summaryrefslogtreecommitdiff
path: root/Dragon/src/CFCFBM.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/CFCFBM.f')
-rw-r--r--Dragon/src/CFCFBM.f1227
1 files changed, 1227 insertions, 0 deletions
diff --git a/Dragon/src/CFCFBM.f b/Dragon/src/CFCFBM.f
new file mode 100644
index 0000000..f1fed9c
--- /dev/null
+++ b/Dragon/src/CFCFBM.f
@@ -0,0 +1,1227 @@
+*DECK CFCFBM
+ SUBROUTINE CFCFBM (TEXT1,TEXT2,IPLISU,IPLISD,IPFBM,NGRP,NBUM,NISM,
+ 1 NBURN,NISO,HISO,NL,IPRINT,TOTAL,ZNUG,DIFFX,DIFFY,DIFFZ,H,SCAT,
+ 1 MIJ,MNJ,TMREF,SMREF,DMREFX,DMREFY,DMREFZ,TOTAF,ZNUF,DXF,DYF,DZF,
+ 1 HF,SCATF,WORK3,REFC,TMICR,SMICR,DMICRX,DMICRY,DMICRZ,DELTA,
+ 1 DENSIT,TFR,TCR,TMR,XIR,TEXT,TEXTR,NB,FMICR,HMICR,FMREF,HMREF,
+ 1 JTAB,MIXP,V,EFJ,NXS,IXYZ,NBPARA,DBPARA)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute and store FBM coefficients.
+*
+*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
+* IPLISU address of the Compo object.
+* IPLISD address of the Compo object.
+* IPFBM address of the feedback data dase.
+* NISO 1+number of extracted isotopes.
+* TEXT1 name of the first feedback coefficient.
+* TEXT2 name of the second feedback coefficient.
+* TEXTR name of the record.
+* TFR reference fuel temperature.
+* TCR reference coolant temperature.
+* TMR reference moderator temperature.
+* NGRP number of energy groups.
+* NBUM number of materials.
+* NISM number of isotopes in materials.
+* NBURN number of burnup steps.
+* NB number of feedback coefficient per parameter.
+* NL number of Legendre orders (=1 for isotropic scattering).
+* IPRINT print parameter. Equal to zero for no print.
+* HISO Hollerith name information for extracted isotopes.
+* DENSIT number densities.
+* REFC reference number densities of the parameter.
+* TOTAL reference total macroscopic x-sections.
+* ZNUG reference nu * fission macroscopic x-sections.
+* DIFFX reference X-directed diffusion coefficients.
+* DIFFY reference Y-directed diffusion coefficients.
+* DIFFZ reference Z-directed diffusion coefficients.
+* H reference H-FACTORS (kappa * fission mac. x-sect.).
+* SCAT reference scattering macroscopic x-sections.
+* MIJ I pointer to decompress scattering matrix.
+* MNJ N pointer to decompress scattering matrix.
+* TMREF reference total microscopic x-sections.
+* DMREFX reference mic. X-directed diffusion coefficients.
+* DMREFY reference mic. Y-directed diffusion coefficients.
+* DMREFZ reference mic. Z-directed diffusion coefficients.
+* SMREF reference scattering microscopic x-sections.
+* FMREF reference nu * fission microscopic x-sections.
+* HMREF reference microscopic H-FACTORS.
+* TOTAF feedback total macroscopic x-sections.
+* ZNUF feedback nu * fission macroscopic x-sections.
+* DXF feedback X-directed diffusion coefficients.
+* DYF feedback Y-directed diffusion coefficients.
+* DZF feedback Z-directed diffusion coefficients.
+* HF feedback H-FACTORS (kappa * fission mac. x-sect.).
+* SCATF feedback scattering macroscopic x-sections.
+* TMICR feedback total microscopic x-sections.
+* DMICRX feedback microscipic X-directed diffusion coefficients.
+* DMICRY feedback microscipic Y-directed diffusion coefficients.
+* DMICRZ feedback microscipic Z-directed diffusion coefficients.
+* SMICR feedback scattering microscopic x-sections.
+* NBPARA Number of parameters for FBM.
+* DBPARA Values of parameters for FBM.
+*
+*Parameters: scratch
+* WORK3 undefined.
+* DELTA undefined.
+* XIR undefined.
+* TEXT undefined.
+* FMICR undefined.
+* HMICR undefined.
+* JTAB undefined.
+* MIXP undefined.
+* V undefined.
+* EFJ undefined.
+* NXS undefined.
+* IXYZ undefined.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ CHARACTER TEXT1*8,TEXT2*8,TEXT(2)*12,TEXTR*12
+ TYPE(C_PTR) IPLISU,IPLISD,IPFBM
+ INTEGER NGRP,NBUM,NISM,NBURN,NISO,HISO(3*NISO),NL,IPRINT,
+ 1 MIJ(NGRP),MNJ(NGRP),NB,JTAB(NISO),MIXP,NXS,IXYZ,NBPARA
+ REAL 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),TMREF(NGRP,NBUM,NISO),
+ 3 SMREF(NISM,NBUM,NL,NGRP,NGRP),DMREFX(NGRP,NBUM,NISO),
+ 4 DMREFY(NGRP,NBUM,NISO),DMREFZ(NGRP,NBUM,NISO),
+ 5 TOTAF(NGRP,NBUM,NB),ZNUF(NGRP,NBUM,NB),DXF(NGRP,NBUM,NB),
+ 6 DYF(NGRP,NBUM,NB),DZF(NGRP,NBUM,NB),HF(NGRP,NBUM,NB),
+ 7 SCATF(NB,NBUM,NL,NGRP,NGRP),WORK3(NGRP*NGRP),REFC(NBUM,NISO),
+ 8 TMICR(NGRP,NISM,NBUM,NB),SMICR(NB,NISM,NBUM,NL,NGRP,NGRP),
+ 9 DMICRX(NGRP,NISM,NBUM,NB),DMICRY(NGRP,NISM,NBUM,NB),
+ 1 DMICRZ(NGRP,NISM,NBUM,NB),DELTA(NBUM,2),DENSIT(NISO),
+ 2 TFR,TCR,TMR,XIR,FMICR(NGRP,NISM,NBUM,NB),
+ 3 HMICR(NGRP,NISM,NBUM,NB),FMREF(NGRP,NBUM,NISO),
+ 4 HMREF(NGRP,NBUM,NISO),V(NBUM,8,NB),EFJ(NISO),DBPARA(NBPARA)
+*----
+* LOCAL PARAMETERS
+*----
+ TYPE(C_PTR) IPLIST
+ INTEGER IOUT
+ PARAMETER (IOUT=6)
+ CHARACTER HMICRO*12,CM*2,TEXTB*12,TMIX(8)*8,HSMG*131
+ LOGICAL LOGI,LOHIS
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IXS
+ SAVE TMIX
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(IJJ(NGRP),NJJ(NGRP),IXS(NXS))
+C-----
+C PARAMETER VALUES ( TEMPERETURES, POWER AND PURITY )
+C-----
+ TFU=DBPARA(8)
+ TCU=DBPARA(9)
+ TMU=DBPARA(15)
+ TFD=DBPARA(16)
+ TCD=DBPARA(17)
+ TMD=DBPARA(18)
+ PWU=DBPARA(10)
+ PWD=DBPARA(13)
+ XI=DBPARA(14)
+C-----
+C SET ALL THE VARIABLES TO ZERO
+C-----
+C
+C REAL VARIABLE
+C
+ DEL=0.0
+ PV1U=0.0
+ PV2U=0.0
+ PV2UB=0.0
+ PV1D=0.0
+ PV2D=0.0
+ PV2DB=0.0
+C
+ DO 10 III=1,8
+ TMIX(III)=' '
+ 10 CONTINUE
+ V(:NBUM,:8,:NB)=0.0
+ DELTA(:NBUM,:2)=0.0
+ TOTAF(:NGRP,:NBUM,:NB)=0.0
+ ZNUF(:NGRP,:NBUM,:NB)=0.0
+ HF(:NGRP,:NBUM,:NB)=0.0
+ DXF(:NGRP,:NBUM,:NB)=0.0
+ DYF(:NGRP,:NBUM,:NB)=0.0
+ DZF(:NGRP,:NBUM,:NB)=0.0
+ TMICR(:NGRP,:NISO,:NBUM,:NB)=0.0
+ FMICR(:NGRP,:NISO,:NBUM,:NB)=0.0
+ HMICR(:NGRP,:NISO,:NBUM,:NB)=0.0
+ DMICRX(:NGRP,:NISO,:NBUM,:NB)=0.0
+ DMICRY(:NGRP,:NISO,:NBUM,:NB)=0.0
+ DMICRZ(:NGRP,:NISO,:NBUM,:NB)=0.0
+ SCATF(:NB,:NBUM,:NL,:NGRP,:NGRP)=0.0
+ SMICR(:NB,:NISO,:NBUM,:NL,:NGRP,:NGRP)=0.0
+C
+ DO 20 IGR=1,NGRP
+ IJJ(IGR)=IGR
+ NJJ(IGR)=1
+ 20 CONTINUE
+C
+C LOGICAL VARIABLE
+C
+ LOHIS=.FALSE.
+C
+C INITIAL UNIT NUMBER
+C
+ IPLIST=IPLISU
+C----------------------------------------------------------------------C
+C-----
+C RECOVER NEUTRONICS PARAMETRES
+C-----
+ DO 180 J=1,NB
+ IF(J.EQ.2) IPLIST=IPLISD
+ CALL LCMSIX(IPLIST,TEXT(J),1)
+ CALL LCMGET(IPLIST,'ISOTOPESNAME',HISO)
+C
+ I=1
+ WRITE(TEXTB,'(4HBURN,4X,I4)') I
+ CALL LCMSIX(IPLIST,TEXTB,1)
+ IXYZF=0
+ DO 30 ISO=1,NISO
+ WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+ CALL LCMSIX(IPLIST,HMICRO,1)
+ CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+ CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+ IF(IXS(18).EQ.1) IXYZF=1
+ CALL LCMSIX(IPLIST,' ',2)
+ 30 CONTINUE
+ IF(IXYZF.NE.IXYZ) THEN
+ WRITE(HSMG,
+ > '(15HXS_SAVED(18) = ,I5,17HREF XS_SAVED(18)=,I5)')
+ > IXS(18),IXYZ
+ CALL XABORT('CFCFBM: INCONSISTENT NB OF FLAGS '
+ 1 //TEXT(J)//' IS '//HSMG//' ')
+ ENDIF
+ CALL LCMSIX(IPLIST,' ',2)
+C
+ DO 170 I=1,NBURN
+ WRITE(TEXTB,'(4HBURN,4X,I4)') I
+ CALL LCMSIX(IPLIST,TEXTB,1)
+ CALL LCMGET(IPLIST,'ISOTOPESDENS',DENSIT)
+ CALL LCMGET(IPLIST,'ISOTOPES-EFJ',EFJ)
+ IF(DENSIT(1).NE.1.0) CALL XABORT('CFCFBM: DENSIT(1).NE.1.')
+C
+C RECOVER FEEDBACK MACROSCOPIC X-SECTIONS.
+C
+ CALL LCMSIX(IPLIST,'MACR',1)
+ CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+ CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+ IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TOTAF(1,I,J))
+ IF(IXS(3).EQ.1) CALL LCMGET(IPLIST,'NUSIGF',ZNUF(1,I,J))
+ IF(IXS(4).EQ.1) THEN
+ CALL LCMGET(IPLIST,'NFTOT',HF(1,I,J))
+ DO 40 IGR=1,NGRP
+ HF(IGR,I,J)=HF(IGR,I,J)*EFJ(1)
+ 40 CONTINUE
+ ENDIF
+ IL=1
+ WRITE (CM,'(I2.2)') IL-1
+ IF(IXS(20+IL).EQ.1) THEN
+ CALL LCMGET(IPLIST,'SIGS'//CM,WORK3)
+ DO 50 IGR=1,NGRP
+ TOTAF(IGR,I,J)= TOTAF(IGR,I,J)-WORK3(IGR)
+ 50 CONTINUE
+ ENDIF
+C
+ IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD ',DXF(1,I,J))
+ IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DXF(1,I,J))
+ IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DYF(1,I,J))
+ IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DZF(1,I,J))
+C
+ CALL LCMSIX(IPLIST,' ',2)
+C
+C RECOVER FEEDBACK DENSITIES.
+C
+ DO 100 ISO=2,NISO
+ WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+ IF(HMICRO.EQ.'BMOD') THEN
+ IF(TEXT1.EQ.'BOR') THEN
+ DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO)
+ DELTA(I,2)=0.0
+ ENDIF
+ ELSE IF(HMICRO.EQ.'XE135') THEN
+ IF(TEXT1.EQ.'XEN') THEN
+ DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO)
+ DELTA(I,2)=0.0
+ IF(I.EQ.1) DELTA(I,1)=0.0
+ ELSE IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN
+ V(I,1,J)=DENSIT(ISO)- REFC(I,ISO)
+ TMIX(1)='XEN'
+ ENDIF
+ ELSE IF(HMICRO.EQ.'SM149') THEN
+ IF(TEXT1.EQ.'SM149') THEN
+ DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO)
+ DELTA(I,2)=0.0
+ IF(I.EQ.1) DELTA(I,1)=0.0
+ ELSE IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN
+ V(I,2,J)=DENSIT(ISO)- REFC(I,ISO)
+ TMIX(2)='SM149'
+ ENDIF
+ ELSE IF(HMICRO.EQ.'NP239') THEN
+ IF(TEXT1.EQ.'NP239') THEN
+ DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO)
+ DELTA(I,2)=0.0
+ IF(I.EQ.1) DELTA(I,1)=0.0
+ ELSE IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN
+ V(I,3,J)=DENSIT(ISO)- REFC(I,ISO)
+ TMIX(3)='NP239'
+ ENDIF
+ ELSE IF(HMICRO.EQ.'FPC') THEN
+ IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN
+ DELTA(I,J)=DENSIT(ISO)- REFC(I,ISO)
+ ENDIF
+ ELSE IF(HMICRO.EQ.'CWAT') THEN
+ IF(TEXT1.EQ.'D1C') THEN
+ IF(J.EQ.1) THEN
+ PV1U=DENSIT(ISO)- REFC(I,ISO)
+ PV2U=PV1U*PV1U
+ PV2UB=PV1U*PV1U
+ DELTA(I,J)=PV1U
+ ELSE
+ PV1D=DENSIT(ISO)- REFC(I,ISO)
+ PV2D=PV1D*PV1D
+ PV2DB=PV1D*PV1D
+ DELTA(I,J)=PV1D
+ ENDIF
+ ENDIF
+ IF(TEXT1.EQ.'MIXFD'.OR.TEXT1.EQ.'MIXMD') THEN
+ DELTA(I,1)=DENSIT(ISO)- REFC(I,ISO)
+ DELTA(I,2)=0.0
+ V(I,1,J)=DENSIT(ISO)- REFC(I,ISO)
+ V(I,2,J)=V(I,1,J)*V(I,1,J)
+ TMIX(1)='D1C'
+ TMIX(2)='D2C'
+ ENDIF
+ ELSE IF(HMICRO.EQ.'MWAT') THEN
+ IF(TEXT1.EQ.'D1M') THEN
+ IF(J.EQ.1) THEN
+ PV1U=ALOG(DENSIT(ISO)/REFC(I,ISO))
+ PV2U=1.0/DENSIT(ISO) - 1.0/REFC(I,ISO)
+ PV2UB=DENSIT(ISO)- REFC(I,ISO)
+ DELTA(I,J)=PV2UB
+ ELSE
+ PV1D=ALOG(DENSIT(ISO)/REFC(I,ISO))
+ PV2D=1.0/DENSIT(ISO) - 1.0/REFC(I,ISO)
+ PV2DB=DENSIT(ISO)- REFC(I,ISO)
+ DELTA(I,J)=PV2DB
+ ENDIF
+ ELSE IF(TEXT1.EQ.'PUR') THEN
+ DELTA(I,1)=(XI-XIR)*REFC(I,ISO)
+ DELTA(I,2)=0.0
+ ENDIF
+ ENDIF
+C
+C RECOVER FEEDBACK MICROSCOPIC X-SECTIONS.
+C
+ CALL LCMSIX(IPLIST,HMICRO,1)
+ CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+ CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+ IF(IXS(1).EQ.1) CALL LCMGET(IPLIST,'TOTAL',TMICR(1,ISO,I,J))
+ IF(IXS(3).EQ.1) CALL LCMGET(IPLIST,'NUSIGF',FMICR(1,ISO,I,J))
+ IF(IXS(4).EQ.1) THEN
+ CALL LCMGET(IPLIST,'NFTOT',HMICR(1,ISO,I,J))
+ DO 60 IGR=1,NGRP
+ HMICR(IGR,ISO,I,J)=HMICR(IGR,ISO,I,J)*EFJ(ISO)
+ 60 CONTINUE
+ ENDIF
+ IL=1
+ WRITE (CM,'(I2.2)') IL-1
+ IF(IXS(20+IL).EQ.1) THEN
+ CALL LCMGET(IPLIST,'SIGS'//CM,WORK3)
+ DO 70 IGR=1,NGRP
+ TMICR(IGR,ISO,I,J)= TMICR(IGR,ISO,I,J)-WORK3(IGR)
+ 70 CONTINUE
+ ENDIF
+C
+ IF(IXS(17).EQ.1) CALL LCMGET(IPLIST,'STRD ',DMICRX(1,ISO,I,J))
+ IF(IXS(18).EQ.1) CALL LCMGET(IPLIST,'STRD X',DMICRX(1,ISO,I,J))
+ IF(IXS(19).EQ.1) CALL LCMGET(IPLIST,'STRD Y',DMICRY(1,ISO,I,J))
+ IF(IXS(20).EQ.1) CALL LCMGET(IPLIST,'STRD Z',DMICRZ(1,ISO,I,J))
+C
+C ADD THE CONTRIBUTION OF MIC. X-SECT. IN MAC. X-S
+C
+ DO 80 IGR=1,NGRP
+ TOTAF(IGR,I,J)=TOTAF(IGR,I,J)+DENSIT(ISO)*TMICR(IGR,ISO,I,J)
+ DXF(IGR,I,J) =DXF(IGR,I,J) +DENSIT(ISO)*DMICRX(IGR,ISO,I,J)
+ DYF(IGR,I,J) =DYF(IGR,I,J) +DENSIT(ISO)*DMICRY(IGR,ISO,I,J)
+ DZF(IGR,I,J) =DZF(IGR,I,J) +DENSIT(ISO)*DMICRZ(IGR,ISO,I,J)
+ 80 CONTINUE
+ IF(JTAB(ISO).EQ.1) THEN
+ DO 90 IGR=1,NGRP
+ ZNUF(IGR,I,J)=ZNUF(IGR,I,J)+DENSIT(ISO)*FMICR(IGR,ISO,I,J)
+ HF(IGR,I,J) =HF(IGR,I,J) +DENSIT(ISO)*HMICR(IGR,ISO,I,J)
+ 90 CONTINUE
+ ENDIF
+ CALL LCMSIX(IPLIST,' ',2)
+ 100 CONTINUE
+C
+C RECOVER MACROSCOPIC SCATTERING X-SECTIONS.
+C
+ CALL LCMSIX(IPLIST,'MACR',1)
+ CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+ CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+ 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 120 JGR=1,NGRP
+ DO 110 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1
+ IGAR=IGAR+1
+ SCATF(J,I,IL,IGR,JGR)=WORK3(IGAR)
+ 110 CONTINUE
+ 120 CONTINUE
+ ENDIF
+C
+ CALL LCMSIX(IPLIST,' ',2)
+C
+C RECOVER MICROSCOPIC CONTRIBUTIONS OF SCATTERING X-SECTIONS.
+C
+ DO 160 ISO=2,NISO
+ WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+ CALL LCMSIX(IPLIST,HMICRO,1)
+ CALL LCMGET(IPLIST,'XS-SAVED',IXS)
+ CALL LCMGET(IPLIST,'SCAT-SAVED',IXS(21))
+ 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 140 JGR=1,NGRP
+ DO 130 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1
+ IGAR=IGAR+1
+ SMICR(J,ISO,I,IL,IGR,JGR)=WORK3(IGAR)
+ SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)+
+ 1 DENSIT(ISO)*WORK3(IGAR)
+ 130 CONTINUE
+ 140 CONTINUE
+ ENDIF
+ CALL LCMSIX(IPLIST,' ',2)
+ 160 CONTINUE
+C GOING UP FOR BURN
+ CALL LCMSIX(IPLIST,' ',2)
+ 170 CONTINUE
+ CALL LCMSIX(IPLIST,' ',2)
+ 180 CONTINUE
+C----------------------------------------------------------------------C
+C C
+C BEGIN THE COEFFICIENTS CALCULATION C
+C C
+C----------------------------------------------------------------------C
+ DT=0.0
+ IF(TEXT1.EQ.'T1F') THEN
+ PV1U=SQRT(TFU)-SQRT(TFR)
+ PV2U=TFU-TFR
+ PV2UB=PV2U
+ PV1D=SQRT(TFD)-SQRT(TFR)
+ PV2D=TFD-TFR
+ PV2DB=PV2D
+ ELSE IF(TEXT1.EQ.'T1C') THEN
+ PV1U=ALOG(TCU/TCR)
+ PV2U=1.0/TCU - 1.0/TCR
+ PV2UB=PV2U
+ PV1D=ALOG(TCD/TCR)
+ PV2D=1.0/TCD - 1.0/TCR
+ PV2DB=PV2D
+ ELSE IF(TEXT1.EQ.'T1M') THEN
+ PV1U=ALOG(TMU/TMR)
+ PV2U=1.0/TMU - 1.0/TMR
+ PV2UB=PV2U
+ PV1D=ALOG(TMD/TMR)
+ PV2D=1.0/TMD - 1.0/TMR
+ PV2DB=PV2D
+ ELSE IF(TEXT1.EQ.'MIXMD') THEN
+ DT=ALOG(TCU/TCR)
+ DO 190 I=1,NBURN
+ V(I,3,1)=ALOG(TCU/TCR)
+ V(I,4,1)=1.0/TCU - 1.0/TCR
+ 190 CONTINUE
+ TMIX(1)='D1C'
+ TMIX(2)='D2C'
+ TMIX(3)='T1C'
+ TMIX(4)='T2C'
+ ELSE IF(TEXT1.EQ.'MIXFD') THEN
+ DT=SQRT(TFU)-SQRT(TFR)
+ DO 200 I=1,NBURN
+ V(I,3,1)=SQRT(TFU)-SQRT(TFR)
+ V(I,4,1)=TFU-TFR
+ 200 CONTINUE
+ TMIX(1)='D1C'
+ TMIX(2)='D2C'
+ TMIX(3)='T1F'
+ TMIX(4)='T2F'
+ ENDIF
+C
+C----------------------------------------------------------------------C
+C
+C COMPUTE DELTA SIGMA
+C
+ DO 290 I=1,NBURN
+ DO 280 J=1,NB
+ DO 240 IGR=1,NGRP
+ TOTAF(IGR,I,J)=TOTAF(IGR,I,J)-TOTAL(IGR,I)
+ DXF(IGR,I,J)=DXF(IGR,I,J)-DIFFX(IGR,I)
+ DYF(IGR,I,J)=DYF(IGR,I,J)-DIFFY(IGR,I)
+ DZF(IGR,I,J)=DZF(IGR,I,J)-DIFFZ(IGR,I)
+ ZNUF(IGR,I,J)=ZNUF(IGR,I,J)-ZNUG(IGR,I)
+ HF(IGR,I,J)=HF(IGR,I,J)-H(IGR,I)
+ DO 210 ISO=2,NISO
+ TMICR(IGR,ISO,I,J) =TMICR(IGR,ISO,I,J) - TMREF(IGR,I,ISO)
+ DMICRX(IGR,ISO,I,J)=DMICRX(IGR,ISO,I,J)- DMREFX(IGR,I,ISO)
+ DMICRY(IGR,ISO,I,J)=DMICRY(IGR,ISO,I,J)- DMREFY(IGR,I,ISO)
+ DMICRZ(IGR,ISO,I,J)=DMICRZ(IGR,ISO,I,J)- DMREFZ(IGR,I,ISO)
+ IF(JTAB(ISO).EQ.1) THEN
+ FMICR(IGR,ISO,I,J)=FMICR(IGR,ISO,I,J)- FMREF(IGR,I,ISO)
+ HMICR(IGR,ISO,I,J)=HMICR(IGR,ISO,I,J)- HMREF(IGR,I,ISO)
+ ENDIF
+ 210 CONTINUE
+ IL=1
+ DO 230 JGR=1,NGRP
+ SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)-
+ 1 SCAT(I,IL,IGR,JGR)
+ DO 220 ISO=2,NISO
+ SMICR(J,ISO,I,IL,IGR,JGR)=SMICR(J,ISO,I,IL,IGR,JGR)-
+ 1 SMREF(ISO,I,IL,IGR,JGR)
+ 220 CONTINUE
+ 230 CONTINUE
+ 240 CONTINUE
+C
+C CORRECTION OF MACRO. X-SECTIONS
+C
+ LOGI=.FALSE.
+ DO 270 ISO=2,NISO
+ WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+ IF(HMICRO.EQ.'BMOD'.AND.TEXT1.EQ.'BOR') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'XE135'.AND.TEXT1.EQ.'XEN') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'SM149'.AND.TEXT1.EQ.'SM149') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'NP239'.AND.TEXT1.EQ.'NP239') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'CWAT'.AND.TEXT1.EQ.'D1C') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'MWAT'.AND.TEXT1.EQ.'D1M') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'CWAT'.AND.TEXT1.EQ.'MIXFD') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'CWAT'.AND.TEXT1.EQ.'MIXMD') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'XE135'.AND.TEXT1.EQ.'FPCH1') THEN
+ LOGI =.TRUE.
+ DELC=V(I,1,J)
+ ELSE IF(HMICRO.EQ.'XE135'.AND.TEXT1.EQ.'FPCL1') THEN
+ LOGI =.TRUE.
+ DELC=V(I,1,J)
+ ELSE IF(HMICRO.EQ.'SM149'.AND.TEXT1.EQ.'FPCH1') THEN
+ LOGI =.TRUE.
+ DELC=V(I,2,J)
+ ELSE IF(HMICRO.EQ.'SM149'.AND.TEXT1.EQ.'FPCL1') THEN
+ LOGI =.TRUE.
+ DELC=V(I,2,J)
+ ELSE IF(HMICRO.EQ.'NP239'.AND.TEXT1.EQ.'FPCH1') THEN
+ LOGI =.TRUE.
+ DELC=V(I,3,J)
+ ELSE IF(HMICRO.EQ.'NP239'.AND.TEXT1.EQ.'FPCL1') THEN
+ LOGI =.TRUE.
+ DELC=V(I,3,J)
+ ELSE IF(HMICRO.EQ.'FPC'.AND.TEXT1.EQ.'FPCH1') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ELSE IF(HMICRO.EQ.'FPC'.AND.TEXT1.EQ.'FPCL1') THEN
+ LOGI =.TRUE.
+ DELC=DELTA(I,J)
+ ENDIF
+C
+ IF(LOGI) THEN
+ DO 260 IGR=1,NGRP
+ TOTAF(IGR,I,J)=TOTAF(IGR,I,J)-TMICR(IGR,ISO,I,J)*DELC
+ DXF(IGR,I,J)=DXF(IGR,I,J)-DMICRX(IGR,ISO,I,J)*DELC
+ DYF(IGR,I,J)=DYF(IGR,I,J)-DMICRY(IGR,ISO,I,J)*DELC
+ DZF(IGR,I,J)=DZF(IGR,I,J)-DMICRZ(IGR,ISO,I,J)*DELC
+ IF(JTAB(ISO).EQ.1) THEN
+ ZNUF(IGR,I,J)= ZNUF(IGR,I,J)-FMICR(IGR,ISO,I,J)*DELC
+ HF(IGR,I,J)=HF(IGR,I,J)-HMICR(IGR,ISO,I,J)*DELC
+ ENDIF
+ IL=1
+ DO 250 JGR=1,NGRP
+ SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)-
+ 1 SMICR(J,ISO,I,IL,IGR,JGR)*DELC
+ 250 CONTINUE
+ 260 CONTINUE
+ ENDIF
+ LOGI=.FALSE.
+ 270 CONTINUE
+ 280 CONTINUE
+ 290 CONTINUE
+C----------------------------------------------------------------------C
+C 'MIXMD' AND 'MIXFD'
+C TAKE OFF THE INDIVIDUAL VARIATION CONTRIBUTION OF:
+C FUEL TEMPERATURE
+C COOLANT TEMPERATURE
+C COOLANT DENSITY
+C----------------------------
+C 'FPCH1' AND 'FPCL1'
+C XENON CONCENTRATION
+C SAMARIUM CONCENTRATION
+C NEPTUNIUM CONCENTRATION
+C
+ IF(MIXP.EQ.1) THEN
+ IF(TEXT1.EQ.'MIXMD'.OR.TEXT1.EQ.'MIXFD') NCOR=4
+ IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') NCOR=3
+ IF(ABS(IPRINT) .GT. 5) THEN
+ WRITE(IOUT,6000) TEXT1,NCOR,(TMIX(II),II=1,NCOR)
+ ENDIF
+ CALL LCMSIX(IPFBM,TEXTR,1)
+ DO 820 I=1,NBURN
+ WRITE(TEXTB,'(4HBURN,4X,I4)') I
+ CALL LCMSIX(IPFBM,TEXTB,1)
+ CALL LCMSIX(IPFBM,'MACR',1)
+ CALL LCMSIX(IPFBM,'ABS',1)
+ DO 320 II=1,NCOR
+ DO 310 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 300 IGR=1,NGRP
+ TOTAF(IGR,I,J)= TOTAF(IGR,I,J)-WORK3(IGR)*V(I,II,J)
+ 300 CONTINUE
+ 310 CONTINUE
+ 320 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ IF(IXYZ.EQ.0) THEN
+ CALL LCMSIX(IPFBM,'STRD ',1)
+ DO 350 II=1,NCOR
+ DO 340 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 330 IGR=1,NGRP
+ DXF(IGR,I,J)= DXF(IGR,I,J)-WORK3(IGR)*V(I,II,J)
+ 330 CONTINUE
+ 340 CONTINUE
+ 350 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ ELSE IF(IXYZ.EQ.1) THEN
+ CALL LCMSIX(IPFBM,'STRD X',1)
+ DO 380 II=1,NCOR
+ DO 370 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 360 IGR=1,NGRP
+ DXF(IGR,I,J)= DXF(IGR,I,J)-WORK3(IGR)*V(I,II,J)
+ 360 CONTINUE
+ 370 CONTINUE
+ 380 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'STRD Y',1)
+ DO 410 II=1,NCOR
+ DO 400 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 390 IGR=1,NGRP
+ DYF(IGR,I,J)= DYF(IGR,I,J)-WORK3(IGR)*V(I,II,J)
+ 390 CONTINUE
+ 400 CONTINUE
+ 410 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'STRD Z',1)
+ DO 440 II=1,NCOR
+ DO 430 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 420 IGR=1,NGRP
+ DZF(IGR,I,J)= DZF(IGR,I,J)-WORK3(IGR)*V(I,II,J)
+ 420 CONTINUE
+ 430 CONTINUE
+ 440 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(JTAB(1).EQ.1) THEN
+ CALL LCMSIX(IPFBM,'NUSIGF',1)
+ DO 470 II=1,NCOR
+ DO 460 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 450 IGR=1,NGRP
+ ZNUF(IGR,I,J)= ZNUF(IGR,I,J)-WORK3(IGR)*V(I,II,J)
+ 450 CONTINUE
+ 460 CONTINUE
+ 470 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'H-FACTORS',1)
+ DO 500 II=1,NCOR
+ DO 490 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 480 IGR=1,NGRP
+ HF(IGR,I,J)= HF(IGR,I,J)-WORK3(IGR)*V(I,II,J)
+ 480 CONTINUE
+ 490 CONTINUE
+ 500 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IL=1
+ WRITE (CM,'(I2)') IL-1
+ CALL LCMSIX(IPFBM,'SCAT'//CM,1)
+ CALL LCMGET(IPFBM,'NJJ',NJJ)
+ CALL LCMGET(IPFBM,'IJJ',IJJ)
+ DO 540 II=1,NCOR
+ DO 530 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ IGAR=0
+ DO 520 JGR=1,NGRP
+ DO 510 IGR=IJJ(JGR),IJJ(JGR)-NJJ(JGR)+1,-1
+ IGAR=IGAR+1
+ SCATF(J,I,IL,IGR,JGR)=SCATF(J,I,IL,IGR,JGR)-
+ 1 WORK3(IGAR)*V(I,II,J)
+ 510 CONTINUE
+ 520 CONTINUE
+ 530 CONTINUE
+ 540 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+C GO UP FOR MACR
+ CALL LCMSIX(IPFBM,' ',2)
+C
+C MICROSCOPIC X-SECTION CORRECTION
+C
+ DO 810 ISO=2,NISO
+ WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+ CALL LCMSIX(IPFBM,HMICRO,1)
+C
+ CALL LCMSIX(IPFBM,'ABS',1)
+ DO 580 II=1,NCOR
+ DO 570 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 560 IGR=1,NGRP
+ TMICR(IGR,ISO,I,J)=TMICR(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J)
+ 560 CONTINUE
+ 570 CONTINUE
+ 580 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ IF(IXYZ.EQ.0) THEN
+ CALL LCMSIX(IPFBM,'STRD ',1)
+ DO 610 II=1,NCOR
+ DO 600 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 590 IGR=1,NGRP
+ DMICRX(IGR,ISO,I,J)=DMICRX(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J)
+ 590 CONTINUE
+ 600 CONTINUE
+ 610 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ ELSE IF(IXYZ.EQ.1) THEN
+ CALL LCMSIX(IPFBM,'STRD X',1)
+ DO 640 II=1,NCOR
+ DO 630 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 620 IGR=1,NGRP
+ DMICRX(IGR,ISO,I,J)=DMICRX(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J)
+ 620 CONTINUE
+ 630 CONTINUE
+ 640 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'STRD Y',1)
+ DO 670 II=1,NCOR
+ DO 660 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 650 IGR=1,NGRP
+ DMICRY(IGR,ISO,I,J)=DMICRY(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J)
+ 650 CONTINUE
+ 660 CONTINUE
+ 670 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'STRD Z',1)
+ DO 700 II=1,NCOR
+ DO 690 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 680 IGR=1,NGRP
+ DMICRZ(IGR,ISO,I,J)=DMICRZ(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J)
+ 680 CONTINUE
+ 690 CONTINUE
+ 700 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(JTAB(ISO).EQ.1) THEN
+ CALL LCMSIX(IPFBM,'NUSIGF',1)
+ DO 730 II=1,NCOR
+ DO 720 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 710 IGR=1,NGRP
+ FMICR(IGR,ISO,I,J)=FMICR(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J)
+ 710 CONTINUE
+ 720 CONTINUE
+ 730 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'H-FACTORS',1)
+ DO 760 II=1,NCOR
+ DO 750 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ DO 740 IGR=1,NGRP
+ HMICR(IGR,ISO,I,J)= HMICR(IGR,ISO,I,J)-WORK3(IGR)*V(I,II,J)
+ 740 CONTINUE
+ 750 CONTINUE
+ 760 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IL=1
+ WRITE (CM,'(I2)') IL-1
+ CALL LCMSIX(IPFBM,'SCAT'//CM,1)
+ DO 800 II=1,NCOR
+ DO 790 J=1,NB
+ CALL LCMGET(IPFBM,TMIX(II),WORK3)
+ IGAR=0
+ DO 780 JGR=1,NGRP
+ DO 770 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1
+ IGAR=IGAR+1
+ SMICR(J,ISO,I,IL,IGR,JGR)=SMICR(J,ISO,I,IL,IGR,JGR)-
+ 1 WORK3(IGAR)*V(I,II,J)
+ 770 CONTINUE
+ 780 CONTINUE
+ 790 CONTINUE
+ 800 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,' ',2)
+ 810 CONTINUE
+C GO UP FOR BURNUP
+ CALL LCMSIX(IPFBM,' ',2)
+ 820 CONTINUE
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+C END OF INDIVIDUAL CORRECTION
+C----------------------------------------------------------------------C
+C-----
+C INVERT THE FEEDBACK FORMULAS
+C-----
+ DO 945 I=1,NBURN
+ DO 940 IGR=1,NGRP
+ IF(NB.EQ.1) THEN
+C
+C ONLY ONE COEFFICIENT IS REQUIRED (NB=1) FOR:
+C BORON CONCENTRATION
+C XENON CONCENTRATION
+C SAMARIUM CONCENTRATION
+C NEPTUNIUM CONCENTRATION
+C MODERATOR PURITY
+C
+ IF(TEXT1.EQ.'MIXMD'.AND.IGR.EQ.1) DELTA(I,1)=DELTA(I,1)*DT
+ IF(TEXT1.EQ.'MIXFD'.AND.IGR.EQ.1) DELTA(I,1)=DELTA(I,1)*DT
+ IF(DELTA(I,1).NE.0.0) THEN
+ TOTAF(IGR,I,1)=TOTAF(IGR,I,1)/DELTA(I,1)
+ DXF(IGR,I,1)=DXF(IGR,I,1)/DELTA(I,1)
+ DYF(IGR,I,1)=DYF(IGR,I,1)/DELTA(I,1)
+ DZF(IGR,I,1)=DZF(IGR,I,1)/DELTA(I,1)
+ ZNUF(IGR,I,1)=ZNUF(IGR,I,1)/DELTA(I,1)
+ HF(IGR,I,1)=HF(IGR,I,1)/DELTA(I,1)
+ DO 830 ISO=2,NISO
+ TMICR(IGR,ISO,I,1)=TMICR(IGR,ISO,I,1)/DELTA(I,1)
+ DMICRX(IGR,ISO,I,1)=DMICRX(IGR,ISO,I,1)/DELTA(I,1)
+ DMICRY(IGR,ISO,I,1)=DMICRY(IGR,ISO,I,1)/DELTA(I,1)
+ DMICRZ(IGR,ISO,I,1)=DMICRZ(IGR,ISO,I,1)/DELTA(I,1)
+ IF(JTAB(ISO).EQ.1) THEN
+ FMICR(IGR,ISO,I,1)=FMICR(IGR,ISO,I,1)/DELTA(I,1)
+ HMICR(IGR,ISO,I,1)=HMICR(IGR,ISO,I,1)/DELTA(I,1)
+ ENDIF
+ 830 CONTINUE
+ IL=1
+ DO 850 JGR=1,NGRP
+ SCATF(1,I,IL,IGR,JGR)=SCATF(1,I,IL,IGR,JGR)/DELTA(I,1)
+ DO 840 ISO=2,NISO
+ SMICR(1,ISO,I,IL,IGR,JGR)=SMICR(1,ISO,I,IL,IGR,JGR)/DELTA(I,1)
+ 840 CONTINUE
+ 850 CONTINUE
+ ELSE
+ TOTAF(IGR,I,1)=0.0
+ DXF(IGR,I,1) =0.0
+ DYF(IGR,I,1) =0.0
+ DZF(IGR,I,1) =0.0
+C
+ ZNUF(IGR,I,1) =0.0
+ HF(IGR,I,1) =0.0
+ DO 860 ISO=2,NISO
+ TMICR(IGR,ISO,I,1) =0.0
+ DMICRX(IGR,ISO,I,1)=0.0
+ DMICRY(IGR,ISO,I,1)=0.0
+ DMICRZ(IGR,ISO,I,1)=0.0
+ IF(JTAB(ISO).EQ.1) THEN
+ FMICR(IGR,ISO,I,1)=0.0
+ HMICR(IGR,ISO,I,1)=0.0
+ ENDIF
+ 860 CONTINUE
+ DO 872 IL=1,NL
+ DO 871 JGR=1,NGRP
+ SCATF(1,I,IL,IGR,JGR)=0.0
+ DO 870 ISO=2,NISO
+ SMICR(1,ISO,I,IL,IGR,JGR)=0.0
+ 870 CONTINUE
+ 871 CONTINUE
+ 872 CONTINUE
+ ENDIF
+C
+ ELSE IF(NB.EQ.2) THEN
+C
+C INVERT THE FEEDBACK FORMULAS
+C TWO FBM COEFFICIENTS ARE COMPUTED
+C TEMPERATURES
+C DENSITIES
+C POWER LEVEL
+C
+ IF(TEXT1.EQ.'FPCH1'.OR.TEXT1.EQ.'FPCL1') THEN
+ PV1U=DELTA(I,1)
+ PV2U=PV1U*PV1U
+ PV2UB=PV2U
+ PV1D=DELTA(I,2)
+ PV2D=PV1D*PV1D
+ PV2DB=PV2D
+ ENDIF
+C
+ TX=PV2U*PV1D - PV2D*PV1U
+ TXB=PV2UB*PV1D - PV2DB*PV1U
+C
+ IF(TX.NE.0.0.AND.TXB.NE.0.0) THEN
+ TOTAF(IGR,I,2)=(TOTAF(IGR,I,1)*PV1D-TOTAF(IGR,I,2)*PV1U)/TX
+ TOTAF(IGR,I,1)=(TOTAF(IGR,I,1) - TOTAF(IGR,I,2)*PV2U)/PV1U
+C
+ DXF(IGR,I,2)=(DXF(IGR,I,1)*PV1D -DXF(IGR,I,2)*PV1U)/TXB
+ DXF(IGR,I,1)=(DXF(IGR,I,1) - DXF(IGR,I,2)*PV2UB)/PV1U
+ DYF(IGR,I,2)=(DYF(IGR,I,1)*PV1D -DYF(IGR,I,2)*PV1U)/TXB
+ DYF(IGR,I,1)=(DYF(IGR,I,1) - DYF(IGR,I,2)*PV2UB)/PV1U
+ DZF(IGR,I,2)=(DZF(IGR,I,1)*PV1D -DZF(IGR,I,2)*PV1U)/TXB
+ DZF(IGR,I,1)=(DZF(IGR,I,1) - DZF(IGR,I,2)*PV2UB)/PV1U
+C
+ ZNUF(IGR,I,2)=(ZNUF(IGR,I,1)*PV1D - ZNUF(IGR,I,2)*PV1U)/TX
+ ZNUF(IGR,I,1)=(ZNUF(IGR,I,1) - ZNUF(IGR,I,2)*PV2U)/PV1U
+C
+ HF(IGR,I,2)=(HF(IGR,I,1)*PV1D - HF(IGR,I,2)*PV1U)/TX
+ HF(IGR,I,1)=(HF(IGR,I,1) - HF(IGR,I,2)*PV2U)/PV1U
+C
+ DO 880 ISO=2,NISO
+ TMICR(IGR,ISO,I,2)=(TMICR(IGR,ISO,I,1)*PV1D -
+ 1 TMICR(IGR,ISO,I,2)*PV1U)/TX
+ TMICR(IGR,ISO,I,1)=(TMICR(IGR,ISO,I,1) -
+ 1 TMICR(IGR,ISO,I,2)*PV2U)/PV1U
+C
+ DMICRX(IGR,ISO,I,2)=(DMICRX(IGR,ISO,I,1)*PV1D -
+ 1 DMICRX(IGR,ISO,I,2)*PV1U)/TX
+ DMICRX(IGR,ISO,I,1)=(DMICRX(IGR,ISO,I,1) -
+ 1 DMICRX(IGR,ISO,I,2)*PV2U)/PV1U
+ DMICRY(IGR,ISO,I,2)=(DMICRY(IGR,ISO,I,1)*PV1D -
+ 1 DMICRY(IGR,ISO,I,2)*PV1U)/TX
+ DMICRY(IGR,ISO,I,1)=(DMICRY(IGR,ISO,I,1) -
+ 1 DMICRY(IGR,ISO,I,2)*PV2U)/PV1U
+ DMICRZ(IGR,ISO,I,2)=(DMICRZ(IGR,ISO,I,1)*PV1D -
+ 1 DMICRZ(IGR,ISO,I,2)*PV1U)/TX
+ DMICRZ(IGR,ISO,I,1)=(DMICRZ(IGR,ISO,I,1) -
+ 1 DMICRZ(IGR,ISO,I,2)*PV2U)/PV1U
+C
+ IF(JTAB(ISO).EQ.1) THEN
+ FMICR(IGR,ISO,I,2)=(FMICR(IGR,ISO,I,1)*PV1D -
+ 1 FMICR(IGR,ISO,I,2)*PV1U)/TX
+ FMICR(IGR,ISO,I,1)=(FMICR(IGR,ISO,I,1) -
+ 1 FMICR(IGR,ISO,I,2)*PV2U)/PV1U
+C
+ HMICR(IGR,ISO,I,2)=(HMICR(IGR,ISO,I,1)*PV1D -
+ 1 HMICR(IGR,ISO,I,2)*PV1U)/TX
+ HMICR(IGR,ISO,I,1)=(HMICR(IGR,ISO,I,1) -
+ 1 HMICR(IGR,ISO,I,2)*PV2U)/PV1U
+ ENDIF
+ 880 CONTINUE
+C
+ IL=1
+ DO 895 JGR=1,NGRP
+ SCATF(2,I,IL,IGR,JGR)=(SCATF(1,I,IL,IGR,JGR)*PV1D-
+ 1 SCATF(2,I,IL,IGR,JGR)*PV1U)/TXB
+ SCATF(1,I,IL,IGR,JGR)=(SCATF(1,I,IL,IGR,JGR) -
+ 1 SCATF(2,I,IL,IGR,JGR)*PV2UB)/PV1U
+ DO 890 ISO=2,NISO
+ SMICR(2,ISO,I,IL,IGR,JGR)=(SMICR(1,ISO,I,IL,IGR,JGR)*PV1D-
+ 1 SMICR(2,ISO,I,IL,IGR,JGR)*PV1U)/TX
+ SMICR(1,ISO,I,IL,IGR,JGR)=(SMICR(1,ISO,I,IL,IGR,JGR) -
+ 1 SMICR(2,ISO,I,IL,IGR,JGR)*PV2U)/PV1U
+ 890 CONTINUE
+ 895 CONTINUE
+ ELSE
+ DO 930 J=1,NB
+ TOTAF(IGR,I,J)=0.0
+ DXF(IGR,I,J) =0.0
+ DYF(IGR,I,J) =0.0
+ DZF(IGR,I,J) =0.0
+ ZNUF(IGR,I,J)=0.0
+ HF(IGR,I,J)=0.0
+ DO 900 ISO=2,NISO
+ TMICR(IGR,ISO,I,J) =0.0
+ DMICRX(IGR,ISO,I,J)=0.0
+ DMICRY(IGR,ISO,I,J)=0.0
+ DMICRZ(IGR,ISO,I,J)=0.0
+ IF(JTAB(ISO).EQ.1) THEN
+ FMICR(IGR,ISO,I,J)=0.0
+ HMICR(IGR,ISO,I,J)=0.0
+ ENDIF
+ 900 CONTINUE
+ DO 922 IL=1,NL
+ DO 921 JGR=1,NGRP
+ SCATF(J,I,IL,IGR,JGR)=0.0
+ DO 920 ISO=2,NISO
+ SMICR(J,ISO,I,IL,IGR,JGR)=0.0
+ 920 CONTINUE
+ 921 CONTINUE
+ 922 CONTINUE
+ 930 CONTINUE
+ ENDIF
+ ENDIF
+ 940 CONTINUE
+ 945 CONTINUE
+C
+C ALL NOMINAL NEUTRONICS CONSTANTS ARE ALREDY STORED
+C-----
+C STORING PROGRAM FOR THE FEEDBACK COEFFICIENTS.
+C-----
+ CALL LCMSIX(IPFBM,TEXTR,1)
+ DO 1000 I=1,NBURN
+ WRITE(TEXTB,'(4HBURN,4X,I4)') I
+ CALL LCMSIX(IPFBM,TEXTB,1)
+ CALL LCMSIX(IPFBM,'MACR',1)
+ CALL LCMSIX(IPFBM,'ABS',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,TOTAF(1,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ IF(IXYZ.EQ.0) THEN
+ CALL LCMSIX(IPFBM,'STRD ',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DXF(1,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ ELSE IF(IXYZ.EQ.1) THEN
+ CALL LCMSIX(IPFBM,'STRD X',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DXF(1,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Y',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DYF(1,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Z',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DZF(1,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(JTAB(1).EQ.1) THEN
+ CALL LCMSIX(IPFBM,'NUSIGF',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,ZNUF(1,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'H-FACTORS',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,HF(1,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(NB.EQ.2) THEN
+ CALL LCMSIX(IPFBM,'ABS',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,TOTAF(1,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ IF(IXYZ.EQ.0) THEN
+ CALL LCMSIX(IPFBM,'STRD ',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DXF(1,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ ELSE IF(IXYZ.EQ.1) THEN
+ CALL LCMSIX(IPFBM,'STRD X',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DXF(1,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Y',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DYF(1,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Z',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DZF(1,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(JTAB(1).EQ.1) THEN
+ CALL LCMSIX(IPFBM,'NUSIGF',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,ZNUF(1,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'H-FACTORS',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,HF(1,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+ ENDIF
+C
+ IL=1
+ WRITE (CM,'(I2)') IL-1
+ CALL LCMSIX(IPFBM,'SCAT'//CM,1)
+ CALL LCMLEN(IPFBM,'REF',ILENG,ITYXSM)
+ IF(ILENG.GT.0) THEN
+ IGAR=0
+ DO 955 JGR=1,NGRP
+ DO 950 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1
+ IGAR=IGAR+1
+ WORK3(IGAR)=SCATF(1,I,IL,IGR,JGR)
+ 950 CONTINUE
+ 955 CONTINUE
+ CALL LCMPUT(IPFBM,TEXT1,IGAR,2,WORK3)
+ IF(NB.EQ.2) THEN
+ IGAR=0
+ DO 965 JGR=1,NGRP
+ DO 960 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1
+ IGAR=IGAR+1
+ WORK3(IGAR)=SCATF(2,I,IL,IGR,JGR)
+ 960 CONTINUE
+ 965 CONTINUE
+ CALL LCMPUT(IPFBM,TEXT2,IGAR,2,WORK3)
+ ENDIF
+ ENDIF
+ CALL LCMSIX(IPFBM,' ',2)
+C
+C GO UP FOR MACR
+ CALL LCMSIX(IPFBM,' ',2)
+C-----
+C STORE MICROSCOPIC INFONFORMATION
+C-----
+ DO 990 ISO=2,NISO
+ WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3)
+ CALL LCMLEN(IPFBM,HMICRO,ILENG,ITYLCM)
+ CALL LCMSIX(IPFBM,HMICRO,1)
+C
+ CALL LCMSIX(IPFBM,'ABS',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,TMICR(1,ISO,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ IF(IXYZ.EQ.0) THEN
+ CALL LCMSIX(IPFBM,'STRD ',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRX(1,ISO,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ ELSE IF(IXYZ.EQ.1) THEN
+ CALL LCMSIX(IPFBM,'STRD X',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRX(1,ISO,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Y',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRY(1,ISO,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Z',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,DMICRZ(1,ISO,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(JTAB(ISO).EQ.1) THEN
+ CALL LCMSIX(IPFBM,'NUSIGF',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,FMICR(1,ISO,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'H-FACTORS',1)
+ CALL LCMPUT(IPFBM,TEXT1,NGRP,2,HMICR(1,ISO,I,1))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(NB.EQ.2) THEN
+ CALL LCMSIX(IPFBM,'ABS',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,TMICR(1,ISO,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ IF(IXYZ.EQ.0) THEN
+ CALL LCMSIX(IPFBM,'STRD ',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRX(1,ISO,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ ELSE IF(IXYZ.EQ.1) THEN
+ CALL LCMSIX(IPFBM,'STRD X',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRX(1,ISO,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Y',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRY(1,ISO,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ CALL LCMSIX(IPFBM,'STRD Z',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,DMICRZ(1,ISO,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+C
+ IF(JTAB(ISO).EQ.1) THEN
+ CALL LCMSIX(IPFBM,'NUSIGF',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,FMICR(1,ISO,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+C
+ CALL LCMSIX(IPFBM,'H-FACTORS',1)
+ CALL LCMPUT(IPFBM,TEXT2,NGRP,2,HMICR(1,ISO,I,2))
+ CALL LCMSIX(IPFBM,' ',2)
+ ENDIF
+ ENDIF
+C
+ IL=1
+ WRITE (CM,'(I2)') IL-1
+ CALL LCMSIX(IPFBM,'SCAT'//CM,1)
+ CALL LCMLEN(IPFBM,'REF',ILENG,ITYXSM)
+ IF(ILENG.GT.0) THEN
+ IGAR=0
+ DO 975 JGR=1,NGRP
+ DO 970 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1
+ IGAR=IGAR+1
+ WORK3(IGAR)=SMICR(1,ISO,I,IL,IGR,JGR)
+ 970 CONTINUE
+ 975 CONTINUE
+ CALL LCMPUT(IPFBM,TEXT1,IGAR,2,WORK3)
+ IF(NB.EQ.2) THEN
+ IGAR=0
+ DO 985 JGR=1,NGRP
+ DO 980 IGR=MIJ(JGR),MIJ(JGR)-MNJ(JGR)+1,-1
+ IGAR=IGAR+1
+ WORK3(IGAR)=SMICR(2,ISO,I,IL,IGR,JGR)
+ 980 CONTINUE
+ 985 CONTINUE
+ CALL LCMPUT(IPFBM,TEXT2,IGAR,2,WORK3)
+ ENDIF
+ ENDIF
+ CALL LCMSIX(IPFBM,' ',2)
+C
+C GO UP FOR MICR
+ CALL LCMSIX(IPFBM,' ',2)
+ 990 CONTINUE
+C GO UP FOR BURN
+ CALL LCMSIX(IPFBM,' ',2)
+ 1000 CONTINUE
+C
+ CALL LCMSIX(IPFBM,' ',2)
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(IXS,NJJ,IJJ)
+C
+ RETURN
+ 6000 FORMAT(' Keyword =',A8,' ncor =',i4,' Param =',8(2X,A8))
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:22:25 +0000