diff options
Diffstat (limited to 'Dragon/src/EDIPXS.f')
| -rw-r--r-- | Dragon/src/EDIPXS.f | 571 |
1 files changed, 571 insertions, 0 deletions
diff --git a/Dragon/src/EDIPXS.f b/Dragon/src/EDIPXS.f new file mode 100644 index 0000000..7e81b8b --- /dev/null +++ b/Dragon/src/EDIPXS.f @@ -0,0 +1,571 @@ +*DECK EDIPXS + SUBROUTINE EDIPXS(IPEDIT,IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NSAVES, + > NGCOND,NMERGE,ILEAKS,NW,NTAUXT,EIGENK,B2,IGOVE, + > CUREIN,NIFISS,CURNAM,NEDMAC,VOLMER,WLETYC, + > WENERG,SCATTD,RATECM,FLUXCM,FADJCM,SIGS,SCATTS, + > DISFCT,ALBP,TAUXE,HVECT,OVERV,HFACT,HSPH,NENER, + > TIMEF,LH,LSPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Save homogenized/condensed macroscopic cross sections. +* +*Copyright: +* Copyright (C) 2002 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): G. Marleau +* +*Parameters: input +* IPEDIT pointer to the edition LCM object. +* IADJ type of flux weighting: +* = 0 direct flux weighting; +* = 1 direct-adjoint flux weighting. +* IPRINT print level; +* = 0 no print; +* = 1 print fluxes; +* = 2 1+print reaction rates; +* = 3 2+print homogenized cross sections. +* NL number of Legendre orders. +* NDEL number of delayed precursor groups. +* NALBP number of physical albedos. +* ITRANC type of transport correction. +* NSAVES homogenized cross section compute/save flag: +* = 0 no compute, no save; +* = 1 compute, no save; +* = 2 compute and save. +* NGCOND number of groups condensed. +* NMERGE number of regions merged. +* ILEAKS type of leakage calculation: +* = 0 no leakage; +* = 1 homogeneous leakage (Diffon); +* = 2 isotropic streaming (Ecco); +* = 3 anisotropic streaming (Tibere); +* = 4 inconsistent model (1/3*strd); +* = 10 isotropic diffusion coefficients recovered from input +* macrolib; +* = 11 anisotropic diffusion coefficients recovered from input +* macrolib. +* NW type of weighting for PN cross section info (=0 P0; =1 P1). +* NTAUXT number of reaction rate edits (=15+2*NDEL). +* EIGENK eigenvalue for problem. +* B2 square buckling: +* for ILEAKS=1,2,4: B2(4) is homogeneous; +* for ILEAKS=3: B2(1),B2(2),B2(3) are directional heterogeneous +* and B2(4) is homogeneous. +* IGOVE Golfier-Vergain flag (=0/1: don't/use Golfier-Vergain equ'n). +* CUREIN infinite multiplication factor. +* NIFISS number of fissile isotopes. +* CURNAM name of LCM directory where the merged/condensed cross +* sections are stored. +* NEDMAC number of extra edit vectors. +* VOLMER volume of region merged. +* WLETYC lethargy width condensed. +* WENERG energy group limits. +* SCATTD double precision scattering rates. +* NENER number of energy groups limits. +* TIMEF time stamp in day/burnup/irradiation. +* LH flag set to true if H-factors are set. +* LSPH flag set to true if SPH factors are set. +* +*Parameters: output +* RATECM averaged region/group cross sections: +* = RATECM(*,1) = total P0; +* = RATECM(*,2) = total P1; +* = RATECM(*,NW+2) = absorption; +* = RATECM(*,NW+3) = fission; +* = RATECM(*,NW+4) = fixed sources / productions; +* = RATECM(*,NW+5) = leakage; +* = RATECM(*,NW+6) = total out of group scattering; +* = RATECM(*,NW+7) = diagonal scattering x-s; +* = RATECM(*,NW+8) = chi; +* = RATECM(*,NW+9) = wims type transport correction; +* = RATECM(*,NW+10) = x-directed leakage; +* = RATECM(*,NW+11) = y-directed leakage; +* = RATECM(*,NW+12) = z-directed leakage; +* = RATECM(*,NW+13) = nu-sigf for delayed neutrons; +* = RATECM(*,NW+13+NDEL) = fission spectra for delayed neutrons. +* FLUXCM integrated region/group fluxes: +* = FLUXCM(*,1) = fluxes P0; +* = FLUXCM(*,2) = fluxes P1. +* FADJCM averaged region/group afjoint fluxes: +* = FADJCM(*,1) = adjoint fluxes P0; +* = FADJCM(*,2) = adjoint fluxes P1. +* SIGS Legendre dependent scattering cross sections. +* SCATTS homogenized scattering cross sections. +* DISFCT disadvantage factor. +* ALBP physical albedos. +* TAUXE extra edit rates. +* HVECT extra edit names. +* OVERV 1/v merge condensed. +* HFACT H-factors condensed. +* HSPH SPH factors condensed. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPEDIT + INTEGER IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NSAVES,NGCOND,NMERGE, + > ILEAKS,NW,NTAUXT,NIFISS,NEDMAC,NENER,IGOVE + REAL EIGENK,B2(4),CUREIN,VOLMER(NMERGE),WLETYC(NGCOND), + > WENERG(NGCOND+1),RATECM(NMERGE,NGCOND,NTAUXT), + > FLUXCM(NMERGE,NGCOND,NW+1),FADJCM(NMERGE,NGCOND,NW+1), + > SIGS(NMERGE,NGCOND,NL), + > SCATTS(NMERGE,NGCOND,NGCOND,NL),DISFCT(NGCOND), + > ALBP(NALBP,NGCOND,NGCOND),TAUXE(NMERGE,NGCOND,NEDMAC), + > OVERV(NMERGE,NGCOND),HFACT(NMERGE,NGCOND), + > HSPH(NMERGE,NGCOND),TIMEF(3) + LOGICAL LH,LSPH + CHARACTER CURNAM*12,HVECT(NEDMAC)*8 + DOUBLE PRECISION SCATTD(NMERGE,NGCOND,NGCOND,NL) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPEDIT,KPEDIT + CHARACTER APG*3 + PARAMETER (IUNOUT=6,APG=' > ',ILCMUP=1,ILCMDN=2,NSTATE=40) + CHARACTER CEDNAM*12,HSIGN*12,CM*2 + INTEGER IDATA(NSTATE),ISTATE(NSTATE) + DOUBLE PRECISION SCATWG,SCATTN,FAC1,FAC2 + LOGICAL LAL1D +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) ::IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) ::SCATC,ALPHA + REAL, ALLOCATABLE, DIMENSION(:,:) :: FACT,ALB1 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMERGE),NJJ(NMERGE),IPOS(NMERGE)) + ALLOCATE(SCATC(NMERGE*NGCOND),FACT(NMERGE,NW+1),ALPHA(NGCOND)) +*---- +* COMPUTE MERGED/CONDENSED X-S +*---- + IF(NSAVES.GE.1) THEN + IDATA(4)=0 + DO 200 IGR=1,NGCOND + DO 40 IKK=1,NMERGE + DO 5 IL=1,NW+1 + IF(FLUXCM(IKK,IGR,1).EQ.0.0) THEN + FACT(IKK,IL)=0.0 + ELSE + FACT(IKK,IL)=1.0/FLUXCM(IKK,IGR,IL) + ENDIF + 5 CONTINUE + RATECM(IKK,IGR,NW+3)=RATECM(IKK,IGR,NW+3)*FACT(IKK,1) + IF((RATECM(IKK,IGR,NW+3).NE.0.0).OR. + > (RATECM(IKK,IGR,NW+8).NE.0.0)) IDATA(4)=1 + IF(IADJ.EQ.0) THEN + DO IW=1,NW+1 + RATECM(IKK,IGR,IW)=RATECM(IKK,IGR,IW)*FACT(IKK,IW) + ENDDO + RATECM(IKK,IGR,NW+2)=RATECM(IKK,IGR,NW+2)*FACT(IKK,1) + RATECM(IKK,IGR,NW+4)=RATECM(IKK,IGR,NW+4)*FACT(IKK,1) + IF(NENER.GT.0) OVERV(IKK,IGR)=OVERV(IKK,IGR)*FACT(IKK,1) + IF(LH) HFACT(IKK,IGR)=HFACT(IKK,IGR)*FACT(IKK,1) + IF(LSPH) HSPH(IKK,IGR)=HSPH(IKK,IGR)*FACT(IKK,1) + IF(ITRANC.NE.0) RATECM(IKK,IGR,NW+9)=RATECM(IKK,IGR,NW+9) + > *FACT(IKK,1) + DO 10 IL=1,NL + IW=MIN(IL,NW+1,2) + SIGS(IKK,IGR,IL)=SIGS(IKK,IGR,IL)*FACT(IKK,IW) + 10 CONTINUE + ELSE IF(IADJ.EQ.1) THEN + DO IL=1,NW+1 + FAD1=FADJCM(IKK,IGR,IL) + RATECM(IKK,IGR,IL)=RATECM(IKK,IGR,IL)*FACT(IKK,IL)/FAD1 + ENDDO + FAD1=FADJCM(IKK,IGR,1) + RATECM(IKK,IGR,NW+2)=RATECM(IKK,IGR,NW+2)*FACT(IKK,1)/FAD1 + RATECM(IKK,IGR,NW+4)=RATECM(IKK,IGR,NW+4)*FACT(IKK,1)/FAD1 + IF(NENER.GT.0) OVERV(IKK,IGR)=OVERV(IKK,IGR)*FACT(IKK,1) + > /FAD1 + IF(LH) HFACT(IKK,IGR)=HFACT(IKK,IGR)*FACT(IKK,1)/FAD1 + IF(LSPH) HSPH(IKK,IGR)=HSPH(IKK,IGR)*FACT(IKK,1)/FAD1 + IF(ITRANC.NE.0) RATECM(IKK,IGR,NW+9)=RATECM(IKK,IGR,NW+9) + > *FACT(IKK,1)/FAD1 + DO 20 IL=1,NL + IW=MIN(IL,NW+1,2) + SIGS(IKK,IGR,IL)=SIGS(IKK,IGR,IL)*FACT(IKK,IW)/ + > FADJCM(IKK,IGR,IW) + 20 CONTINUE + ENDIF + DO 30 IDEL=1,NDEL + K=NW+12+IDEL + RATECM(IKK,IGR,K)=RATECM(IKK,IGR,K)*FACT(IKK,1) + 30 CONTINUE + 40 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4)) THEN + IF(IADJ.EQ.0) THEN + DO 50 IKK=1,NMERGE + RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1) + 50 CONTINUE + ELSE IF(IADJ.EQ.1) THEN + DEN2=0.0 + DO 60 IKK=1,NMERGE + DEN2=DEN2+FADJCM(IKK,IGR,1) + RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1)/ + > FADJCM(IKK,IGR,1) + 60 CONTINUE + ENDIF + ELSE IF(ILEAKS.GT.0) THEN + DO 70 IKK=1,NMERGE + RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1) + RATECM(IKK,IGR,NW+10)=RATECM(IKK,IGR,NW+10)*FACT(IKK,1) + RATECM(IKK,IGR,NW+11)=RATECM(IKK,IGR,NW+11)*FACT(IKK,1) + RATECM(IKK,IGR,NW+12)=RATECM(IKK,IGR,NW+12)*FACT(IKK,1) + 70 CONTINUE + ENDIF + DO 100 JGR=1,NGCOND + DO 90 IKK=1,NMERGE + DO 80 IL=1,NL + IW=MIN(IL,NW+1) + IF(IADJ.EQ.0) THEN + SCATTS(IKK,JGR,IGR,IL)=REAL(SCATTD(IKK,JGR,IGR,IL) + > *FACT(IKK,IW)) + ELSE IF(IADJ.EQ.1) THEN + SCATTS(IKK,JGR,IGR,IL)=REAL(SCATTD(IKK,JGR,IGR,IL) + > *FACT(IKK,IW)/FADJCM(IKK,JGR,IW)) + ENDIF + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + DO 110 IKK=1,NMERGE + RATECM(IKK,IGR,NW+7)=SCATTS(IKK,IGR,IGR,1) + 110 CONTINUE + DO 130 IED=1,NEDMAC + DO 120 IKK=1,NMERGE + IF(IADJ.EQ.0) THEN + TAUXE(IKK,IGR,IED)=TAUXE(IKK,IGR,IED)*FACT(IKK,1) + ELSE IF(IADJ.EQ.1) THEN + TAUXE(IKK,IGR,IED)=TAUXE(IKK,IGR,IED)*FACT(IKK,1)/ + > FADJCM(IKK,IGR,1) + ENDIF + 120 CONTINUE + 130 CONTINUE + 200 CONTINUE + IF(NSAVES.EQ.2) THEN +*---- +* COMPUTE THE GOLFIER-VERGAIN FACTORS +*---- + IF(IGOVE.EQ.1) THEN + DO 205 IGR=1,NGCOND + FAC1=0.0D0 + FAC2=0.0D0 + DO 204 IKK=1,NMERGE + FAC1=FAC1+RATECM(IKK,IGR,NW+5)*FLUXCM(IKK,IGR,1) + FAC2=FAC2+FLUXCM(IKK,IGR,1)/(3.0*(RATECM(IKK,IGR,1)- + > SIGS(IKK,IGR,2))) + 204 CONTINUE + ALPHA(IGR)=REAL(FAC1/FAC2) + 205 CONTINUE + IF(IPRINT.GE.3) WRITE(IUNOUT,6000) ALPHA(:) + ENDIF +*---- +* SAVE MERGED/CONDENSED X-S ON LCM +*---- + CALL LCMSIX(IPEDIT,CURNAM,ILCMUP) + CALL LCMSIX(IPEDIT,'MACROLIB',ILCMUP) + CALL LCMPUT(IPEDIT,'TIMESTAMP',3,2,TIMEF) + IDATA(1)=NGCOND + IDATA(2)=NMERGE + IDATA(3)=NL + IDATA(5)=NEDMAC + IDATA(6)=ITRANC + IDATA(7)=NDEL + IDATA(15)=IADJ + IF(NEDMAC.GT.0) THEN + CALL LCMPTC(IPEDIT,'ADDXSNAME-P0',8,NEDMAC,HVECT) + ENDIF + JPEDIT=LCMLID(IPEDIT,'GROUP',NGCOND) + DO 210 IGR=1,NGCOND + KPEDIT=LCMDIL(JPEDIT,IGR) + IF(NEDMAC.GT.0) THEN + DO 211 IED=1,NEDMAC + CEDNAM=HVECT(IED) + IF((CEDNAM(:2).EQ.'NW').OR. + > (CEDNAM.EQ.'H-FACTOR')) GO TO 211 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,TAUXE(1,IGR,IED)) + 211 CONTINUE + ENDIF + IF(NENER.GT.0) CALL LCMPUT(KPEDIT,'OVERV',NMERGE,2, + > OVERV(1,IGR)) + IF(LH) CALL LCMPUT(KPEDIT,'H-FACTOR',NMERGE,2,HFACT(1,IGR)) + IF(LSPH) CALL LCMPUT(KPEDIT,'NSPH',NMERGE,2,HSPH(1,IGR)) + DO IW=1,MIN(NW+1,10) + WRITE(CEDNAM,'(4HNTOT,I1)') IW-1 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,IW)) + ENDDO + CALL LCMPUT(KPEDIT,'ABS',NMERGE,2,RATECM(1,IGR,NW+2)) + CALL LCMPUT(KPEDIT,'PRODUCTION',NMERGE,2,RATECM(1,IGR,NW+4)) + DO 212 IKK=1,NMERGE + RATECM(IKK,IGR,NW+6)=RATECM(IKK,IGR,1)-RATECM(IKK,IGR,NW+2) + 212 CONTINUE + IF(IDATA(4).EQ.1) THEN + CALL LCMPUT(KPEDIT,'NUSIGF',NMERGE,2,RATECM(1,IGR,NW+3)) + CALL LCMPUT(KPEDIT,'CHI',NMERGE,2,RATECM(1,IGR,NW+8)) + DO 901 IDEL=1,NDEL + K=NW+12+IDEL + WRITE(CEDNAM,'(6HNUSIGF,I2.2)') IDEL + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,K)) + WRITE(CEDNAM,'(3HCHI,I2.2)') IDEL + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,NDEL+K)) + 901 CONTINUE + ENDIF + IF(ITRANC.NE.0) THEN + CALL LCMPUT(KPEDIT,'TRANC',NMERGE,2,RATECM(1,IGR,NW+9)) + ENDIF + IF(IGOVE.EQ.1) THEN + ! use the Golfier-Vergain formula + SCATC(:NMERGE)=ALPHA(IGR)/(3.0*(RATECM(:NMERGE,IGR,1) + > -SIGS(:NMERGE,IGR,2))) + CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,SCATC) + ELSE IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) + > THEN + CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,NW+5)) + ELSE IF(ILEAKS.EQ.3) THEN + CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,NW+5)) + CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,NW+10)) + CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,NW+11)) + CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,NW+12)) + ELSE IF(ILEAKS.EQ.11) THEN + CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,NW+10)) + CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,NW+11)) + CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,NW+12)) + ENDIF + CALL LCMPUT(KPEDIT,'FLUX-INTG',NMERGE,2,FLUXCM(1,IGR,1)) + DO IL=2,MIN(NW+1,10) + WRITE(CEDNAM,'(11HFLUX-INTG-P,I1)') IL-1 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,FLUXCM(1,IGR,IL)) + ENDDO + IF(IADJ.EQ.1) THEN + DO IL=1,MIN(NW+1,10) + WRITE(CEDNAM,'(4HNWAT,I1)') IL-1 + CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,FADJCM(1,IGR,IL)) + ENDDO + ENDIF + DO 350 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + IPOSIT=0 + DO 214 IKK=1,NMERGE + J2=IGR + J1=IGR + DO 215 JGR=1,NGCOND + IF(SCATTS(IKK,IGR,JGR,IL).NE.0.0) THEN + J2=MAX(J2,JGR) + J1=MIN(J1,JGR) + ENDIF + 215 CONTINUE + NJJ(IKK)=J2-J1+1 + IJJ(IKK)=J2 + IPOS(IKK)=IPOSIT+1 + DO 216 JGR=J2,J1,-1 + IPOSIT=IPOSIT+1 + SCATC(IPOSIT)=SCATTS(IKK,IGR,JGR,IL) + 216 CONTINUE + 214 CONTINUE + CALL LCMPUT(KPEDIT,'SIGS'//CM,NMERGE,2,SIGS(1,IGR,IL)) + CALL LCMPUT(KPEDIT,'SIGW'//CM,NMERGE,2,SCATTS(1,IGR,IGR,IL)) + CALL LCMPUT(KPEDIT,'SCAT'//CM,IPOSIT,2,SCATC) + CALL LCMPUT(KPEDIT,'NJJS'//CM,NMERGE,1,NJJ) + CALL LCMPUT(KPEDIT,'IJJS'//CM,NMERGE,1,IJJ) + CALL LCMPUT(KPEDIT,'IPOS'//CM,NMERGE,1,IPOS) + 350 CONTINUE + IF(IPRINT.GE.4) THEN + WRITE(IUNOUT,'(/14H G R O U P :,I4)') IGR + CALL LCMLIB(KPEDIT) + ENDIF + 210 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) THEN + CALL LCMPUT(IPEDIT,'B2 B1HOM',1,2,B2(4)) + ELSE IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN + CALL LCMPUT(IPEDIT,'B2 B1HOM',1,2,B2(4)) + CALL LCMPUT(IPEDIT,'B2 HETE',3,2,B2) + ENDIF + IDATA(8)=NALBP + DO 217 I=9,NSTATE + IDATA(I)=0 + 217 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR. + > (ILEAKS.EQ.10)) THEN + IDATA(9)=1 + ELSE IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN + IDATA(9)=2 + ENDIF + IDATA(10)=NW + IF(LSPH) THEN + IDATA(14)=1 + CALL LCMSIX(IPEDIT,'SPH',1) + ISTATE(:)=0 + ISTATE(1)=4 + ISTATE(2)=1 + ISTATE(6)=1 + ISTATE(7)=1 + ISTATE(8)=NGCOND + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMSIX(IPEDIT,' ',2) + ENDIF + CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IDATA) + HSIGN='L_MACROLIB' + CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN) + IF(NENER.GT.0) THEN + CALL LCMPUT(IPEDIT,'ENERGY',NGCOND+1,2,WENERG) + CALL LCMPUT(IPEDIT,'DELTAU',NGCOND,2,WLETYC) + ENDIF + CALL LCMPUT(IPEDIT,'VOLUME',NMERGE,2,VOLMER) + IF((EIGENK.NE.0.0).AND.(NIFISS.GT.0)) THEN + CALL LCMPUT(IPEDIT,'K-EFFECTIVE',1,2,EIGENK) + ENDIF + IF((CUREIN.NE.0.0).AND.(NIFISS.GT.0)) THEN + CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,CUREIN) + ENDIF + CALL LCMPUT(IPEDIT,'FLUXDISAFACT',NGCOND,2,DISFCT) + IF(NALBP.GT.0) THEN + LAL1D=.TRUE. + DO IAL=1,NALBP + DO IGR=1,NGCOND + DO JGR=1,NGCOND + IF((IGR.NE.JGR).AND.(ALBP(IAL,IGR,JGR).NE.0.0)) THEN + LAL1D=.FALSE. + GO TO 218 + ENDIF + ENDDO + ENDDO + ENDDO + 218 IF(LAL1D) THEN +* diagonal physical albedos + ALLOCATE(ALB1(NALBP,NGCOND)) + DO IAL=1,NALBP + DO IGR=1,NGCOND + ALB1(IAL,IGR)=ALBP(IAL,IGR,IGR) + ENDDO + ENDDO + CALL LCMPUT(IPEDIT,'ALBEDO',NALBP*NGCOND,2,ALB1) + DEALLOCATE(ALB1) + ELSE +* matrix physical albedos + CALL LCMPUT(IPEDIT,'ALBEDO',NALBP*NGCOND*NGCOND,2,ALBP) + ENDIF + ENDIF + CALL LCMSIX(IPEDIT,' ',ILCMDN) + CALL LCMSIX(IPEDIT,' ',ILCMDN) + IF(IPRINT.GT.0) WRITE(IUNOUT,6031) CURNAM + ENDIF + ENDIF +*---- +* PRINT X-S +*---- + IF(IPRINT.GE.3) THEN + IF(IGOVE.EQ.1) THEN + WRITE(IUNOUT,'(/41H EDIPXS: USE THE GOLFIER-VERGAIN APPROXIM, + > 43HATION FOR DIFFUSION COEFFICIENT CALCULATION)') + ENDIF + WRITE(IUNOUT,6010) + DO 170 IGR=1,NGCOND + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR. + > (ILEAKS.EQ.10)) THEN + WRITE(IUNOUT,6020) IGR + ELSE + WRITE(IUNOUT,6021) IGR + ENDIF + DO 171 IKK=1,NMERGE +*---- +* UNCOMMENT THE 4 LINES TO PERFORM TRANSPORT CORRECTION +*---- + TOTAL=RATECM(IKK,IGR,1) + SCATWG=SCATTS(IKK,IGR,IGR,1) +* IF(ITRANC.NE.0) THEN +* TOTAL=TOTAL-RATECM(IKK,IGR,NW+9) +* SCATWG=SCATWG-RATECM(IKK,IGR,NW+9) +* ENDIF +* + IF (FLUXCM(IKK,IGR,1).NE.0.0) THEN + FLXAVG=FLUXCM(IKK,IGR,1)/VOLMER(IKK) + SCATTN=0.0D0 + DO 172 JGR=1,NGCOND + IF(JGR.NE.IGR) SCATTN=SCATTN+SCATTS(IKK,JGR,IGR,1) + 172 CONTINUE + IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR. + > (ILEAKS.EQ.10)) THEN + WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL, + > RATECM(IKK,IGR,NW+5),RATECM(IKK,IGR,NW+2), + > RATECM(IKK,IGR,NW+3),RATECM(IKK,IGR,NW+8),SCATWG,SCATTN + ELSE + WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL, + > RATECM(IKK,IGR,NW+2),RATECM(IKK,IGR,NW+3), + > RATECM(IKK,IGR,NW+8),SCATWG,SCATTN + ENDIF + ENDIF + 171 CONTINUE + IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN + WRITE(IUNOUT,6024) + DO 173 IKK=1,NMERGE + WRITE(IUNOUT,6025) IKK,RATECM(IKK,IGR,NW+10), + > RATECM(IKK,IGR,NW+11),RATECM(IKK,IGR,NW+12), + > RATECM(IKK,IGR,NW+5) + 173 CONTINUE + ENDIF + WRITE(IUNOUT,6026) DISFCT(IGR) + 170 CONTINUE + ENDIF + IF(IPRINT.GE.4) THEN + DO 190 IKK=1,NMERGE + WRITE(IUNOUT,6027) IKK,(JGR,JGR=1,NGCOND) + DO 180 IGR=1,NGCOND +*---- +* UNCOMMENT THE FOLLOWING LINE TO PERFORM TRANSPORT CORRECTION +*---- + SCATWG=SCATTS(IKK,IGR,IGR,1) +* IF(ITRANC.NE.0) SCATWG=SCATWG-RATECM(IKK,IGR,NW+9) +* + WRITE(IUNOUT,6028) IGR,(SCATTS(IKK,JGR,IGR,1),JGR=1,IGR-1), + > SCATWG,(SCATTS(IKK,JGR,IGR,1),JGR=IGR+1,NGCOND) + 180 CONTINUE + WRITE (IUNOUT,'(//)') + 190 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ALPHA,FACT,SCATC) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN +*---- +* FORMAT +*---- + 6000 FORMAT(/33H EDIPXS: Golfier-Vergain factors=,1P,10E12.4/(33X, + > 10E12.4)) + 6010 FORMAT(/' F L U X E S A N D H O M O G E N I Z E D X - S'/ + > 1X,51(1H-)) + 6020 FORMAT(/' G R O U P :',I4/ + >1X,'REGION',3X,'AVERAGE',9X,'NTOT0',7X,'DIFFUSION',5X, + >'ABSORPTION',5X,'NUSIGF',8X,'FISSION',10X,'SCATTERING X-S'/11X, + >'FLUX',12X,'X-S',7X,'COEFFICIENT',7X,'X-S',10X,'X-S',10X, + >'SPECTRUM',2X,'WITHIN GROUP',2X,'OUT OF GROUP') + 6021 FORMAT(/' G R O U P :',I4/ + >1X,'REGION',3X,'AVERAGE',9X,'NTOT0',7X, + >'ABSORPTION',5X,'NUSIGF',8X,'FISSION',10X,'SCATTERING X-S'/11X, + >'FLUX',12X,'X-S',11X,'X-S',10X,'X-S',10X,'SPECTRUM',2X, + >'WITHIN GROUP',2X,'OUT OF GROUP') + 6022 FORMAT(1X,I4,1P,8E14.5) + 6024 FORMAT(/' REGION X-LEAKAGE Y-LEAKAGE Z-LEAKAGE', + >' HOM-LEAKAGE'/' COEFFICIENT COEFFICIENT ', + >'COEFFICIENT COEFFICIENT') + 6025 FORMAT(1X,I6,1X,1P,5E14.5) + 6026 FORMAT(/' FLUX DISADVANTAGE FACTOR =',1P,E14.5) + 6027 FORMAT(/47H SCATTERING TRANSFER X-S (I TOWARD J) IN REGION,I5,1H: + > //(11X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=, + > I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X, + > 2HJ=,I4)) + 6028 FORMAT(3H I=,I4,2H: ,1P,10E12.4/(9X,10E12.4)) + 6031 FORMAT(/53H MERGED/CONDENSED SET OF X-S SAVED IN LCM DIRECTORY ', + > A12,2H'./) + END |