Initial commit from Polytechnique Montreal

1 files changed, 1117 insertions, 0 deletions

diff --git a/Dragon/src/CFCDRV.f b/Dragon/src/CFCDRV.f
new file mode 100644
index 0000000..32491f2
--- /dev/null
+++ b/Dragon/src/CFCDRV.f
@@ -0,0 +1,1117 @@
+*DECK CFCDRV
+      SUBROUTINE CFCDRV (IPRINT,NENTRY,KENTRY,HENTRY,NBURN,NGRP,NISO,
+     1 NL,CTITRE,TEX,NXS,NBPARA,DBPARA)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Driver for the construction of a feedback database.
+*
+*Copyright:
+* Copyright (C) 1996 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version.
+*
+*Author(s): M. T. Sissaoui
+*
+*Parameters: input
+* IPRINT  print level.
+* NENTRY  number of LCM objects.
+* KENTRY  address of the LCM objects.
+* HENTRY  name of the LCM objects.
+* NBURN   number of burnup steps.
+* NGRP    number of energy groups.
+* NISO    1+number of extracted isotopes.
+* NL      number of Legendre orders.
+* CTITRE  execution title.
+* TEX     database name.
+* NXS     number of reactions (equal to 21+NL).
+* NBPARA  number of parameters for FBM.
+* DBPARA  values of parameters for FBM.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) KENTRY(NENTRY)
+      INTEGER     IPRINT,NENTRY,NBURN,NGRP,NISO,NL,NXS,NBPARA
+      CHARACTER   HENTRY(NENTRY)*12,TEX*9
+      REAL        DBPARA(NBPARA)
+*----
+*  LOCAL PARAMETERS
+*----
+      TYPE(C_PTR) IPLISU,IPLISD,IPFBM,IPLIST,IPHISU,IPHISD,IPHIST
+      INTEGER     IOUT,NSTATE
+      PARAMETER  (IOUT=6,NSTATE=40)
+      CHARACTER   TEXT1*8,CM*2,TEXT2*8,HMICRO*12,
+     1            TEXTB*12,TEXT(2)*12,TEXTR*12,TEXT12*12,CTITRE*72
+      INTEGER     ISTATE(NSTATE),IPAR(5),HTITLE(18)
+      REAL        XP(7)
+*----
+*  ALLOCATABLE STATEMENTS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,MIJ,MNJ,HISO,JTAB,
+     1 IXS
+      REAL, ALLOCATABLE, DIMENSION(:) :: WORK3,DENSIT,EFJ,KBUR,KB
+      REAL, ALLOCATABLE, DIMENSION(:) :: TOT2,ZN2,DXF2,DYF2,DZF2,HF2,
+     1 SCA2,MIRCT2,MIRCS2,MICDX2,MICDY2,MICDZ2,V2,MIRCF2,MIRCH2
+      REAL, ALLOCATABLE, DIMENSION(:) :: FLUI3,FLDIS3,OV3,DIFD3,NF3,
+     1 CHI3,MCHI3
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ,
+     1 H,REFC,DELTA
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: TMREF,DMRFX,DMRFY,DMRFZ,
+     1 FMREF,HMREF
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: SMREF
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(IJJ(NL*NGRP),NJJ(NL*NGRP),MIJ(NL*NGRP),MNJ(NL*NGRP),
+     1 HISO(3*NISO),JTAB(NISO),IXS(NXS))
+      ALLOCATE(TOTAL(NGRP,NBURN),ZNUG(NGRP,NBURN),DIFFX(NGRP,NBURN),
+     1 DIFFY(NGRP,NBURN),DIFFZ(NGRP,NBURN),H(NGRP,NBURN),
+     2 SCAT(NBURN,NL,NGRP,NGRP),WORK3(NGRP*(NGRP+1)),DENSIT(NISO),
+     3 EFJ(NISO),TMREF(NGRP,NBURN,NISO),SMREF(NISO,NBURN,NL,NGRP,NGRP),
+     4 DMRFX(NGRP,NBURN,NISO),DMRFY(NGRP,NBURN,NISO),
+     5 DMRFZ(NGRP,NBURN,NISO),REFC(NBURN,NISO),FMREF(NGRP,NBURN,NISO),
+     6 HMREF(NGRP,NBURN,NISO),DELTA(NBURN,2))
+*-----
+*  REFERENCE(NOMINAL) LOCAL PARAMETER
+*-----
+      PWR=DBPARA(1)
+      TCR=DBPARA(2)
+      TMR=DBPARA(3)
+      TFR=DBPARA(4)
+      RHOM=DBPARA(5)
+      RHOC=DBPARA(6)
+      XIR=DBPARA(7)
+      TFU=DBPARA(8)
+      TCU=DBPARA(9)
+      PWUL=DBPARA(10)
+      PWDL=DBPARA(11)
+      PWU=DBPARA(12)
+      PWD=DBPARA(13)
+      XI=DBPARA(14)
+C
+C     FLAG FOR COLLISION PROBABILITY CALCULATION
+C     IXYZ=0  PIJ  CALCULATION
+C     IXYZ=1  PIJK  CALCULATION
+C
+       IXYZ=0
+C-----
+C     CHECK NGRP AND NBURN
+C-----
+      IF(NBURN.EQ.0) CALL XABORT('CFCDRV: ZERO NUMBER OF MIXTURES.')
+      IF(NGRP.EQ.0)  CALL XABORT('CFCDRV: ZERO NUMBER OF GROUPS.')
+C
+C     ONLY THE FIRST ORDER IS CONSIDERED IN FBM
+C
+C----------------------------------------------------------------------C
+C-----
+C     DYNAMIC MEMORY ALLOCATION
+C-----
+      ALLOCATE(TOT2(2*NBURN*NGRP),ZN2(2*NBURN*NGRP),DXF2(2*NBURN*NGRP),
+     1 DYF2(2*NBURN*NGRP),DZF2(2*NBURN*NGRP),HF2(2*NBURN*NGRP),
+     2 SCA2(2*NBURN*NL*NGRP*NGRP),MIRCT2(2*NBURN*NISO*NGRP),
+     3 MIRCS2(2*NBURN*NL*NGRP*NGRP*NISO),MICDX2(2*NBURN*NISO*NGRP),
+     4 MICDY2(2*NBURN*NISO*NGRP),MICDZ2(2*NBURN*NISO*NGRP),V2(16*NBURN),
+     5 MIRCF2(2*NBURN*NISO*NGRP),MIRCH2(2*NBURN*NISO*NGRP))
+C
+C-----
+C     DATABASE FILE UNIT NUMBER
+C-----
+         IPFBM=KENTRY(1)
+C-----
+C     STOTRE THE NOMINAL LOCAL PARAMETER IN THE DATABASE
+C     IP=1 FOR THE FUEL
+C     IP=2 FOR THE REFLECTOR
+C-----
+        DO 801 IP=1,2
+C
+C     INITIALIZATION OF THE MATRICES.
+C
+      JTAB(:NISO)=0
+      TOTAL(:NGRP,:NBURN)=0.0
+      ZNUG(:NGRP,:NBURN)=0.0
+      DIFFX(:NGRP,:NBURN)=0.0
+      DIFFY(:NGRP,:NBURN)=0.0
+      DIFFZ(:NGRP,:NBURN)=0.0
+      H(:NGRP,:NBURN)=0.0
+      TMREF(:NGRP,:NBURN,:NISO)=0.0
+      DMRFX(:NGRP,:NBURN,:NISO)=0.0
+      DMRFY(:NGRP,:NBURN,:NISO)=0.0
+      DMRFZ(:NGRP,:NBURN,:NISO)=0.0
+      FMREF(:NGRP,:NBURN,:NISO)=0.0
+      HMREF(:NGRP,:NBURN,:NISO)=0.0
+      SCAT(:NBURN,:NL,:NGRP,:NGRP)=0.0
+      SMREF(:NISO,:NBURN,:NL,:NGRP,:NGRP)=0.0
+      DO 10 IGR=1,NGRP
+      IJJ(IGR)=IGR
+      NJJ(IGR)=1
+      MIJ(IGR)=IGR
+      MNJ(IGR)=1
+  10  CONTINUE
+C
+        DO 44 ILOC=1,7
+        IF(ILOC.EQ.1) THEN
+        HMICRO='PW'
+        XP(ILOC)=PWR
+        ELSE IF(ILOC.EQ.2) THEN
+        HMICRO='TCOOL'
+        XP(ILOC)=TCR
+        ELSE IF(ILOC.EQ.3) THEN
+        HMICRO='TMOD'
+        XP(ILOC)=TMR
+        ELSE IF(ILOC.EQ.4) THEN
+        HMICRO='TFUEL'
+        XP(ILOC)=TFR
+        ELSE IF(ILOC.EQ.5) THEN
+        HMICRO='RHOC'
+        XP(ILOC)=RHOC
+        ELSE IF(ILOC.EQ.6) THEN
+        HMICRO='RHOM'
+        XP(ILOC)=RHOM
+        ELSE IF(ILOC.EQ.7) THEN
+        HMICRO='PUR'
+        XP(ILOC)=XIR
+        ENDIF
+        READ(HMICRO,'(3A4)') (HISO((ILOC-1)*3+IH),IH=1,3)
+  44    CONTINUE
+C-----
+C        TYPE OF PROPERTIES
+C-----
+         IF(IP.EQ.1) THEN
+         IPLIST=KENTRY(2)
+         TEXTR='FUL'//TEX
+         ELSE
+         IPLIST=KENTRY(23)
+         TEXTR='MOD'//TEX
+         ENDIF
+C----------------------------------------------------------------------C
+C-----
+C     RECOVER AND STORE NEUTRONICS PARAMETRES
+C-----
+         IF(IP.EQ.1) THEN
+          CALL LCMSIX(IPFBM,TEXTR,1)
+          CALL LCMSIX(IPFBM,'INFO-NOMINA',1)
+          CALL LCMPUT(IPFBM,'NOMINALN',3*7,3,HISO)
+          CALL LCMPUT(IPFBM,'NOMINALP',7,2,XP)
+          CALL LCMSIX(IPFBM,' ',2)
+          READ(CTITRE,'(18A4)') (HTITLE(I),I=1,18)
+          CALL LCMPUT(IPFBM,'TITLE',18,3,HTITLE)
+          IPAR(1)=NGRP
+          IPAR(2)=NISO
+          IPAR(3)=NL
+          IPAR(4)=NBURN
+          NBUM=NBURN
+          NISM=NISO
+          CALL LCMPUT(IPFBM,'PARAM',4,1,IPAR)
+          CALL LCMSIX(IPFBM,' ',2)
+         ELSE
+          TEXT12='SIGNATURE'
+          CALL LCMNXT(IPLIST,TEXT12)
+C
+          IF(TEXT12.EQ.'SIGNATURE') CALL XABORT('CFCDRV: '
+     1 //'INVALID INPUT COMPO.')
+          CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE)
+          CALL LCMSIX(IPLIST,TEXT12,1)
+          CALL LCMSIX(IPLIST,' ',2)
+          NGRP=ISTATE(2)
+          NISO=ISTATE(3)
+          NL=ISTATE(4)
+          NBURN=ISTATE(5)
+C
+          CALL LCMSIX(IPFBM,TEXTR,1)
+          CALL LCMSIX(IPFBM,'INFO-NOMINA',1)
+          CALL LCMPUT(IPFBM,'NOMINALN',3*7,3,HISO)
+          CALL LCMPUT(IPFBM,'NOMINALP',7,2,XP)
+          CALL LCMSIX(IPFBM,' ',2)
+          READ(CTITRE,'(18A4)') (HTITLE(I),I=1,18)
+          CALL LCMPUT(IPFBM,'TITLE',18,3,HTITLE)
+          CALL LCMSIX(IPFBM,' ',2)
+         ENDIF
+C
+C        RECOVER INFORMATION FROM CPO FILE(NOMINAL)
+C
+         ALLOCATE(KB(NBURN),KBUR(NBURN))
+         IF(IP.EQ.1) THEN
+         CALL LCMSIX(IPLIST,'REF        1',1)
+         ELSE
+         CALL LCMSIX(IPLIST,'MODREF     1',1)
+         ENDIF
+         CALL LCMGET(IPLIST,'ISOTOPESNAME',HISO)
+         CALL LCMGET(IPLIST,'VOLUME',VOL)
+         CALL LCMGET(IPLIST,'ENERGY',WORK3)
+         CALL LCMGET(IPLIST,'BURNUP',KBUR)
+         CALL LCMGET(IPLIST,'N/KB',KB)
+         CALL LCMSIX(IPLIST,' ',2)
+C
+C        STORE INFORMATION IN THE DATABASE
+C
+         CALL LCMSIX(IPFBM,TEXTR,1)
+         CALL LCMPUT(IPFBM,'HITAB',3*NISO,3,HISO)
+         CALL LCMPUT(IPFBM,'VOLUME',1,2,VOL)
+         CALL LCMPUT(IPFBM,'ENERGY',NGRP+1,2,WORK3)
+         CALL LCMPUT(IPFBM,'BURNUP',NBURN,2,KBUR)
+         CALL LCMPUT(IPFBM,'N/KB',NBURN,2,KB)
+         CALL LCMSIX(IPFBM,' ',2)
+C
+         DEALLOCATE(KBUR,KB)
+C-----
+C     GOING DOWN TO THE MACR AND MICR SUB-DIRECTORIES
+C-----
+C
+C        DYNAMIC ALLOCATION MEMORY
+C
+         ALLOCATE(FLUI3(NGRP),FLDIS3(NGRP),OV3(NGRP),DIFD3(3*NGRP),
+     1   NF3(NGRP),CHI3(NGRP),MCHI3(NGRP))
+C
+         DO 20 I=1,NBURN
+         WRITE(TEXTB,'(4HBURN,4X,I4)') I
+         IF(IP.EQ.1) THEN
+         CALL LCMSIX(IPLIST,'REF        1',1)
+         ELSE
+         CALL LCMSIX(IPLIST,'MODREF     1',1)
+         ENDIF
+         CALL LCMSIX(IPLIST,TEXTB,1)
+         CALL LCMGET(IPLIST,'ISOTOPESDENS',DENSIT)
+         CALL LCMGET(IPLIST,'ISOTOPES-EFJ',EFJ)
+         IF(DENSIT(1).NE.1.0) CALL XABORT('FBM: DENSIT(1).NE.1.')
+         CALL LCMGET(IPLIST,'FLUX-INTG',FLUI3)
+         CALL LCMGET(IPLIST,'FLUXDISAFACT',FLDIS3)
+         CALL LCMGET(IPLIST,'OVERV',OV3)
+C-----
+C        RECOVER MACROSCOPIC  X-SECTIONS.
+C-----
+         CALL LCMSIX(IPLIST,'MACR',1)
+         IXS(:NXS)=0
+         CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+         CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+         IF(IXS(18).EQ.1) IXYZ=1
+         IF(IXS(3).EQ.1)  JTAB(1)=1
+C
+         IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TOTAL(1,I))
+         IF(IXS(3).EQ.1) CALL LCMGET(IPLIST,'NUSIGF',ZNUG(1,I))
+         IF(IXS(4).EQ.1) THEN
+           CALL LCMGET(IPLIST,'NFTOT',NF3)
+           CALL LCMGET(IPLIST,'NFTOT',H(1,I))
+           DO 11 IGR=1,NGRP
+           H(IGR,I)=H(IGR,I)*EFJ(1)
+  11       CONTINUE
+         ENDIF
+         IF(IXS(5).EQ.1) CALL LCMGET(IPLIST,'CHI',CHI3)
+         IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD  ',DIFFX(1,I))
+         IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DIFFX(1,I))
+         IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DIFFY(1,I))
+         IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DIFFZ(1,I))
+         CALL LCMLEN(IPLIST,'NUSIGF',ILENGF,ITYLCM)
+C
+C        RECOVER SCATTERING X-SECTIONS.
+C
+         IL=1
+         WRITE (CM,'(I2.2)') IL-1
+         IF(IXS(20+IL).EQ.1) THEN
+         CALL LCMGET(IPLIST,'SIGS'//CM,WORK3)
+         DO 110 IGR=1,NGRP
+         TOTAL(IGR,I)= TOTAL(IGR,I)-WORK3(IGR)
+ 110     CONTINUE
+C
+         CALL LCMLEN(IPLIST,'SCAT'//CM,LENGT,ITYLCM)
+         CALL LCMGET(IPLIST,'SCAT'//CM,WORK3)
+         CALL LCMGET(IPLIST,'NJJS'//CM,NJJ)
+         CALL LCMGET(IPLIST,'IJJS'//CM,IJJ)
+         IGAR=0
+         DO 125 JGR=1,NGRP
+         DO 120 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1
+         IGAR=IGAR+1
+         SCAT(I,IL,IGR,JGR)=WORK3(IGAR)
+  120    CONTINUE
+  125    CONTINUE
+        ENDIF
+C
+         CALL LCMSIX(IPLIST,' ',2)
+C-----
+C       RECOVER MICROSCOPIC  X-SECTIONS.
+C-----
+        DO 40 ISO=2,NISO
+        IF(DENSIT(ISO).EQ.0.0) GO TO 40
+        WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+        REFC(I,ISO)=DENSIT(ISO)
+        CALL LCMSIX(IPLIST,HMICRO,1)
+        CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+        CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+        IF(IXS(3).EQ.1)  JTAB(ISO)=1
+        IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TMREF(1,I,ISO))
+C
+C       COMPUTE THE ABSORPTION XS
+C
+        IL=1
+        WRITE (CM,'(I2.2)') IL-1
+         IF(IXS(20+IL).EQ.1) THEN
+          CALL LCMGET(IPLIST,'SIGS'//CM,WORK3)
+          DO 231 IGR=1,NGRP
+          TMREF(IGR,I,ISO)= TMREF(IGR,I,ISO)-WORK3(IGR)
+ 231      CONTINUE
+         ENDIF
+C
+         IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD  ',DMRFX(1,I,ISO))
+         IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DMRFX(1,I,ISO))
+         IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DMRFY(1,I,ISO))
+         IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DMRFZ(1,I,ISO))
+C
+C      ADD THE CONTRIBURTION OF THE MICR. X-SECTIONS
+C
+       DO 721 IGR=1,NGRP
+       TOTAL(IGR,I)=TOTAL(IGR,I) + DENSIT(ISO)*TMREF(IGR,I,ISO)
+       DIFFX(IGR,I)=DIFFX(IGR,I) + DENSIT(ISO)*DMRFX(IGR,I,ISO)
+       DIFFY(IGR,I)=DIFFY(IGR,I) + DENSIT(ISO)*DMRFY(IGR,I,ISO)
+       DIFFZ(IGR,I)=DIFFZ(IGR,I) + DENSIT(ISO)*DMRFZ(IGR,I,ISO)
+  721  CONTINUE
+C
+       IF(IXS(3).EQ.1) THEN
+       CALL LCMGET(IPLIST,'NUSIGF',FMREF(1,I,ISO))
+       DO 30 IGR=1,NGRP
+       ZNUG(IGR,I)=ZNUG(IGR,I) + DENSIT(ISO)*FMREF(IGR,I,ISO)
+ 30    CONTINUE
+       ENDIF
+       IF(IXS(4).EQ.1) THEN
+          CALL LCMGET(IPLIST,'NFTOT',WORK3)
+          CALL LCMGET(IPLIST,'NFTOT',HMREF(1,I,ISO))
+          DO 31 IGR=1,NGRP
+          HMREF(IGR,I,ISO)=HMREF(IGR,I,ISO)*EFJ(ISO)
+          NF3(IGR)=NF3(IGR)+DENSIT(ISO)*WORK3(IGR)
+          H(IGR,I)=H(IGR,I) + DENSIT(ISO)*HMREF(IGR,I,ISO)
+  31      CONTINUE
+         ENDIF
+         IF(IXS(5).EQ.1) CALL LCMGET(IPLIST,'CHI',MCHI3)
+      CALL LCMSIX(IPLIST,' ',2)
+   40 CONTINUE
+         CALL LCMSIX(IPLIST,' ',2)
+         CALL LCMSIX(IPLIST,' ',2)
+C----------------------------------------------------------------------C
+C-----
+C     STORE PROPERTIES
+C-----
+         CALL LCMSIX(IPFBM,TEXTR,1)
+C
+         CALL LCMPUT(IPFBM,'JTAB',NISO,1,JTAB)
+C
+         CALL LCMSIX(IPFBM,TEXTB,1)
+         CALL LCMPUT(IPFBM,'ISOTOPESDENS',NISO,2,DENSIT)
+         CALL LCMPUT(IPFBM,'FLUX-INTG',NGRP,2,FLUI3)
+         CALL LCMPUT(IPFBM,'OVERV',NGRP,2,OV3)
+         CALL LCMPUT(IPFBM,'FLUXDISAFACT',NGRP,2,FLDIS3)
+C
+C        STORE MACROSCOPIC X-SECTIONS
+C
+         CALL LCMSIX(IPFBM,'MACR',1)
+         CALL LCMSIX(IPFBM,'ABS',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,TOTAL(1,I))
+         CALL LCMSIX(IPFBM,' ',2)
+         IF(IXYZ.EQ.0) THEN
+         CALL LCMSIX(IPFBM,'STRD',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFX(1,I))
+         CALL LCMSIX(IPFBM,' ',2)
+         ELSE IF(IXYZ.EQ.1) THEN
+         CALL LCMSIX(IPFBM,'STRD X',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFX(1,I))
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMSIX(IPFBM,'STRD Y',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFY(1,I))
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMSIX(IPFBM,'STRD Z',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,DIFFZ(1,I))
+         CALL LCMSIX(IPFBM,' ',2)
+         ENDIF
+         IF(JTAB(1).EQ.1) THEN
+         CALL LCMSIX(IPFBM,'NUSIGF',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,ZNUG(1,I))
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMSIX(IPFBM,'H-FACTORS',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,H(1,I))
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMPUT(IPFBM,'CHI',NGRP,2,CHI3)
+         CALL LCMPUT(IPFBM,'NFTOT',NGRP,2,NF3)
+         ENDIF
+         CALL LCMSIX(IPFBM,' ',2)
+C
+C        STORE MICROSCOPIC X-SECTIONS
+C
+         DO 49 ISO=2,NISO
+         IF(DENSIT(ISO).EQ.0.0) GO TO 49
+         WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+         CALL LCMSIX(IPFBM,HMICRO,1)
+         CALL LCMSIX(IPFBM,'ABS',1)
+         CALL LCMPUT(IPFBM,'REF',NGRP,2,TMREF(1,I,ISO))
+         CALL LCMSIX(IPFBM,' ',2)
+         IF(IXYZ.EQ.0) THEN
+           CALL LCMSIX(IPFBM,'STRD',1)
+           CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFX(1,I,ISO))
+           CALL LCMSIX(IPFBM,' ',2)
+         ELSE IF(IXYZ.EQ.1) THEN
+           CALL LCMSIX(IPFBM,'STRD X',1)
+           CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFX(1,I,ISO))
+           CALL LCMSIX(IPFBM,' ',2)
+           CALL LCMSIX(IPFBM,'STRD Y',1)
+           CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFY(1,I,ISO))
+           CALL LCMSIX(IPFBM,' ',2)
+           CALL LCMSIX(IPFBM,'STRD Z',1)
+           CALL LCMPUT(IPFBM,'REF',NGRP,2,DMRFZ(1,I,ISO))
+           CALL LCMSIX(IPFBM,' ',2)
+         ENDIF
+         IF(JTAB(ISO).EQ.1) THEN
+           CALL LCMSIX(IPFBM,'NUSIGF',1)
+           CALL LCMPUT(IPFBM,'REF',NGRP,2,FMREF(1,I,ISO))
+           CALL LCMSIX(IPFBM,' ',2)
+           CALL LCMSIX(IPFBM,'H-FACTORS',1)
+           CALL LCMPUT(IPFBM,'REF',NGRP,2,HMREF(1,I,ISO))
+           CALL LCMSIX(IPFBM,' ',2)
+           CALL LCMPUT(IPFBM,'CHI',NGRP,2,MCHI3)
+         ENDIF
+         CALL LCMSIX(IPFBM,' ',2)
+   49    CONTINUE
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMSIX(IPFBM,' ',2)
+C-----
+C     RECOVER MICROSCOPIC CONTRIBUTIONS OF SCATTERING X-SECTIONS.
+C-----
+      DO 160 ISO=2,NISO
+      IF(DENSIT(ISO).EQ.0.0) GO TO 160
+      WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+      IF(IP.EQ.1) THEN
+         CALL LCMSIX(IPLIST,'REF        1',1)
+         ELSE
+         CALL LCMSIX(IPLIST,'MODREF     1',1)
+         ENDIF
+      CALL LCMSIX(IPLIST,TEXTB,1)
+      CALL LCMLEN(IPLIST,HMICRO,ILENG,ITYLCM)
+      IF(ILENG.NE.0) THEN
+      CALL LCMSIX(IPLIST,HMICRO,1)
+      CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+      CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+C
+      IL=1
+      WRITE (CM,'(I2.2)') IL-1
+      IF(IXS(20+IL).EQ.1) THEN
+         CALL LCMGET(IPLIST,'SCAT'//CM,WORK3)
+         CALL LCMGET(IPLIST,'NJJS'//CM,NJJ)
+         CALL LCMGET(IPLIST,'IJJS'//CM,IJJ)
+         IGAR=0
+         DO 150 JGR=1,NGRP
+         DO 140 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1
+         IGAR=IGAR+1
+         SMREF(ISO,I,IL,IGR,JGR)=WORK3(IGAR)
+         SCAT(I,IL,IGR,JGR)=SCAT(I,IL,IGR,JGR)+DENSIT(ISO)*WORK3(IGAR)
+  140    CONTINUE
+  150    CONTINUE
+        ENDIF
+C
+        CALL LCMSIX(IPLIST,' ',2)
+      ENDIF
+      CALL LCMSIX(IPLIST,' ',2)
+      CALL LCMSIX(IPLIST,' ',2)
+  160 CONTINUE
+C----------------------------------------------------------------------C
+C
+C        STORE MACROSCOPIC SCATTERING X-SECTIONS
+C
+         CALL LCMSIX(IPFBM,TEXTR,1)
+         CALL LCMSIX(IPFBM,TEXTB,1)
+C
+         CALL LCMSIX(IPFBM,'MACR',1)
+         IL=1
+         WRITE (CM,'(I2)') IL-1
+         CALL LCMSIX(IPFBM,'SCAT'//CM,1)
+         IGARM=0
+         DO 799 JGR=1,NGRP
+         IGRMIN=JGR
+         IGRMAX=JGR
+         DO 899 IGR=1,NGRP
+          IF(SCAT(I,IL,IGR,JGR).NE.0.0) THEN
+                    IGRMIN=MIN(IGRMIN,IGR)
+                    IGRMAX=MAX(IGRMAX,IGR)
+          ENDIF
+ 899     CONTINUE
+         MIJ(JGR)=IGRMAX
+         MNJ(JGR)=IGRMAX-IGRMIN+1
+         DO 795 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1
+         IGARM=IGARM+1
+         WORK3(IGARM)=SCAT(I,IL,IGR,JGR)
+  795    CONTINUE
+  799   CONTINUE
+         CALL LCMPUT(IPFBM,'NJJ',NGRP,1,MNJ)
+         CALL LCMPUT(IPFBM,'IJJ',NGRP,1,MIJ)
+         CALL LCMPUT(IPFBM,'REF',IGARM,2,WORK3)
+         CALL LCMSIX(IPFBM,' ',2)
+C
+C
+         CALL LCMSIX(IPFBM,' ',2)
+C
+C
+C       STORE THE SCATTERING X-SECTIONS
+C
+         DO 860 ISO=2,NISO
+         IF(DENSIT(ISO).EQ.0.0) GO TO 860
+         WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+         CALL LCMSIX(IPFBM,HMICRO,1)
+         IL=1
+         WRITE (CM,'(I2)') IL-1
+         CALL LCMSIX(IPFBM,'SCAT'//CM,1)
+         IGARM=0
+         DO 105 JGR=1,NGRP
+         DO 100 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1
+         IGARM=IGARM+1
+         WORK3(IGARM)=SMREF(ISO,I,IL,IGR,JGR)
+  100    CONTINUE
+  105    CONTINUE
+         CALL LCMPUT(IPFBM,'REF',IGARM,2,WORK3)
+         CALL LCMPUT(IPFBM,'NJJ',NGRP,1,MNJ)
+         CALL LCMPUT(IPFBM,'IJJ',NGRP,1,MIJ)
+         CALL LCMSIX(IPFBM,' ',2)
+C
+         CALL LCMSIX(IPFBM,' ',2)
+  860    CONTINUE
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMSIX(IPFBM,' ',2)
+  20     CONTINUE
+C
+         DEALLOCATE(MCHI3,CHI3,NF3,DIFD3,OV3,FLDIS3,FLUI3)
+         WRITE(IOUT,9000)
+C----------------------------------------------------------------------C
+C                                                                      C
+C  FUEL COEFFICIENTS CALCULATIONS                                      C
+C                                                                      C
+C----------------------------------------------------------------------C
+C MIXP =0 : INDIVIDUAL LOCAL PARAMETER                                 C
+C MIXP =1 : MIXDED     LOCAL PARAMETER                                 C
+C NB   =1 : THE COEFFICIENTS CALCULATION REQUIRE ONE L_COMPO           C
+C NB   =2 : THE COEFFICIENTS CALCULATION REQUIRE TWO L_COMPO           C
+C TEXT1   : FIRST RECORD ON WHICH THE COEFF. ARE STORED (NB=1)         C
+C TEXT2   : SECOND RECORD ON WHICH THE COEFF. ARE STORED (NB=2)        C
+C----------------------------------------------------------------------C
+C
+       IF(IP.EQ.1) THEN
+       DO 111 J=1,5
+       JJU=2*J+1
+       JJD=2*J+2
+       IPLISU=KENTRY(JJU)
+       IPLISD=KENTRY(JJD)
+       IF(ABS(IPRINT) .GT. 5) THEN
+         WRITE(IOUT,6000) JJU,HENTRY(JJU),JJD,HENTRY(JJD)
+       ENDIF 
+       NB=2
+       MIXP=0
+C-----
+C     COMPUTE  FUEL TEMPERATURE COEFFICIENTS (TWO L_COMPO)
+C-----
+       IF(J.EQ.1) THEN
+        TEXT(1)='SIGNATURE'
+        CALL LCMNXT(IPLISU,TEXT(1))
+        IF(TEXT(1).NE.'FTEMP-UP   1') THEN
+        CALL XABORT('CFCDRV: FTEMP-UP COMPO EXPECTED.')
+        ENDIF
+        TEXT(2)='SIGNATURE'
+        CALL LCMNXT(IPLISD,TEXT(2))
+        IF(TEXT(2).NE.'FTEMP-D    1') CALL XABORT('CFCDRV: '
+     1   //' FTEMP-D COMPO EXPECTED.')
+        TEXT1='T1F'
+        TEXT2='T2F'
+C-----
+C     COMPUTE  COOLANT TEMPERATURE COEFFICIENTS (TWO L_COMPO)
+C-----
+       ELSE IF(J.EQ.2) THEN
+       TEXT(1)='SIGNATURE'
+       CALL LCMNXT(IPLISU,TEXT(1))
+       IF(TEXT(1).NE.'CTEMP-UP   1') THEN
+       CALL XABORT('CFCDRV: CTEMP-UP COMPO EXPECTED.')
+       ENDIF
+       TEXT(2)='SIGNATURE'
+       CALL LCMNXT(IPLISD,TEXT(2))
+       IF(TEXT(2).NE.'CTEMP-D    1') CALL XABORT('CFCDRV:'
+     1  //' CTEMP-D COMPO EXPECTED.')
+       TEXT1='T1C'
+       TEXT2='T2C'
+C-----
+C     COMPUTE  MODERATOR TEMPERATURE COEFFICIENTS (TWO L_COMPO)
+C-----
+      ELSE IF(J.EQ.3) THEN
+      TEXT(1)='SIGNATURE'
+      CALL LCMNXT(IPLISU,TEXT(1))
+      IF(TEXT(1).NE.'MTEMP-UP   1') THEN
+      CALL XABORT('CFCDRV: MTEMP-UP COMPO EXPECTED.')
+      ENDIF
+      TEXT(2)='SIGNATURE'
+      CALL LCMNXT(IPLISD,TEXT(2))
+      IF(TEXT(2).NE.'MTEMP-D    1') CALL XABORT('CFCDRV:'
+     1  //' MTEMP-D COMPO EXPECTED.')
+      TEXT1='T1M'
+      TEXT2='T2M'
+C-----
+C      COMPUTE  COOLANT DENSITY COEFFICIENTS (TWO L_COMPO)
+C-----
+       ELSE IF(J.EQ.4) THEN
+       TEXT(1)='SIGNATURE'
+       CALL LCMNXT(IPLISU,TEXT(1))
+       IF(TEXT(1).NE.'CDEN-UP    1') THEN
+       CALL XABORT('CFCDRV: CDEN-UP COMPO EXPECTED.')
+       ENDIF
+       TEXT(2)='SIGNATURE'
+       CALL LCMNXT(IPLISD,TEXT(2))
+       IF(TEXT(2).NE.'CDEN-D     1') CALL XABORT('CFCDRV:'
+     1 //' CDEN-D COMPO EXPECTED.')
+       TEXT1='D1C'
+       TEXT2='D2C'
+C-----
+C     COMPUTE  MODERATOR DENSITY COEFFICIENTS (TWO L_COMPO)
+C-----
+      ELSE IF(J.EQ.5) THEN
+      TEXT(1)='SIGNATURE'
+      CALL LCMNXT(IPLISU,TEXT(1))
+      IF(TEXT(1).NE.'MDEN-UP    1') THEN
+      CALL XABORT('CFCDRV: MDEN-UP COMPO EXPECTED.')
+      ENDIF
+      TEXT(2)='SIGNATURE'
+      CALL LCMNXT(IPLISD,TEXT(2))
+      IF(TEXT(2).NE.'MDEN-D     1') CALL XABORT('CFCDRV:'
+     1//'  MDEN-D COMPO EXPECTED.')
+      TEXT1='D1M'
+      TEXT2='D2M'
+      ENDIF
+C
+         CALL CFCFBM(TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM,
+     1   NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ,
+     1   H,SCAT,MIJ,MNJ,TMREF,SMREF,DMRFX,DMRFY,DMRFZ,TOT2,ZN2,DXF2,
+     1   DYF2,DZF2,HF2,SCA2,WORK3,REFC,MIRCT2,MIRCS2,MICDX2,MICDY2,
+     1   MICDZ2,DELTA,DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB,MIRCF2,
+     1   MIRCH2,FMREF,HMREF,JTAB,MIXP,V2,EFJ,NXS,IXYZ,NBPARA,DBPARA)
+ 111   CONTINUE
+       WRITE(IOUT,9001)
+C----------------------------------------------------------------------C
+C                                                                      C
+C                                                                      C
+C----------------------------------------------------------------------C
+       DO 112 J=13,21
+       IPLISU=KENTRY(J)
+       IPLISD=IPLISU
+       NB=1
+       MIXP=0
+       IF(ABS(IPRINT) .GT. 5) THEN
+         WRITE(IOUT,6001) J,HENTRY(J)
+       ENDIF 
+C-----
+C      COMPUTE BORON COEFFICIENTS (ONE L_COMPO)
+C-----
+       IF(J.EQ.13) THEN
+       TEXT(1)='SIGNATURE'
+       CALL LCMNXT(IPLISU,TEXT(1))
+        IF(TEXT(1).NE.'BORON      1') THEN
+        CALL XABORT('CFCDRV: BORON COMPO EXPECTED.')
+        ENDIF
+       TEXT1='BOR'
+       TEXT2='BOR'
+       TEXT(2)=TEXT(1)
+C-----
+C      COMPUTE PURITY COEFFICIENTS (ONE L_COMPO)
+C-----
+       ELSE IF(J.EQ.14) THEN
+       TEXT(1)='SIGNATURE'
+       CALL LCMNXT(IPLISU,TEXT(1))
+        IF(TEXT(1).NE.'PURITY     1') THEN
+        CALL XABORT('CFCDRV: BORON COMPO EXPECTED.')
+        ENDIF
+       TEXT1='PUR'
+       TEXT2='PUR'
+       TEXT(2)=TEXT(1)
+C-----
+C       COMPUTE  XENON COEFFICIENTS (ONE L_COMPO)
+C-----
+        ELSE IF(J.EQ.15) THEN
+        TEXT(1)='SIGNATURE'
+        CALL LCMNXT(IPLISU,TEXT(1))
+         IF(TEXT(1).NE.'XENON      1') THEN
+         CALL XABORT('CFCDRV: XENON COMPO EXPECTED.')
+         ENDIF
+        TEXT1='XEN'
+        TEXT2='XEN'
+        TEXT(2)=TEXT(1)
+C-----
+C      COMPUTE  SAMARIUM COEFFICIENTS (ONE L_COMPO)
+C-----
+       ELSE IF(J.EQ.16) THEN
+       TEXT(1)='SIGNATURE'
+       CALL LCMNXT(IPLISU,TEXT(1))
+        IF(TEXT(1).NE.'SM149      1') THEN
+        CALL XABORT('CFCDRV: SM149 COMPO EXPECTED.')
+        ENDIF
+       TEXT1='SM149'
+       TEXT2='SM149'
+       TEXT(2)=TEXT(1)
+C-----
+C       COMPUTE  NP239 COEFFICIENTS (ONE L_COMPO)
+C-----
+        ELSE IF(J.EQ.17) THEN
+        TEXT(1)='SIGNATURE'
+        CALL LCMNXT(IPLISU,TEXT(1))
+         IF(TEXT(1).NE.'NP239      1') THEN
+         CALL XABORT('CFCDRV: NP239 COMPO EXPECTED.')
+         ENDIF
+        TEXT1='NP239'
+        TEXT2='NP239'
+        TEXT(2)=TEXT(1)
+C-----
+C       COMPUTE MIXED FUEL AND DENSITY COEFFICIENTS (ONE L_COMPO)
+C-----
+        ELSE IF(J.EQ.18) THEN
+        TEXT(1)='SIGNATURE'
+        CALL LCMNXT(IPLISU,TEXT(1))
+         IF(TEXT(1).NE.'MIXFD      1') THEN
+         CALL XABORT('CFCDRV: MIXFD COMPO EXPECTED.')
+         ENDIF
+         MIXP=1
+        TEXT1='MIXFD'
+        TEXT2='MIXFD'
+        TEXT(2)=TEXT(1)
+C-----
+C       COMPUTE MIXED COLLANT AND DENSITY COEFFICIENTS (ONE L_COMPO)
+C-----
+        ELSE IF(J.EQ.19) THEN
+        TEXT(1)='SIGNATURE'
+        CALL LCMNXT(IPLISU,TEXT(1))
+         IF(TEXT(1).NE.'MIXMD      1') THEN
+         CALL XABORT('CFCDRV: MIXMD COMPO EXPECTED.')
+         ENDIF
+         MIXP=1
+        TEXT1='MIXMD'
+        TEXT2='MIXMD'
+        TEXT(2)=TEXT(1)
+C-----
+C      COMPUTE (HIGH)FISSION ISOTOPES COEFFICIENTS  (TWO L_COMPO)
+C-----
+      ELSE IF(J.EQ.20) THEN
+      TEXT(1)='SIGNATURE'
+      CALL LCMNXT(IPLISU,TEXT(1))
+       IF(TEXT(1).NE.'POWER-UP   1') THEN
+       CALL XABORT('CFCDRV: POWER-UP COMPO EXPECTED.')
+       ENDIF
+       IPLISD=KENTRY(J+1)
+       TEXT(2)='SIGNATURE'
+       CALL LCMNXT(IPLISD,TEXT(2))
+       IF(TEXT(2).NE.'POWER-IN   1') CALL XABORT('CFCDRV:'
+     1  //'  POWER-D COMPO EXPECTED.')
+       MIXP=1
+       NB=2
+       TEXT1='FPCH1'
+       TEXT2='FPCH2'
+C-----
+C     COMPUTE LOW FISSION ISOTOPES COEFFICIENTS (TWO L_COMPO)
+C-----
+      ELSE IF(J.EQ.21) THEN
+      TEXT(1)='SIGNATURE'
+      CALL LCMNXT(IPLISU,TEXT(1))
+       IF(TEXT(1).NE.'POWER-IN   1') THEN
+       CALL XABORT('CFCDRV: POWER-UP COMPO EXPECTED.')
+       ENDIF
+       IPLISD=KENTRY(J+1)
+       TEXT(2)='SIGNATURE'
+       CALL LCMNXT(IPLISD,TEXT(2))
+       IF(TEXT(2).NE.'POWER-D    1') CALL XABORT('CFCDRV:'
+     1  //'  POWER-D COMPO EXPECTED.')
+       MIXP=1
+       NB=2
+       TEXT1='FPCL1'
+       TEXT2='FPCL2'
+      ENDIF
+         IF(ABS(IPRINT) .GT. 5) THEN
+           WRITE(IOUT,6002) TEXT1,TEXT2
+         ENDIF 
+C
+         CALL CFCFBM(TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM,
+     1   NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ,
+     1   H,SCAT,MIJ,MNJ,TMREF,SMREF,DMRFX,DMRFY,DMRFZ,TOT2,ZN2,
+     1   DXF2, DYF2,DZF2,HF2,SCA2,WORK3,REFC,MIRCT2,MIRCS2,MICDX2,
+     1   MICDY2,MICDZ2,DELTA,DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB,
+     1   MIRCF2,MIRCH2,FMREF,HMREF,JTAB,MIXP,V2,EFJ,NXS,IXYZ,NBPARA,
+     1   DBPARA)
+ 112   CONTINUE
+       WRITE(IOUT,9002)
+C----------------------------------------------------------------------C
+C                                                                      C
+C                                                                      C
+C----------------------------------------------------------------------C
+C-----
+C        COMPUTE THE HISTORY CONCENTRATION
+C-----
+         DO 650 JJ=1,2
+         IF(JJ.EQ.1) THEN
+          IPHISU=KENTRY(21)
+          IPHISD=KENTRY(22)
+          TEXT(1)='SIGNATURE'
+          CALL LCMNXT(IPHISU,TEXT(1))
+          IF(TEXT(1).NE.'POWER-IN   1') THEN
+          CALL XABORT('CFCDRV: POWER-IN COMPO EXPECTED.')
+          ENDIF
+          TEXT(2)='SIGNATURE'
+          CALL LCMNXT(IPHISD,TEXT(2))
+          IF(TEXT(2).NE.'POWER-D    1') CALL XABORT('CFCDRV:'
+     1    //'  POWER-D COMPO EXPECTED.')
+          NB=2
+C          TEXT1='PHIS1'
+C          TEXT2='PHIS2'
+          ELSE IF(JJ.EQ.2) THEN
+          IPHISU=KENTRY(20)
+          IPHISD=KENTRY(21)
+          TEXT(1)='SIGNATURE'
+          CALL LCMNXT(IPHISU,TEXT(1))
+          IF(TEXT(1).NE.'POWER-UP   1') THEN
+          CALL XABORT('CFCDRV: POWER-UP COMPO EXPECTED.')
+          ENDIF
+          TEXT(2)='SIGNATURE'
+          CALL LCMNXT(IPHISD,TEXT(2))
+          IF(TEXT(2).NE.'POWER-IN   1') CALL XABORT('CFCDRV:'
+     1    //'  POWER-D COMPO EXPECTED.')
+          NB=2
+C          TEXT1='PHIL1'
+C          TEXT2='PHIL2'
+        ENDIF
+C-----
+C         STORE THE HISTORY COEFFICIENTS
+C-----
+         DO 730 JP=1,4
+         IF(JP.EQ.1) THEN
+           TEXT12='FPC'
+             IF(JJ.EQ.1) THEN
+               TEXT1='PHIS1'
+               TEXT2='PHIS2'
+             ELSE
+               TEXT1='PHIL1'
+               TEXT2='PHIL2'
+             ENDIF
+         ELSE IF(JP.EQ.2) THEN
+           TEXT12='XE135'
+             IF(JJ.EQ.1) THEN
+               TEXT1='PHISX1'
+               TEXT2='PHISX2'
+             ELSE
+               TEXT1='PHILX1'
+               TEXT2='PHILX2'
+             ENDIF
+         ELSE IF(JP.EQ.3) THEN
+           TEXT12='SM149'
+              IF(JJ.EQ.1) THEN
+               TEXT1='PHISS1'
+               TEXT2='PHISS2'
+             ELSE
+               TEXT1='PHILS1'
+               TEXT2='PHILS2'
+             ENDIF
+         ELSE IF(JP.EQ.4) THEN
+           TEXT12='NP239'
+             IF(JJ.EQ.1) THEN
+               TEXT1='PHISN1'
+               TEXT2='PHISN2'
+             ELSE
+               TEXT1='PHILN1'
+               TEXT2='PHILN2'
+             ENDIF
+         ENDIF
+         DO 630 JB=1,NB
+            IF(JB.EQ.1) IPHIST=IPHISU
+            IF(JB.EQ.2) IPHIST=IPHISD
+         CALL LCMSIX(IPHIST,TEXT(JB),1)
+         CALL LCMGET(IPHIST,'ISOTOPESNAME',HISO)
+         DO 621 I=1,NBURN
+         WRITE(TEXTB,'(4HBURN,4X,I4)') I
+         CALL LCMSIX(IPHIST,TEXTB,1)
+         CALL LCMGET(IPHIST,'ISOTOPESDENS',DENSIT)
+         IF(DENSIT(1).NE.1.0) CALL XABORT('FBM: DENSIT(1).NE.1.')
+      DO 649 ISO=2,NISO
+      WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+      IF(HMICRO.EQ.TEXT12) DELTA(I,JB)=DENSIT(ISO)- REFC(I,ISO)
+ 649   CONTINUE
+      CALL LCMSIX(IPHIST,' ',2)
+ 621   CONTINUE
+      CALL LCMSIX(IPHIST,' ',2)
+ 630   CONTINUE
+       DO 622 I=1,NBURN
+        IF(NB.EQ.2) THEN
+        PV1U=0.0
+        PV2U=0.0
+        PV1D=0.0
+        PV2D=0.0
+        IF(JJ.EQ.1) THEN
+         PV1U=PWU-PWR
+         PV2U=PV1U*PV1U
+         PV1D=PWD-PWR
+         PV2D=PV1D*PV1D
+        ELSE IF(JJ.EQ.2) THEN
+         PV1U=ALOG(PWUL/PWR)
+         PV2U=1.0/PWUL - 1.0/PWR
+         PV1D=ALOG(PWDL/PWR)
+         PV2D=1.0/PWDL - 1.0/PWR
+        ENDIF
+        TX=PV2U*PV1D - PV2D*PV1U
+        DELTA(I,2)=(DELTA(I,1)*PV1D-DELTA(I,2)*PV1U)/TX
+        DELTA(I,1)=(DELTA(I,1) - DELTA(I,2)*PV2U)/PV1U
+C
+       ENDIF
+C
+         CALL LCMSIX(IPFBM,TEXTR,1)
+         WRITE(TEXTB,'(4HBURN,4X,I4)') I
+         CALL LCMSIX(IPFBM,TEXTB,1)
+         CALL LCMSIX(IPFBM,'HISTORY',1)
+         CALL LCMPUT(IPFBM,TEXT1,1,2,DELTA(I,1))
+         IF(NB.EQ.2) THEN
+         CALL LCMPUT(IPFBM,TEXT2,1,2,DELTA(I,2))
+         ENDIF
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMSIX(IPFBM,' ',2)
+         CALL LCMSIX(IPFBM,' ',2)
+ 622    CONTINUE
+ 730    CONTINUE
+ 650    CONTINUE
+        WRITE(IOUT,9003)
+        ELSE
+C----------------------------------------------------------------------C
+C                                                                      C
+C       MODERATOR CALCULATIONS                                         C
+C                                                                      C
+C----------------------------------------------------------------------C
+       DO 811 J=1,4
+       NB=2
+       MIXP=0
+C-----
+C     COMPUTE  MODERATOR TEMPERATURE COEFFICIENTS
+C-----
+      IF(J.EQ.1) THEN
+       IPLISU=KENTRY(24)
+       IPLISD=KENTRY(25)
+      TEXT(1)='SIGNATURE'
+      CALL LCMNXT(IPLISU,TEXT(1))
+       IF(TEXT(1).NE.'MODTP-UP   1') THEN
+       CALL XABORT('CFCDRV: MTEMP-UP COMPO EXPECTED.')
+       ENDIF
+      TEXT(2)='SIGNATURE'
+      CALL LCMNXT(IPLISD,TEXT(2))
+       IF(TEXT(2).NE.'MODTP-D    1') CALL XABORT('CFCDRV:'
+     1  //' MTEMP-D COMPO EXPECTED.')
+        TEXT1='T1M'
+        TEXT2='T2M'
+C-----
+C     COMPUTE  MODERATOR DENSITY COEFFICIENTS
+C-----
+      ELSE IF(J.EQ.2) THEN
+       IPLISU=KENTRY(26)
+       IPLISD=KENTRY(27)
+      TEXT(1)='SIGNATURE'
+      CALL LCMNXT(IPLISU,TEXT(1))
+       IF(TEXT(1).NE.'MODDEN-U   1') THEN
+       CALL XABORT('CFCDRV: MDEN-UP COMPO EXPECTED.')
+       ENDIF
+       TEXT(2)='SIGNATURE'
+       CALL LCMNXT(IPLISD,TEXT(2))
+       IF(TEXT(2).NE.'MODDEN-D   1') CALL XABORT('CFCDRV:'
+     1  //'  MDEN-D COMPO EXPECTED.')
+       TEXT1='D1M'
+       TEXT2='D2M'
+C-----
+C     COMPUTE BORON COEFFICIENTS
+C-----
+      ELSE IF(J.EQ.3) THEN
+       NB=1
+       MIXP=0
+       IPLISU=KENTRY(28)
+       TEXT(1)='SIGNATURE'
+       CALL LCMNXT(IPLISU,TEXT(1))
+        IF(TEXT(1).NE.'MODBOR     1') THEN
+        CALL XABORT('CFCDRV: BORON COMPO EXPECTED.')
+        ENDIF
+       TEXT1='BOR'
+       TEXT2='BOR'
+       TEXT(2)=TEXT(1)
+C-----
+C      COMPUTE PURITY COEFFICIENTS
+C-----
+       ELSE IF(J.EQ.4) THEN
+       NB=1
+       MIXP=0
+       IPLISU=KENTRY(29)
+       TEXT(1)='SIGNATURE'
+       CALL LCMNXT(IPLISU,TEXT(1))
+        IF(TEXT(1).NE.'MODPUR     1') THEN
+        CALL XABORT('CFCDRV: BORON COMPO EXPECTED.')
+        ENDIF
+       TEXT1='PUR'
+       TEXT2='PUR'
+       TEXT(2)=TEXT(1)
+       ENDIF
+C
+         CALL CFCFBM(TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM,
+     1   NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ,
+     1   H,SCAT,MIJ,MNJ,TMREF,SMREF,DMRFX,DMRFY,DMRFZ,TOT2,ZN2,
+     1   DXF2, DYF2,DZF2,HF2,SCA2,WORK3,REFC,MIRCT2,MIRCS2,MICDX2,
+     1   MICDY2,MICDZ2,DELTA,DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB,
+     1   MIRCF2,MIRCH2,FMREF,HMREF,JTAB,MIXP,V2,EFJ,NXS,IXYZ,NBPARA,
+     1   DBPARA)
+C
+ 811   CONTINUE
+       WRITE(IOUT,9004)
+        ENDIF
+C-----
+C       STORE PARAM INFORMATION
+C-----
+          CALL LCMSIX(IPFBM,TEXTR,1)
+          IPAR(1)=NGRP
+          IPAR(2)=NISO
+          IPAR(3)=NL
+          IPAR(4)=NBURN
+          IPAR(5)=IXYZ
+          CALL LCMPUT(IPFBM,'PARAM',5,1,IPAR)
+          CALL LCMSIX(IPFBM,'     ',2)
+ 801   CONTINUE
+C----------------------------------------------------------------------C
+C        RELEASE MEMORY                                                C
+C----------------------------------------------------------------------C
+         DEALLOCATE(MIRCH2,MIRCF2,V2,MICDZ2,MICDY2,MICDX2,MIRCS2,
+     >   MIRCT2,SCA2,HF2,DZF2,DYF2,DXF2,ZN2,TOT2)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(DELTA,HMREF,FMREF,REFC,DMRFZ,DMRFY,DMRFX,SMREF,TMREF,
+     > EFJ,DENSIT,WORK3,SCAT,H,DIFFZ,DIFFY,DIFFX,ZNUG,TOTAL)
+      DEALLOCATE(IXS,JTAB,HISO,MNJ,MIJ,NJJ,IJJ)
+*
+      RETURN
+ 6000 FORMAT(' CPO ',I4,' for up parameter named   = ',A12/
+     >       ' CPO ',I4,' for down parameter named = ',A12)
+ 6001 FORMAT(' CPO ',I4,' with name ',A12)
+ 6002 FORMAT(' Records ',2(A8,4X))
+ 9000 FORMAT(' CELL REFERENCE (NOMINAL) PARAMETER ARE STORED')
+ 9001 FORMAT(' CELL FEEDBACK COEFFICIENTS CORRESPONDING TO:'/
+     >       ' FUEL      TEMPERATURE,'/
+     >       ' COOLANT   TEMPERATURE,'/
+     >       ' MODERATOR TEMPERATURE,'/
+     >       ' COOLANT   DENSITY    ,'/
+     >       ' MODERATOR DENSITY    ,')
+ 9002 FORMAT(' CELL FEEDBACK COEFFICIENTS CORRESPONDING TO:'/
+     >       ' BORON      CONCENTRATION,'/
+     >       ' MODERATOR  PURITY       ,'/
+     >       ' XENON      CONCENTRATION,'/
+     >       ' SAMARIUM   CONCENTRATION,'/
+     >       ' NEPTUNIUM  CONCENTRATION,'/
+     >       ' ************************,'/
+     >       ' MIXED FUEL    TEMPERATURE AND COOLANT DENSITY,'/
+     >       ' MIXED COOLANT TEMPERATURE AND COOLANT DENSITY,'/
+     >       ' *********************************************,'/
+     >       ' THE POWER HISTORY,'/)
+ 9003 FORMAT(' POWER HISTORY COEFFICIENTS FOR THE CONCENTRATION '/
+     >       ' ARE STORED')
+ 9004 FORMAT(' REFLECTOR FEEDBACK COEFFICIENTS CORRESPONDING TO:'/
+     >       ' MODERATOR  TEMPERATURE  ,'/
+     >       ' MODERATOR  DENSITY      ,'/
+     >       ' BORON      CONCENTRATION,'/
+     >       ' MODERATOR  PURITY       ,'/)
+      END