*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