diff options
| author | HEBERT Alain <alain.hebert@polymtl.ca> | 2025-12-28 15:55:41 -0500 |
|---|---|---|
| committer | HEBERT Alain <alain.hebert@polymtl.ca> | 2025-12-28 15:55:41 -0500 |
| commit | 744b40856a035580b786378cae13d453edd26689 (patch) | |
| tree | d7056a5fcb559893c91df8d7533fa5fdb03d8480 /Dragon/src | |
| parent | ec64ba52445d2d06deba1216471ccf3d289c78a3 (diff) | |
Resolve "Depreciate use of Version 4 and 5.0 Draglibs"
Diffstat (limited to 'Dragon/src')
44 files changed, 910 insertions, 515 deletions
diff --git a/Dragon/src/BREANM.f b/Dragon/src/BREANM.f index 345268d..8a2b2c0 100644 --- a/Dragon/src/BREANM.f +++ b/Dragon/src/BREANM.f @@ -1,7 +1,7 @@ *DECK BREANM - SUBROUTINE BREANM(IPMAC1,NG,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF,B2, - 1 ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, - 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) + SUBROUTINE BREANM(IPMAC1,NG,LX1,NMIX1,IMIX,ICODE,ISPH,IH,ZKEFF, + 1 B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,HFACT1,JXM,JXP, + 2 FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) * *----------------------------------------------------------------------- * @@ -36,6 +36,7 @@ * CHI1 fission spectra. * SIGF1 nu*fission cross sections. * SCAT1 scattering P0 cross sections. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * JXP right boundary currents. * FHETXM left boundary fluxes. @@ -57,8 +58,8 @@ INTEGER NG,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,NGET,IPRINT REAL ZKEFF,B2,ENER(NG+1),XXX1(LX1+1),VOL1(NMIX1),FLX1(NMIX1,NG), 1 DC1(NMIX1,NG),TOT1(NMIX1,NG),CHI1(NMIX1,NG),SIGF1(NMIX1,NG), - 2 SCAT1(NMIX1,NG,NG),JXM(NMIX1,NG),JXP(NMIX1,NG),FHETXM(NMIX1,NG), - 3 FHETXP(NMIX1,NG),ADF1(NMIX1,NG),ADFREF(NG) + 2 SCAT1(NMIX1,NG,NG),HFACT1(NMIX1,NG),JXM(NMIX1,NG),JXP(NMIX1,NG), + 3 FHETXM(NMIX1,NG),FHETXP(NMIX1,NG),ADF1(NMIX1,NG),ADFREF(NG) *---- * LOCAL VARIABLES *---- @@ -227,6 +228,9 @@ DO JGR=1,NG SCAT1(IBM,IGR,JGR)=SCAT1(IBM,IGR,JGR)/FDXM(IBM,JGR) ENDDO + IF(IH.EQ.1) THEN + HFACT1(IBM,IGR)=HFACT1(IBM,IGR)/FDXM(IBM,IGR) + ENDIF ENDDO ENDDO IF(ICODE(2).NE.0) THEN @@ -332,6 +336,7 @@ CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + IF(IH.EQ.1) CALL LCMPUT(KPMAC1,'H-FACTOR',NMIX1,2,HFACT1(:,IGR)) ENDDO *---- * SCRATCH STORAGE DEALLOCATION diff --git a/Dragon/src/BREDRV.f b/Dragon/src/BREDRV.f index 3e9a12a..805edd9 100644 --- a/Dragon/src/BREDRV.f +++ b/Dragon/src/BREDRV.f @@ -77,8 +77,8 @@ 1 ISTOP REAL, ALLOCATABLE, DIMENSION(:) :: XXX,XXXS,XXX1,ENER,ZKEFF,B2 REAL, ALLOCATABLE, DIMENSION(:,:) :: VOL1 - REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLX1,DC1,CHI1,SIGF1,JXM, - 1 JXP,ADF1 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLX1,DC1,CHI1,SIGF1,HFACT1, + 1 JXM,JXP,ADF1 REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: TOT1,FHETXM,FHETXP REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: SCAT1 TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPMAC2 @@ -252,45 +252,46 @@ NL=NLF ALLOCATE(VOL1(NMIX1,NC),FLX1(NMIX1,NG,NC),DC1(NMIX1,NG,NC), 1 TOT1(NMIX1,NG,NL,NC),CHI1(NMIX1,NG,NC),SIGF1(NMIX1,NG,NC), - 2 SCAT1(NMIX1,NG,NG,NL,NC),JXM(NMIX1,NG,NC),JXP(NMIX1,NG,NC), - 3 FHETXM(NMIX1,NG,NL,NC),FHETXP(NMIX1,NG,NL,NC),ADF1(NMIX1,NG,NC), - 4 ZKEFF(NC),B2(NC)) + 2 SCAT1(NMIX1,NG,NG,NL,NC),HFACT1(NMIX1,NG,NC),JXM(NMIX1,NG,NC), + 3 JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC),FHETXP(NMIX1,NG,NL,NC), + 4 ADF1(NMIX1,NG,NC),ZKEFF(NC),B2(NC)) CALL BREMAC(NC,IPMAC2,NG,NL,LX1,NMIX1,NMIX2,IMIX,IMIX1,IGAP, - 1 ILEAKS,IDF,IPRINT,ZKEFF,B2,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1, - 2 JXM,JXP,FHETXM,FHETXP,ADF1) + 1 ILEAKS,IDF,IPRINT,IH,ZKEFF,B2,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1, + 2 SCAT1,HFACT1,JXM,JXP,FHETXM,FHETXP,ADF1) *---- * SELECT A REFLECTOR MODEL *---- IF(HMREFL.EQ."DF-NEM") THEN IF(NC.NE.1) CALL XABORT('BREDRV: NC=1 EXPECTED.') - CALL BRENEM(IPMAC1,NG,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH,ZKEFF, - 1 B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, - 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) + CALL BRENEM(IPMAC1,NG,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH,IH,ZKEFF, + 1 B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,HFACT1,JXM,JXP, + 2 FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) ELSE IF(HMREFL.EQ."DF-ANM") THEN IF(NC.NE.1) CALL XABORT('BREDRV: NC=1 EXPECTED.') - CALL BREANM(IPMAC1,NG,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF,B2,ENER, - 1 XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM,FHETXP, - 2 ADF1,NGET,ADFREF,IPRINT) + CALL BREANM(IPMAC1,NG,LX1,NMIX1,IMIX,ICODE,ISPH,IH,ZKEFF,B2, + 1 ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,HFACT1,JXM,JXP, + 2 FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) ELSE IF(HMREFL.EQ."DF-RT") THEN IF(NC.NE.1) CALL XABORT('BREDRV: NC=1 EXPECTED.') - CALL BRERT(IPMAC1,IELEM,ICOL,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH, + CALL BRERT(IPMAC1,IELEM,ICOL,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH,IH, 1 IDIFF,ZKEFF,B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1, - 2 JXM,JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) + 2 HFACT1,JXM,JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) ELSE IF(HMREFL.EQ."ERM-NEM") THEN - CALL BREERM(IPMAC1,NC,NG,NL,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH, - 1 ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP, - 2 FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) + CALL BREERM(IPMAC1,NC,NG,NL,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH,IH, + 1 ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,HFACT1,JXM, + 2 JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) ELSE IF(HMREFL.EQ."ERM-ANM") THEN - CALL BREERA(IPMAC1,NC,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF,B2, - 1 ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, - 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) + CALL BREERA(IPMAC1,NC,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH,IH,ZKEFF, + 1 B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,HFACT1,JXM,JXP, + 2 FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) ELSE IF(HMREFL.EQ."LEFEBVRE-LEB") THEN IF(NC.NE.2) CALL XABORT('BREDRV: NC=2 EXPECTED.') - CALL BRELLB(IPMAC1,NC,NG,NL,NMIX1,ENER,JXM,FHETXM,IPRINT) + CALL BRELLB(IPMAC1,NC,NG,NL,NMIX1,IH,ENER,HFACT1,JXM,FHETXM, + 1 IPRINT) ELSE IF(HMREFL.EQ."KOEBKE") THEN IF(NC.NE.2) CALL XABORT('BREDRV: NC=2 EXPECTED.') - CALL BREKOE(IPMAC1,NC,NG,NL,NMIX1,ISPH,B2,ENER,DC1,TOT1,SCAT1, - 1 JXM,FHETXM,IPRINT) + CALL BREKOE(IPMAC1,NC,NG,NL,NMIX1,ISPH,IH,B2,ENER,DC1,TOT1, + 1 SCAT1,HFACT1,JXM,FHETXM,IPRINT) ELSE WRITE(HSMG,'(25H BREDRV: REFLECTOR MODEL ,A,12H IS UNKNOWN.)') 1 HMREFL @@ -299,8 +300,8 @@ *---- * SCRATCH STORAGE DEALLOCATION *---- - DEALLOCATE(IMIX,B2,ZKEFF,ADF1,FHETXP,FHETXM,JXP,JXM,SCAT1,SIGF1, - 1 CHI1,TOT1,DC1,FLX1,VOL1) + DEALLOCATE(IMIX,B2,ZKEFF,ADF1,FHETXP,FHETXM,JXP,JXM,HFACT1,SCAT1, + 1 SIGF1,CHI1,TOT1,DC1,FLX1,VOL1) DEALLOCATE(XXX1,XXXS,IMIXS,ENER,IHOM) DEALLOCATE(IPMAC2) RETURN diff --git a/Dragon/src/BREERA.f b/Dragon/src/BREERA.f index 336032f..0aedba7 100644 --- a/Dragon/src/BREERA.f +++ b/Dragon/src/BREERA.f @@ -1,7 +1,7 @@ *DECK BREERA - SUBROUTINE BREERA(IPMAC1,NC,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH,ZKEFF, - 1 B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, - 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) + SUBROUTINE BREERA(IPMAC1,NC,NG,NL,LX1,NMIX1,IMIX,ICODE,ISPH,IH, + 1 ZKEFF,B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,HFACT1, + 2 JXM,JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) * *----------------------------------------------------------------------- * @@ -28,6 +28,7 @@ * IMIX mix index of each node. * ICODE physical albedo index on each side of the domain. * ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* IH H-FACTOR flag (=0: not used; =1: recovered). * ZKEFF effective multiplication factor. * B2 buckling. * ENER energy limits. @@ -39,6 +40,7 @@ * CHI1 fission spectra. * SIGF1 nu*fission cross sections. * SCAT1 scattering P0 cross sections. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * JXP right boundary currents. * FHETXM left boundary fluxes. @@ -57,12 +59,13 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC1 - INTEGER NC,NG,NL,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,NGET,IPRINT + INTEGER NC,NG,NL,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,IH,NGET,IPRINT REAL ZKEFF(NC),B2(NC),ENER(NG+1),XXX1(LX1+1),VOL1(NMIX1,NC), 1 FLX1(NMIX1,NG,NC),DC1(NMIX1,NG,NC),TOT1(NMIX1,NG,NL,NC), 2 CHI1(NMIX1,NG,NC),SIGF1(NMIX1,NG,NC),SCAT1(NMIX1,NG,NG,NL,NC), - 3 JXM(NMIX1,NG,NC),JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC), - 4 FHETXP(NMIX1,NG,NL,NC),ADF1(NMIX1,NG,NC),ADFREF(NG) + 3 HFACT1(NMIX1,NG,NC),JXM(NMIX1,NG,NC),JXP(NMIX1,NG,NC), + 4 FHETXM(NMIX1,NG,NL,NC),FHETXP(NMIX1,NG,NL,NC),ADF1(NMIX1,NG,NC), + 5 ADFREF(NG) *---- * LOCAL VARIABLES *---- @@ -76,7 +79,7 @@ INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS REAL, ALLOCATABLE, DIMENSION(:) :: WORK1D,WORK1,WORK2,WORK4,WORK5, 1 VOLTOT - REAL, ALLOCATABLE, DIMENSION(:,:) :: FLX,DC,TOT,CHI,SIGF, + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLX,DC,TOT,CHI,SIGF,HFACT, 1 ADF,AFACTOR,BETA,WORK3 REAL, ALLOCATABLE, DIMENSION(:,:,:) ::FDXM,FDXP,SCAT REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: TAU,B,X @@ -87,7 +90,8 @@ *---- ALLOCATE(WORK1(NG),WORK2(NG),WORK4(NG),WORK5(NG),VOLTOT(NMIX1), 1 FLX(NMIX1,NG),DC(NMIX1,NG),TOT(NMIX1,NG),CHI(NMIX1,NG), - 1 SIGF(NMIX1,NG),ADF(NMIX1,NG),AFACTOR(NG,NG),BETA(NG,NG)) + 1 SIGF(NMIX1,NG),HFACT(NMIX1,NG),ADF(NMIX1,NG),AFACTOR(NG,NG), + 2 BETA(NG,NG)) ALLOCATE(FDXM(NMIX1,NG,NG),FDXP(NMIX1,NG,NG),SCAT(NMIX1,NG,NG), 1 WORK3(NG,NG)) ALLOCATE(FHOMM(NC,NG,NMIX1),FHOMP(NC,NG,NMIX1),L(NG,2*NG,LX1), @@ -102,6 +106,7 @@ CHI(:,:)=0.0 SIGF(:,:)=0.0 SCAT(:,:,:)=0.0 + HFACT(:,:)=0.0 ADF(:,:)=0.0 FHOMM(:NC,:NG,:NMIX1)=0.0D0 FHOMP(:NC,:NG,:NMIX1)=0.0D0 @@ -117,6 +122,7 @@ DO JGR=1,NG SCAT(IBM,IGR,JGR)=SCAT(IBM,IGR,JGR)+SCAT1(IBM,IGR,JGR,1,IC) ENDDO + IF(IH.EQ.1) HFACT(IBM,IGR)=HFACT(IBM,IGR)+HFACT1(IBM,IGR,IC) ADF(IBM,IGR)=ADF(IBM,IGR)+ADF1(IBM,IGR,IC) ENDDO ENDDO @@ -128,6 +134,7 @@ CHI(:,:)=CHI(:,:)/REAL(NC) SIGF(:,:)=SIGF(:,:)/REAL(NC) SCAT(:,:,:)=SCAT(:,:,:)/REAL(NC) + IF(IH.EQ.1) HFACT(:,:)=HFACT(:,:)/REAL(NC) ADF(:,:)=ADF(:,:)/REAL(NC) *---- * LOOP OVER CASES @@ -430,14 +437,15 @@ CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + IF(IH.EQ.1) CALL LCMPUT(KPMAC1,'H-FACTOR',NMIX1,2,HFACT(:,IGR)) ENDDO *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(R,L,FHOMP,FHOMM) DEALLOCATE(SCAT,FDXP,FDXM) - DEALLOCATE(WORK3,BETA,AFACTOR,ADF,SIGF,CHI,TOT,DC,FLX,VOLTOT, - 1 WORK5,WORK4,WORK2,WORK1) + DEALLOCATE(WORK3,BETA,AFACTOR,ADF,HFACT,SIGF,CHI,TOT,DC,FLX, + 1 VOLTOT,WORK5,WORK4,WORK2,WORK1) RETURN 20 FORMAT(1X,A9,1P,10E12.4,/(10X,10E12.4)) END diff --git a/Dragon/src/BREERM.f b/Dragon/src/BREERM.f index b2d146b..1b59f86 100644 --- a/Dragon/src/BREERM.f +++ b/Dragon/src/BREERM.f @@ -1,7 +1,7 @@ *DECK BREERM SUBROUTINE BREERM(IPMAC1,NC,NG,NL,LX1,NMIX1,ITRIAL,IMIX,ICODE, - 1 ISPH,ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP, - 2 FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) + 1 ISPH,IH,ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1, + 2 HFACT1,JXM,JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) * *----------------------------------------------------------------------- * @@ -30,6 +30,7 @@ * IMIX mix index of each node. * ICODE physical albedo index on each side of the domain. * ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* IH H-FACTOR flag (=0: not used; =1: recovered). * ZKEFF effective multiplication factor. * B2 buckling. * ENER energy limits. @@ -40,6 +41,7 @@ * CHI1 fission spectra. * SIGF1 nu*fission cross sections. * SCAT1 scattering P0 cross sections. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * JXP right boundary currents. * FHETXM left boundary fluxes. @@ -58,13 +60,13 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC1 - INTEGER NC,NG,NL,LX1,NMIX1,ITRIAL(NG),IMIX(LX1),ICODE(2),ISPH, + INTEGER NC,NG,NL,LX1,NMIX1,ITRIAL(NG),IMIX(LX1),ICODE(2),ISPH,IH, 1 NGET,IPRINT REAL ZKEFF(NC),B2(NC),ENER(NG+1),VOL1(NMIX1,NC),FLX1(NMIX1,NG,NC), 1 DC1(NMIX1,NG,NC),TOT1(NMIX1,NG,NL,NC),CHI1(NMIX1,NG,NC), - 2 SIGF1(NMIX1,NG,NC),SCAT1(NMIX1,NG,NG,NL,NC),JXM(NMIX1,NG,NC), - 3 JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC),FHETXP(NMIX1,NG,NL,NC), - 4 ADF1(NMIX1,NG,NC),ADFREF(NG) + 2 SIGF1(NMIX1,NG,NC),SCAT1(NMIX1,NG,NG,NL,NC),HFACT1(NMIX1,NG,NC), + 3 JXM(NMIX1,NG,NC),JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC), + 4 FHETXP(NMIX1,NG,NL,NC),ADF1(NMIX1,NG,NC),ADFREF(NG) *---- * LOCAL VARIABLES *---- @@ -80,7 +82,7 @@ INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS REAL, ALLOCATABLE, DIMENSION(:) :: WORK,ETA,VOL REAL, ALLOCATABLE, DIMENSION(:,:) :: AB,ALPHA,FLX,DC,TOT,CHI,SIGF, - 1 ADF,AFACTOR,BETA + 1 HFACT,ADF,AFACTOR,BETA REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FDXM,FDXP,SCAT REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: TAU,B,X REAL(KIND=8), ALLOCATABLE, DIMENSION(:,:) :: WORK2 @@ -91,7 +93,8 @@ ALLOCATE(ETA(NG),ALPHA(5,NG),FDXM(NMIX1,NG,NG),FDXP(NMIX1,NG,NG), 1 AFACTOR(NG,NG),BETA(NG,NG),FHOMM(NC,NG,NMIX1),FHOMP(NC,NG,NMIX1)) ALLOCATE(VOL(NMIX1),FLX(NMIX1,NG),DC(NMIX1,NG),TOT(NMIX1,NG), - 1 CHI(NMIX1,NG),SIGF(NMIX1,NG),SCAT(NMIX1,NG,NG),ADF(NMIX1,NG)) + 1 CHI(NMIX1,NG),SIGF(NMIX1,NG),SCAT(NMIX1,NG,NG),HFACT(NMIX1,NG), + 2 ADF(NMIX1,NG)) *---- * AVERAGE THE OUTPUT NODAL MACROLIB *---- @@ -102,6 +105,7 @@ CHI(:,:)=0.0 SIGF(:,:)=0.0 SCAT(:,:,:)=0.0 + HFACT(:,:)=0.0 ADF(:,:)=0.0 DO IC=1,NC DO IBM=1,NMIX1 @@ -115,6 +119,7 @@ DO JGR=1,NG SCAT(IBM,IGR,JGR)=SCAT(IBM,IGR,JGR)+SCAT1(IBM,IGR,JGR,1,IC) ENDDO + IF(IH.EQ.1) HFACT(IBM,IGR)=HFACT(IBM,IGR)+HFACT1(IBM,IGR,IC) ADF(IBM,IGR)=ADF(IBM,IGR)+ADF1(IBM,IGR,IC) ENDDO ENDDO @@ -126,6 +131,7 @@ CHI(:,:)=CHI(:,:)/REAL(NC) SIGF(:,:)=SIGF(:,:)/REAL(NC) SCAT(:,:,:)=SCAT(:,:,:)/REAL(NC) + IF(IH.EQ.1) HFACT(:,:)=HFACT(:,:)/REAL(NC) ADF(:,:)=ADF(:,:)/REAL(NC) *---- * LOOP OVER CASES @@ -512,11 +518,13 @@ CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + IF(IH.EQ.1) CALL LCMPUT(KPMAC1,'H-FACTOR',NMIX1,2,HFACT(:,IGR)) ENDDO *---- * SCRATCH STORAGE DEALLOCATION *---- - DEALLOCATE(WORK,IPOS,NJJ,IJJ,ADF,SCAT,SIGF,CHI,TOT,DC,FLX,VOL) + DEALLOCATE(WORK,IPOS,NJJ,IJJ,ADF,HFACT,SCAT,SIGF,CHI,TOT,DC,FLX, + 1 VOL) DEALLOCATE(FHOMP,FHOMM,BETA,AFACTOR,FDXP,FDXM,ALPHA,ETA) RETURN 20 FORMAT(1X,A9,1P,10E12.4,/(10X,10E12.4)) diff --git a/Dragon/src/BREKOE.f b/Dragon/src/BREKOE.f index d98ca1f..855bec2 100644 --- a/Dragon/src/BREKOE.f +++ b/Dragon/src/BREKOE.f @@ -1,6 +1,6 @@ *DECK BREKOE - SUBROUTINE BREKOE(IPMAC1,NC,NG,NL,NMIX1,ISPH,B2,ENER,DC1,TOT1, - 1 SCAT1,JXM,FHETXM,IPRINT) + SUBROUTINE BREKOE(IPMAC1,NC,NG,NL,NMIX1,ISPH,IH,B2,ENER,DC1,TOT1, + 1 SCAT1,HFACT1,JXM,FHETXM,IPRINT) * *----------------------------------------------------------------------- * @@ -24,10 +24,12 @@ * scattering in LAB). * NMIX1 number of mixtures in the nodal calculation. * ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* IH H-FACTOR flag (=0: not used; =1: recovered). * B2 buckling. * ENER energy limits. * TOT1 total cross sections. * SCAT1 scattering P0 cross sections. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * FHETXM left boundary fluxes. * IPRINT edition flag. @@ -39,9 +41,10 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC1 - INTEGER NC,NG,NL,NMIX1,ISPH,IPRINT + INTEGER NC,NG,NL,NMIX1,ISPH,IH,IPRINT REAL B2(NC),ENER(NG+1),DC1(NMIX1,NG,NC),TOT1(NMIX1,NG,NL,NC), - 1 SCAT1(NMIX1,NG,NG,NL,NC),JXM(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC) + 1 SCAT1(NMIX1,NG,NG,NL,NC),HFACT1(NMIX1,NG,NC),JXM(NMIX1,NG,NC), + 2 FHETXM(NMIX1,NG,NL,NC) *---- * LOCAL VARIABLES *---- @@ -192,6 +195,10 @@ CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + IF(IH.EQ.1) THEN + WORK(1)=0.5*(HFACT1(IBM,IGR,1)+HFACT1(IBM,IGR,2)) + CALL LCMPUT(KPMAC1,'H-FACTOR',NMIX1,2,WORK) + ENDIF ENDDO *---- * SCRATCH STORAGE DEALLOCATION diff --git a/Dragon/src/BRELLB.f b/Dragon/src/BRELLB.f index 205a994..e8ebcd1 100644 --- a/Dragon/src/BRELLB.f +++ b/Dragon/src/BRELLB.f @@ -1,5 +1,6 @@ *DECK BRELLB - SUBROUTINE BRELLB(IPMAC1,NC,NG,NL,NMIX1,ENER,JXM,FHETXM,IPRINT) + SUBROUTINE BRELLB(IPMAC1,NC,NG,NL,NMIX1,IH,ENER,HFACT1,JXM, + 1 FHETXM,IPRINT) * *----------------------------------------------------------------------- * @@ -22,7 +23,9 @@ * NL Legendre order of TOT1 and SCAT1 arrays (=1 for isotropic * scattering in LAB). * NMIX1 number of mixtures in the nodal calculation. +* IH H-FACTOR flag (=0: not used; =1: recovered). * ENER energy limits. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * FHETXM left boundary fluxes. * IPRINT edition flag. @@ -38,8 +41,9 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC1 - INTEGER NC,NG,NL,NMIX1,IPRINT - REAL ENER(NG+1),JXM(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC) + INTEGER NC,NG,NL,NMIX1,IH,IPRINT + REAL ENER(NG+1),HFACT1(NMIX1,NG,NC),JXM(NMIX1,NG,NC), + 1 FHETXM(NMIX1,NG,NL,NC) *---- * LOCAL VARIABLES *---- @@ -145,6 +149,10 @@ CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + IF(IH.EQ.1) THEN + WORK(1)=0.5*(HFACT1(IBM,IGR,1)+HFACT1(IBM,IGR,2)) + CALL LCMPUT(KPMAC1,'H-FACTOR',NMIX1,2,WORK) + ENDIF ENDDO *---- * SCRATCH STORAGE DEALLOCATION diff --git a/Dragon/src/BREMAC.f b/Dragon/src/BREMAC.f index eaba3e9..d742354 100644 --- a/Dragon/src/BREMAC.f +++ b/Dragon/src/BREMAC.f @@ -1,7 +1,7 @@ *DECK BREMAC SUBROUTINE BREMAC(NC,IPMAC2,NG,NL,LX1,NMIX1,NMIX2,IMIX,IMIX1, - 1 IGAP,ILEAKS,IDF,IPRINT,ZKEFF,B2,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1, - 2 SCAT1,JXM,JXP,FHETXM,FHETXP,ADF1) + 1 IGAP,ILEAKS,IDF,IPRINT,IH,ZKEFF,B2,VOL1,FLX1,DC1,TOT1,CHI1, + 2 SIGF1,SCAT1,HFACT1,JXM,JXP,FHETXM,FHETXP,ADF1) * *----------------------------------------------------------------------- * @@ -36,6 +36,7 @@ * IPRINT print parameter * *Parameters: output +* IH H-FACTOR flag (=0: not used; =1: recovered). * ZKEFF effective multiplication factor. * B2 buckling. * VOL1 volumes. @@ -45,6 +46,7 @@ * CHI1 fission spectra. * SIGF1 nu*fission cross sections. * SCAT1 scattering cross sections. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * JXP right boundary currents. * FHETXM left boundary fluxes. @@ -60,12 +62,12 @@ INTEGER NC TYPE(C_PTR) IPMAC2(NC) INTEGER NG,NL,LX1,NMIX1,NMIX2,IMIX(LX1),IMIX1(LX1),IGAP(LX1), - 1 ILEAKS,IDF,IPRINT + 1 ILEAKS,IDF,IPRINT,IH REAL ZKEFF(NC),B2(NC),VOL1(NMIX1,NC),FLX1(NMIX1,NG,NC), 1 DC1(NMIX1,NG,NC),TOT1(NMIX1,NG,NL,NC),CHI1(NMIX1,NG,NC), - 2 SIGF1(NMIX1,NG,NC),SCAT1(NMIX1,NG,NG,NL,NC),JXM(NMIX1,NG,NC), - 3 JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC),FHETXP(NMIX1,NG,NL,NC), - 4 ADF1(NMIX1,NG,NC) + 2 SIGF1(NMIX1,NG,NC),SCAT1(NMIX1,NG,NG,NL,NC),HFACT1(NMIX1,NG,NC), + 3 JXM(NMIX1,NG,NC),JXP(NMIX1,NG,NC),FHETXM(NMIX1,NG,NL,NC), + 4 FHETXP(NMIX1,NG,NL,NC),ADF1(NMIX1,NG,NC) *---- * LOCAL VARIABLES *---- @@ -77,7 +79,7 @@ *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,IMIX2 REAL, ALLOCATABLE, DIMENSION(:) :: VOL,WORK,SFIS,SFIS1 - REAL, ALLOCATABLE, DIMENSION(:,:) :: DC,CHI,SIGF + REAL, ALLOCATABLE, DIMENSION(:,:) :: DC,CHI,SIGF,HFACT REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLX,TOT REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SCAT DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DCOU @@ -86,7 +88,8 @@ *---- ALLOCATE(VOL(NMIX2),FLX(NMIX2,NG,NL),TOT(NMIX2,NG,NL), 1 DC(NMIX2,NG),CHI(NMIX2,NG),SIGF(NMIX2,NG),SCAT(NMIX2,NG,NG,NL), - 2 IMIX2(NMIX2),SFIS(NMIX2),SFIS1(NMIX1),DCOU(NMIX2+1,NG)) + 2 HFACT(NMIX2,NG),IMIX2(NMIX2),SFIS(NMIX2),SFIS1(NMIX1), + 3 DCOU(NMIX2+1,NG)) ALLOCATE(IJJ(NMIX2),NJJ(NMIX2),IPOS(NMIX2),WORK(NG*NMIX2)) *---- * SET IMIX2 @@ -111,11 +114,12 @@ CALL LCMGET(IPMAC2(IC),'K-EFFECTIVE',ZKEFF(IC)) B2(IC)=0.0 IF(ILEAKS.GT.0) THEN - CALL LCMLEN(IPMAC2(IC),'B2 B1HOM',ILONG,ITYLCM) - IF(ILONG.EQ.1) CALL LCMGET(IPMAC2(IC),'B2 B1HOM',B2(IC)) + CALL LCMLEN(IPMAC2(IC),'B2 B1HOM',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.1) CALL LCMGET(IPMAC2(IC),'B2 B1HOM',B2(IC)) ENDIF JPMAC2=LCMGID(IPMAC2(IC),'GROUP') SCAT(:,:,:,:)=0.0 + IH=0 DO IGR=1,NG KPMAC2=LCMGIL(JPMAC2,IGR) CALL LCMGET(KPMAC2,'FLUX-INTG',FLX(1,IGR,1)) @@ -155,8 +159,8 @@ CALL LCMGET(KPMAC2,'NUSIGF',SIGF(1,IGR)) DO IL=1,NL WRITE(CM,'(I2.2)') IL-1 - CALL LCMLEN(KPMAC2,'IJJS'//CM,ILONG,ITYLCM) - IF(ILONG.EQ.0) CYCLE + CALL LCMLEN(KPMAC2,'IJJS'//CM,ILCMLN,ITYLCM) + IF(ILCMLN.EQ.0) CYCLE CALL LCMGET(KPMAC2,'IJJS'//CM,IJJ) CALL LCMGET(KPMAC2,'NJJS'//CM,NJJ) CALL LCMGET(KPMAC2,'IPOS'//CM,IPOS) @@ -169,6 +173,11 @@ ENDDO ENDDO ENDDO + CALL LCMLEN(KPMAC2,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.GT.0) THEN + IH=1 + CALL LCMGET(KPMAC2,'H-FACTOR',HFACT(1,IGR)) + ENDIF DO IBM=1,NMIX2 FLX(IBM,IGR,:NL)=FLX(IBM,IGR,:NL)/VOL(IBM) ENDDO @@ -220,6 +229,7 @@ SIGF1(:,:,IC)=0.0 CHI1(:,:,IC)=0.0 SCAT1(:,:,:,:,IC)=0.0 + HFACT1(:,:,IC)=0.0 DO IL=1,NL,2 FHETXM(:,:,IL,IC)=1.0 FHETXP(:,:,IL,IC)=1.0 @@ -278,6 +288,10 @@ 1 VOL(IBM2)*FLX(IBM2,JGR,1)*SCAT(IBM2,IGR,JGR,IL) ENDDO ENDDO + IF(IH.EQ.1) THEN + HFACT1(IBM,IGR,IC)=HFACT1(IBM,IGR,IC)+VOL(IBM2)* + 1 FLX(IBM2,IGR,1)*HFACT(IBM2,IGR) + ENDIF ENDDO ENDDO DO IBM=1,NMIX1 @@ -295,6 +309,9 @@ 1 FLX1(IBM,JGR,IC) ENDDO ENDDO + IF(IH.EQ.1) THEN + HFACT1(IBM,IGR,IC)=HFACT1(IBM,IGR,IC)/FLX1(IBM,IGR,IC) + ENDIF ENDDO DO IGR=1,NG FLX1(IBM,IGR,IC)=FLX1(IBM,IGR,IC)/VOL1(IBM,IC) @@ -309,8 +326,8 @@ CALL LCMLEN(IPMAC2(IC),'HADF',NTYPE,ITYLCM) IF(NTYPE/2.NE.1) CALL XABORT('BREMAC: NTYPE=1 EXPECTED.') CALL LCMGTC(IPMAC2(IC),'HADF',8,HADF) - CALL LCMLEN(IPMAC2(IC),HADF,ILONG,ITYLCM) - IF(ILONG.NE.NMIX1*NG) CALL XABORT('BREMAC: ADF OVERFLOW.') + CALL LCMLEN(IPMAC2(IC),HADF,ILCMLN,ITYLCM) + IF(ILCMLN.NE.NMIX1*NG) CALL XABORT('BREMAC: ADF OVERFLOW.') CALL LCMGET(IPMAC2(IC),HADF,ADF1(1,1,IC)) ENDIF *---- @@ -332,6 +349,7 @@ WRITE(6,20) 'DC1',DC1(:,IGR,IC) WRITE(6,20) 'CHI1',CHI1(:,IGR,IC) WRITE(6,20) 'SIGF1',SIGF1(:,IGR,IC) + IF(IH.EQ.1) WRITE(6,20) 'H-FACTOR',HFACT1(:,IGR,IC) DO JGR=1,NG IF(IGR.EQ.JGR) THEN WRITE(6,20) 'INSCAT1-P0',SCAT1(:,IGR,IGR,1,IC) @@ -360,8 +378,8 @@ *---- * SCRATCH STORAGE DEALLOCATION *---- - DEALLOCATE(WORK,IPOS,NJJ,IJJ,DCOU,SFIS1,SFIS,IMIX2,SCAT,SIGF,CHI, - 1 DC,TOT,FLX,VOL) + DEALLOCATE(WORK,IPOS,NJJ,IJJ,DCOU,SFIS1,SFIS,IMIX2,HFACT,SCAT, + 1 SIGF,CHI,DC,TOT,FLX,VOL) RETURN * 10 FORMAT(1X,A12,10I13/(12X,10I13)) diff --git a/Dragon/src/BRENEM.f b/Dragon/src/BRENEM.f index 862ea80..defd511 100644 --- a/Dragon/src/BRENEM.f +++ b/Dragon/src/BRENEM.f @@ -1,7 +1,7 @@ *DECK BRENEM - SUBROUTINE BRENEM(IPMAC1,NG,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH, - 1 ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,JXM,JXP,FHETXM, - 2 FHETXP,ADF1,NGET,ADFREF,IPRINT) + SUBROUTINE BRENEM(IPMAC1,NG,LX1,NMIX1,ITRIAL,IMIX,ICODE,ISPH,IH, + 1 ZKEFF,B2,ENER,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1,SCAT1,HFACT1,JXM, + 2 JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IPRINT) * *----------------------------------------------------------------------- * @@ -37,6 +37,7 @@ * CHI1 fission spectra. * SIGF1 nu*fission cross sections. * SCAT1 scattering P0 cross sections. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * JXP right boundary currents. * FHETXM left boundary fluxes. @@ -59,8 +60,8 @@ 1 IPRINT REAL ZKEFF,B2,ENER(NG+1),VOL1(NMIX1),FLX1(NMIX1,NG),DC1(NMIX1,NG), 1 TOT1(NMIX1,NG),CHI1(NMIX1,NG),SIGF1(NMIX1,NG), - 2 SCAT1(NMIX1,NG,NG),JXM(NMIX1,NG),JXP(NMIX1,NG),FHETXM(NMIX1,NG), - 3 FHETXP(NMIX1,NG),ADF1(NMIX1,NG),ADFREF(NG) + 2 SCAT1(NMIX1,NG,NG),HFACT1(NMIX1,NG),JXM(NMIX1,NG),JXP(NMIX1,NG), + 3 FHETXM(NMIX1,NG),FHETXP(NMIX1,NG),ADF1(NMIX1,NG),ADFREF(NG) *---- * LOCAL VARIABLES *---- @@ -241,6 +242,9 @@ DO JGR=1,NG SCAT1(IBM,IGR,JGR)=SCAT1(IBM,IGR,JGR)/FDXM(IBM,JGR) ENDDO + IF(IH.EQ.1) THEN + HFACT1(IBM,IGR)=HFACT1(IBM,IGR)/FDXM(IBM,IGR) + ENDIF ENDDO ENDDO IF(ICODE(2).NE.0) THEN @@ -347,6 +351,7 @@ CALL LCMPUT(KPMAC1,'NJJS00',NMIX1,1,NJJ) CALL LCMPUT(KPMAC1,'IJJS00',NMIX1,1,IJJ) CALL LCMPUT(KPMAC1,'IPOS00',NMIX1,1,IPOS) + IF(IH.EQ.1) CALL LCMPUT(KPMAC1,'H-FACTOR',NMIX1,2,HFACT1(:,IGR)) ENDDO *---- * SCRATCH STORAGE DEALLOCATION diff --git a/Dragon/src/BRERT.f b/Dragon/src/BRERT.f index 19afde9..91e2b8b 100644 --- a/Dragon/src/BRERT.f +++ b/Dragon/src/BRERT.f @@ -1,7 +1,7 @@ *DECK BRERT SUBROUTINE BRERT(IPMAC1,IELEM,ICOL,NG,NL,LX1,NMIX1,IMIX,ICODE, - 1 ISPH,IDIFF,ZKEFF,B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1, - 2 SCAT1,JXM,JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IMPX) + 1 ISPH,IH,IDIFF,ZKEFF,B2,ENER,XXX1,VOL1,FLX1,DC1,TOT1,CHI1,SIGF1, + 2 SCAT1,HFACT1,JXM,JXP,FHETXM,FHETXP,ADF1,NGET,ADFREF,IMPX) * *----------------------------------------------------------------------- * @@ -30,6 +30,7 @@ * IMIX mix index of each node. * ICODE physical albedo index on each side of the domain. * ISPH SPH flag (=0: use discontinuity factors; =1: use SPH factors). +* IH H-FACTOR flag (=0: not used; =1: recovered). * IDIFF PN calculation option (=0: diffusion theory; =1: SPN theory * with 'NTOT1'; =2: SPN theory with 1/(3*D)). * ZKEFF effective multiplication factor. @@ -43,6 +44,7 @@ * CHI1 fission spectra. * SIGF1 nu*fission cross sections. * SCAT1 scattering P0 cross sections. +* HFACT1 H-FACTOR values. * JXM left boundary currents. * JXP right boundary currents. * FHETXM left boundary fluxes. @@ -61,12 +63,13 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC1 - INTEGER IELEM,ICOL,NG,NL,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,IDIFF, - 1 NGET,IMPX + INTEGER IELEM,ICOL,NG,NL,LX1,NMIX1,IMIX(LX1),ICODE(2),ISPH,IH, + 1 IDIFF,NGET,IMPX REAL ZKEFF,B2,ENER(NG+1),XXX1(LX1+1),VOL1(NMIX1),FLX1(NMIX1,NG), 1 DC1(NMIX1,NG),TOT1(NMIX1,NG,NL),CHI1(NMIX1,NG),SIGF1(NMIX1,NG), - 2 SCAT1(NMIX1,NG,NG,NL),JXM(NMIX1,NG),JXP(NMIX1,NG), - 3 FHETXM(NMIX1,NG,NL),FHETXP(NMIX1,NG,NL),ADF1(NMIX1,NG),ADFREF(NG) + 2 SCAT1(NMIX1,NG,NG,NL),HFACT1(NMIX1,NG),JXM(NMIX1,NG), + 3 JXP(NMIX1,NG),FHETXM(NMIX1,NG,NL),FHETXP(NMIX1,NG,NL), + 4 ADF1(NMIX1,NG),ADFREF(NG) *---- * LOCAL VARIABLES *---- @@ -298,6 +301,9 @@ SCAT1(IBM,IGR,JGR,IL)=SCAT1(IBM,IGR,JGR,IL)*FDXM(IBM,IGR) ENDDO ENDDO + IF(IH.EQ.1) THEN + HFACT1(IBM,IGR)=HFACT1(IBM,IGR)/FDXM(IBM,IGR) + ENDIF ENDDO ENDDO IF(ICODE(2).NE.0) THEN @@ -409,6 +415,7 @@ CALL LCMPUT(KPMAC1,'IJJS'//CM,NMIX1,1,IJJ) CALL LCMPUT(KPMAC1,'IPOS'//CM,NMIX1,1,IPOS) ENDDO + IF(IH.EQ.1) CALL LCMPUT(KPMAC1,'H-FACTOR',NMIX1,2,HFACT1(:,IGR)) ENDDO *---- * SCRATCH STORAGE DEALLOCATION diff --git a/Dragon/src/CPOLGX.f b/Dragon/src/CPOLGX.f index ac5e44b..db9bf1e 100644 --- a/Dragon/src/CPOLGX.f +++ b/Dragon/src/CPOLGX.f @@ -47,7 +47,7 @@ * SUBROUTINE ARGUMENTS *---- INTEGER NDPROC - PARAMETER (NDPROC=20) + PARAMETER (NDPROC=21) TYPE(C_PTR) IPLIB INTEGER IGS,IPRINT,IORD,NGROUP,INDPRO(NDPROC), > ITYPRO(NDPROC) @@ -59,22 +59,24 @@ *---- INTEGER IOUT PARAMETER (IOUT=6) - CHARACTER NAMDXS(NDPROC)*6,NORD*6,TEXT6*6,TEXT12*12,NAMT*12 + CHARACTER NAMDXS(NDPROC)*8,NORD*4,TEXT8*8,TEXT12*12,NAMT*12 INTEGER IODIV,LONG,ITYP,IXSR,IXSTN,IG,JG SAVE NAMDXS - DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', - > 'NU ','NG ','NHEAT ','N2N ','N3N ', - > 'N4N ','NP ','NA ','GOLD ','ABS ', - > 'NWT0 ','STRD ','STRD X','STRD Y','STRD Z'/ + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF ','NFTOT ', + > 'CHI ','NU ','NG ','NHEAT ', + > 'N2N ','N3N ','N4N ','NP ', + > 'NA ','GOLD ','ABS ','NWT0 ', + > 'STRD ','STRD X ','STRD Y ','STRD Z ', + > 'H-FACTOR'/ IODIV=0 IF(IORD.EQ.1) THEN - NORD=' ' + NORD=' ' IODIV=1 ELSE IF(IORD.EQ.2) THEN - NORD=' LIN' + NORD=' LIN' IODIV=2 ELSE IF(IORD.EQ.3) THEN - NORD=' QUA' + NORD=' QUA' IODIV=4 ENDIF *---- @@ -106,8 +108,8 @@ *---- IF(IGS.EQ.1) THEN DO 100 IXSR=1,NDPROC - TEXT6=NAMDXS(IXSR) - IF(IXSR.EQ.1) TEXT6='TOTAL' + TEXT8=NAMDXS(IXSR) + IF(IXSR.EQ.1) TEXT8='TOTAL' IF(INDPRO(IXSR).EQ.1) THEN IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) *---- @@ -124,7 +126,7 @@ 110 CONTINUE 115 CONTINUE IF((IXSTN.NE.0).OR.(IXSR.EQ.2)) THEN - CALL LCMPUT(IPLIB,TEXT6//NORD,NGROUP,2,XSREC(1,IXSR)) + CALL LCMPUT(IPLIB,TEXT8//NORD,NGROUP,2,XSREC(1,IXSR)) ENDIF ENDIF 100 CONTINUE @@ -136,8 +138,8 @@ *---- IF(IGS.EQ.-1) THEN DO 200 IXSR=1,NDPROC - TEXT6=NAMDXS(IXSR) - IF(IXSR.EQ.1) TEXT6='NTOT0' + TEXT8=NAMDXS(IXSR) + IF(IXSR.EQ.1) TEXT8='NTOT0' IF(INDPRO(IXSR).EQ.1) THEN IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) *---- @@ -145,11 +147,11 @@ * INITIALIZE TO 0.0 IF IXSTN = 0 *---- IF(IXSTN.EQ.1) THEN - CALL LCMLEN(IPLIB,TEXT6//NORD,LONG,ITYP) + CALL LCMLEN(IPLIB,TEXT8//NORD,LONG,ITYP) IF(LONG .EQ. 0) THEN XSREC(:NGROUP,IXSR)=0.0 ELSE - CALL LCMGET(IPLIB,TEXT6//NORD,XSREC(1,IXSR)) + CALL LCMGET(IPLIB,TEXT8//NORD,XSREC(1,IXSR)) ENDIF ELSE XSREC(:NGROUP,IXSR)=0.0 diff --git a/Dragon/src/EDIACT.f b/Dragon/src/EDIACT.f index f45201a..4d824a6 100644 --- a/Dragon/src/EDIACT.f +++ b/Dragon/src/EDIACT.f @@ -2,7 +2,7 @@ SUBROUTINE EDIACT(IPEDIT,IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NL, > NBISO,NED,VOLUME,MIX,IGCOND,IMERGE,FLUXES, > ITRANC,ISONAM,IPISO,HVECT,CURNAM,NACTI,IACTI, - > EMEVF2,EMEVG2) + > EMEVF2) * *----------------------------------------------------------------------- * @@ -43,7 +43,6 @@ * NACTI number of mixture with WIMS activation edit. * IACTI mixtures with activation edits. * EMEVF2 fission production energy. -* EMEVG2 capture production energy. * *----------------------------------------------------------------------- * @@ -56,8 +55,7 @@ INTEGER IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NL,NBISO,NED, > MIX(NBISO),IGCOND(NGCOND),IMERGE(NREGIO),ITRANC, > ISONAM(3,NBISO),NACTI,IACTI(NACTI) - REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP), - > EMEVF2(NBISO),EMEVG2(NBISO) + REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP),EMEVF2(NBISO) *---- * LOCAL VARIABLES *---- @@ -65,7 +63,7 @@ TYPE(C_PTR) KPLIB INTEGER IPAR(NSTATE) CHARACTER CACTI*12,CM*2,HMAKE(100)*8,HNEW*12,TEXT12*12,HSMG*131 - LOGICAL LMEVF,LMEVG,LLCM + LOGICAL LMEVF,LLCM DOUBLE PRECISION DVOL,DFLI,DTMP,QEN,ERR INTEGER, ALLOCATABLE, DIMENSION(:) :: ISOMIX INTEGER, ALLOCATABLE, DIMENSION(:,:) :: KCJJ,HNISO @@ -162,10 +160,6 @@ CALL LCMLEN(KPLIB,'MEVF',LENGTH,ITYLCM) IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVF',EVF) LMEVF=(LENGTH.EQ.1).OR.(EMEVF2(ISO).GT.0.0) - IF(EMEVG2(ISO).GT.0.0) EVG=EMEVG2(ISO) - CALL LCMLEN(KPLIB,'MEVG',LENGTH,ITYLCM) - IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVG',EVG) - LMEVG=(LENGTH.EQ.1).OR.(EMEVG2(ISO).GT.0.0) DO 111 IL=1,NL WRITE (CM,'(I2.2)') IL-1 CALL LCMLEN(KPLIB,'SIGS'//CM,LENGTH,ITYLCM) @@ -353,7 +347,6 @@ CALL LCMSIX(IPEDIT,HNEW,1) CALL LCMPUT(IPEDIT,'AWR',1,2,AWR) IF(LMEVF) CALL LCMPUT(IPEDIT,'MEVF',1,2,EVF) - IF(LMEVG) CALL LCMPUT(IPEDIT,'MEVG',1,2,EVG) DO 220 J=1,MAXH IF(HMAKE(J).NE.' ') THEN DO 221 IGCD=1,NGCOND diff --git a/Dragon/src/EDIDRV.f b/Dragon/src/EDIDRV.f index bc48d6f..1f39079 100644 --- a/Dragon/src/EDIDRV.f +++ b/Dragon/src/EDIDRV.f @@ -136,7 +136,7 @@ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: FIPI,FIFP INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KEYANI REAL, ALLOCATABLE, DIMENSION(:) :: WORKF,WORKA,VOLME,WLETY,WE, - > COURI,TAUXT,SIGT,SIGS,SCATS,FLINT,SCATD,DEN,TN,EMEVF,EMEVG,RER, + > COURI,TAUXT,SIGT,SIGS,SCATS,FLINT,SCATD,DEN,TN,EMEVF,RER, > DECAY,RRD,FIYI,ENERG,NAWR,NDEN,NTMP,NVOL,SNEJ,WORK1,WORK2 REAL, ALLOCATABLE, DIMENSION(:,:) :: ADF REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLUXC,FADJC,FLUXES,AFLUXE, @@ -517,9 +517,8 @@ *---- * EVALUATE H-FACTOR IF REQUIRED FOR THE EDITION MACROLIB *---- - ALLOCATE(EMEVF(NBISO),EMEVG(NBISO)) + ALLOCATE(EMEVF(NBISO)) EMEVF(:NBISO)=0.0 - EMEVG(:NBISO)=0.0 IF((NSAVES.GE.2).AND.(IHF.NE.0)) THEN CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILLCM,ITLCM) IF(ILLCM.NE.0) THEN @@ -534,10 +533,9 @@ CALL LCMGET(IPLIB,'DEPLETE-ENER',RER) CALL LCMSIX(IPLIB,' ',2) * - CALL EDIHFC(IPEDIT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL, - > NREAC,MATCOD,VOLUME,INADPL,ISONA,ISONR,IPISO, - > MIX,FLUXES(1,1,1),DEN,IGCOND,IMERGE,RER,EMEVF, - > EMEVG,VOLME,IPRINT) + CALL EDIHFC(IPEDIT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO, + > MATCOD,VOLUME,ISONA,IPISO,MIX,FLUXES(1,1,1), + > DEN,IGCOND,IMERGE,VOLME,IPRINT,EMEVF) * DEALLOCATE(RER,INADPL) CALL LCMSIX(IPEDIT,' ',2) @@ -605,8 +603,8 @@ > IPRINT,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI, > NDFP,ILEAKS,ILUPS,NW,MATCOD,VOLUME,KEYFLX,CURNAM, > IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN, - > ITYPE,IDEPL,LSISO,EMEVF,EMEVG,DECAY,YIELD,FIPI, - > FIFP,PYIELD,ITRANC,LISO,NMLEAK) + > ITYPE,IDEPL,LSISO,EMEVF,DECAY,YIELD,FIPI,FIFP, + > PYIELD,ITRANC,LISO,NMLEAK) *---- * ISOTX FILE PROCESSING *---- @@ -631,13 +629,10 @@ KPEDIT=JPISO(ISO) CALL LCMGET(KPEDIT,'AWR',AWR) EMEVF2=0.0 - EMEVG2=0.0 CALL LCMLEN(KPEDIT,'MEVF',ILENF,ITYLCM) - CALL LCMLEN(KPEDIT,'MEVG',ILENG,ITYLCM) IF(ILENF.EQ.1) CALL LCMGET(KPEDIT,'MEVF',EMEVF2) - IF(ILENG.EQ.1) CALL LCMGET(KPEDIT,'MEVG',EMEVG2) NAWR(ISO)=AWR - SNEJ(ISO)=EMEVF2+EMEVG2 + SNEJ(ISO)=EMEVF2 ENDDO * NBIXS=IXEDI @@ -681,8 +676,7 @@ > NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS, > ILUPS,NW,MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE, > FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN,ITYPE,LSISO,EMEVF, - > EMEVG,DECAY,YIELD,FIPI,FIFP,PYIELD,ITRANC,LISO, - > NMLEAK) + > DECAY,YIELD,FIPI,FIFP,PYIELD,ITRANC,LISO,NMLEAK) ENDIF *---- * EDIT MICROSCOPIC ACTIVATION XS @@ -690,7 +684,7 @@ IF(NACTI.GT.0) THEN CALL EDIACT(IPEDIT,IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NL,NBISO, > NED,VOLUME,MIX,IGCOND,IMERGE,FLUXES(1,1,1),ITRANC, - > ISONA,IPISO,HVECT,CURNAM,NACTI,IACTI,EMEVF,EMEVG) + > ISONA,IPISO,HVECT,CURNAM,NACTI,IACTI,EMEVF) ENDIF *---- * STATISTICS AND DELTA SIGMAS @@ -709,8 +703,7 @@ ENDIF * IF(ALLOCATED(PYIELD)) DEALLOCATE(PYIELD,YIELD,FIFP,FIPI) - DEALLOCATE(DECAY) - DEALLOCATE(EMEVG,EMEVF) + DEALLOCATE(DECAY,EMEVF) DEALLOCATE(SCATS,SIGS,FADJC,FLUXC,TAUXT) DEALLOCATE(WE,WLETY,VOLME) IF(HSIGN.EQ.'L_LIBRARY') THEN diff --git a/Dragon/src/EDIHFC.f b/Dragon/src/EDIHFC.f index 7cdc561..46f53bd 100644 --- a/Dragon/src/EDIHFC.f +++ b/Dragon/src/EDIHFC.f @@ -1,14 +1,12 @@ *DECK EDIHFC SUBROUTINE EDIHFC(IPEDIT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO, - > NDEPL,NREAC,MATCOD,VOLUME,INADPL,ISONAM,ISONRF, - > IPISO,MIX,FLUXES,DEN,IGCOND,IMERGE,RER,EMEVF2, - > EMEVG2,VOLME,IPRINT) + > MATCOD,VOLUME,ISONAM,IPISO,MIX,FLUXES,DEN, + > IGCOND,IMERGE,VOLME,IPRINT,EMEVF2) * *----------------------------------------------------------------------- * *Purpose: -* Evaluate H-factors using information recovered from the reference -* internal library and store them in the edition macrolib. +* Recover H-factors and normalize the flux. * *Copyright: * Copyright (C) 2002 Ecole Polytechnique de Montreal @@ -26,26 +24,20 @@ * NREGIO number of regions. * NMERGE number of merged regions. * NBISO number of isotopes. -* NDEPL number of depleting isotopes. -* NREAC number of depletion reactions. * MATCOD material per region. * VOLUME volume of region. -* INADPL name of depleting isotopes. * ISONAM isotopes names. -* ISONRF library name of isotopes. * IPISO pointer array towards microlib isotopes. * MIX mixture associated with isotopes. * FLUXES multigroup fluxes. * DEN isotope density. * IGCOND limits of condensed groups. * IMERGE index of merged region. -* RER fission and capture production energy (MeV/reaction). * VOLME merged volume. * IPRINT print level. * *Parameters: output -* EMEVF2 fission production energy by isotope. -* EMEVG2 capture production energy by isotope. +* EMEVF2 equivalent fission production energy by isotope. * *----------------------------------------------------------------------- * @@ -55,113 +47,77 @@ *---- TYPE(C_PTR) IPEDIT,IPISO(NBISO) INTEGER IUNOUT - INTEGER NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL,NREAC, - > MATCOD(NREGIO),INADPL(3,NDEPL),ISONAM(3,NBISO), - > ISONRF(3,NBISO),MIX(NBISO),IGCOND(NGCOND), + INTEGER NGROUP,NGCOND,NREGIO,NMERGE,NBISO,MATCOD(NREGIO), + > ISONAM(3,NBISO),MIX(NBISO),IGCOND(NGCOND), > IMERGE(NREGIO) REAL VOLUME(NREGIO),FLUXES(NREGIO,NGROUP),DEN(NBISO), - > RER(NREAC,NDEPL),EMEVF2(NBISO),EMEVG2(NBISO) - REAL VOLME(NMERGE) + > EMEVF2(NBISO),VOLME(NMERGE) INTEGER IPRINT - DOUBLE PRECISION TOTPOW,POWF,POWC,POWT - INTEGER, ALLOCATABLE, DIMENSION(:) :: INDX + DOUBLE PRECISION TOTPOW,POWF REAL, ALLOCATABLE, DIMENSION(:) :: SIG,HFACT - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: FLXMER - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: WORK + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: FLXMER,WORK *---- * LOCAL VARIABLES *---- TYPE(C_PTR) JPEDIT,KPEDIT,KPLIB PARAMETER (IUNOUT=6) - INTEGER IGAR(3) - CHARACTER HNISOR*12,TEXT12*12,HSMG*131 - LOGICAL L1,L2 - DOUBLE PRECISION GAR,CONV,XDRCST + CHARACTER HSMG*131 + LOGICAL LH + DOUBLE PRECISION GAR,CONV,XDRCST,Z1,Z2 *---- * SCRATCH STORAGE ALLOCATION * SIG fission/capture cross sections. * HFACT H-factor in a macrogroup. * FLXMER merged and condensed flux. * WORK H-factors. -* INDX depleting isotope index. *---- - ALLOCATE(INDX(NBISO)) ALLOCATE(SIG(NGROUP),HFACT(NMERGE)) - ALLOCATE(FLXMER(NMERGE,NGCOND),WORK(NMERGE,NGCOND,3)) -*---- -* COMPUTE THE DEPLETING ISOTOPE INDEX -*---- - DO 20 ISO=1,NBISO - WRITE(HNISOR,'(3A4)') (ISONRF(I0,ISO),I0=1,3) - I1=INDEX(HNISOR,'_') - IF(I1.EQ.0) THEN - TEXT12=HNISOR - ELSE - TEXT12=HNISOR(:I1-1) - ENDIF - READ(TEXT12,'(3A4)') (IGAR(I0),I0=1,3) - DO 10 IDP=1,NDEPL - L1=((ISONRF(1,ISO).EQ.INADPL(1,IDP)).AND. - 1 (ISONRF(2,ISO).EQ.INADPL(2,IDP)).AND. - 2 (ISONRF(3,ISO).EQ.INADPL(3,IDP))) - L2=((IGAR(1).EQ.INADPL(1,IDP)).AND. - 1 (IGAR(2).EQ.INADPL(2,IDP)).AND. - 2 (IGAR(3).EQ.INADPL(3,IDP))) - IF(L1.OR.L2) THEN - INDX(ISO)=IDP - GO TO 20 - ENDIF - 10 CONTINUE - INDX(ISO)=0 - 20 CONTINUE + ALLOCATE(FLXMER(NMERGE,NGCOND),WORK(NMERGE,NGCOND)) *---- * COMPUTE H-FACTOR *---- CONV=1.0D6 ! convert MeV to eV - IZFISS=0 FLXMER(:NMERGE,:NGCOND)=0.0D0 - WORK(:NMERGE,:NGCOND,:3)=0.0D0 + WORK(:NMERGE,:NGCOND)=0.0D0 + LH=.FALSE. DO 160 ISO=1,NBISO - IDPL=INDX(ISO) - IF(IDPL.EQ.0) GO TO 160 KPLIB=IPISO(ISO) ! set ISO-th isotope IF(.NOT.C_ASSOCIATED(KPLIB)) THEN WRITE(HSMG,'(17HEDIHFC: ISOTOPE '',3A4,16H'' IS NOT AVAILAB, > 19HLE IN THE MICROLIB.)') (ISONAM(I0,ISO),I0=1,3) CALL XABORT(HSMG) ENDIF + Z1=0.0D0 + Z2=0.0D0 + EMEVF2(ISO)=0.0 *---- * RECOVER H-FACTOR INFORMATION IF AVAILABLE *---- CALL LCMLEN(KPLIB,'H-FACTOR',ILLCM,ITLCM) - IF(ILLCM.EQ.NGROUP) THEN - IZFISS=IZFISS+1 - CALL LCMGET(KPLIB,'H-FACTOR',SIG) - DO 90 IREG=1,NREGIO - IMR=IMERGE(IREG) - IF((IMR.GT.0).AND.(MATCOD(IREG).EQ.MIX(ISO))) THEN - IGRFIN=0 - DO 80 IGC=1,NGCOND - IGRDEB=IGRFIN+1 - IGRFIN=IGCOND(IGC) - GAR=0.0D0 - DO 70 IGR=IGRDEB,IGRFIN - GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)* - > SIG(IGR) - 70 CONTINUE - WORK(IMR,IGC,1)=WORK(IMR,IGC,1)+GAR - 80 CONTINUE - ENDIF - 90 CONTINUE - GO TO 165 - ENDIF + IF(ILLCM.EQ.0) GO TO 160 + LH=.TRUE. + CALL LCMGET(KPLIB,'H-FACTOR',SIG) + DO 90 IREG=1,NREGIO + IMR=IMERGE(IREG) + IF((IMR.GT.0).AND.(MATCOD(IREG).EQ.MIX(ISO))) THEN + IGRFIN=0 + DO 80 IGC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGC) + GAR=0.0D0 + DO 70 IGR=IGRDEB,IGRFIN + GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)*SIG(IGR) + 70 CONTINUE + WORK(IMR,IGC)=WORK(IMR,IGC)+GAR + Z1=Z1+GAR + 80 CONTINUE + ENDIF + 90 CONTINUE *---- * COMPUTE FISSION ENERGY *---- CALL LCMLEN(KPLIB,'NFTOT',ILLCM,ITLCM) IF(ILLCM.EQ.NGROUP) THEN - IZFISS=IZFISS+1 - EMEVF2(ISO)=RER(2,IDPL) CALL LCMGET(KPLIB,'NFTOT',SIG) DO 120 IREG=1,NREGIO IMR=IMERGE(IREG) @@ -170,51 +126,23 @@ DO 110 IGC=1,NGCOND IGRDEB=IGRFIN+1 IGRFIN=IGCOND(IGC) - GAR=0.0D0 DO 100 IGR=IGRDEB,IGRFIN - GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)* - > SIG(IGR) + Z2=Z2+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)*SIG(IGR) 100 CONTINUE - WORK(IMR,IGC,1)=WORK(IMR,IGC,1)+GAR*RER(2,IDPL)*CONV 110 CONTINUE ENDIF 120 CONTINUE - ENDIF -*---- -* COMPUTE CAPTURE ENERGY -*---- - CALL LCMLEN(KPLIB,'NG',ILLCM,ITLCM) - IF(ILLCM.EQ.NGROUP) THEN - IZFISS=IZFISS+1 - EMEVG2(ISO)=RER(3,IDPL) - CALL LCMGET(KPLIB,'NG',SIG) - DO 150 IREG=1,NREGIO - IMR=IMERGE(IREG) - IF((IMR.GT.0).AND.(MATCOD(IREG).EQ.MIX(ISO))) THEN - IGRFIN=0 - DO 140 IGC=1,NGCOND - IGRDEB=IGRFIN+1 - IGRFIN=IGCOND(IGC) - GAR=0.0D0 - DO 130 IGR=IGRDEB,IGRFIN - GAR=GAR+FLUXES(IREG,IGR)*DEN(ISO)*VOLUME(IREG)* - > SIG(IGR) - 130 CONTINUE - WORK(IMR,IGC,2)=WORK(IMR,IGC,2)+GAR*RER(3,IDPL)*CONV - 140 CONTINUE - ENDIF - 150 CONTINUE + IF(Z2.NE.0.0) EMEVF2(ISO)=REAL(Z1/Z2) ENDIF 160 CONTINUE *---- * Normalize total power to 1 W * Print fission, capture and total power density *---- - 165 TOTPOW=0.0D0 + TOTPOW=0.0D0 DO IGC=1,NGCOND DO IMR=1,NMERGE - WORK(IMR,IGC,3)=WORK(IMR,IGC,1)+WORK(IMR,IGC,2) - TOTPOW=TOTPOW+WORK(IMR,IGC,3)*XDRCST('eV','J') + TOTPOW=TOTPOW+WORK(IMR,IGC)*XDRCST('eV','J') ENDDO ENDDO IF(TOTPOW.GT.0.0D0) THEN @@ -222,18 +150,12 @@ WRITE(IUNOUT,6000) DO IMR=1,NMERGE POWF=0.0D0 - POWC=0.0D0 - POWT=0.0D0 DO IGC=1,NGCOND - POWF=POWF+WORK(IMR,IGC,1) - POWC=POWC+WORK(IMR,IGC,2) - POWT=POWT+WORK(IMR,IGC,3) + POWF=POWF+WORK(IMR,IGC) ENDDO IF(VOLME(IMR).NE.0.0) THEN POWF=POWF/(TOTPOW*VOLME(IMR)) - POWC=POWC/(TOTPOW*VOLME(IMR)) - POWT=POWT/(TOTPOW*VOLME(IMR)) - WRITE(IUNOUT,6001) IMR,VOLME(IMR),POWF,POWC,POWT + WRITE(IUNOUT,6001) IMR,VOLME(IMR),POWF ENDIF ENDDO ENDIF @@ -241,7 +163,7 @@ *---- * COMPUTE THE HOMOGENIZED/CONDENSED FLUX *---- - IF(IZFISS.NE.0) THEN + IF(LH) THEN DO 190 IREG=1,NREGIO IMR=IMERGE(IREG) IF(IMR.GT.0) THEN @@ -260,36 +182,34 @@ DO 210 IGC=1,NGCOND DO 200 IMR=1,NMERGE IF(FLXMER(IMR,IGC).GT.0.0) THEN - WORK(IMR,IGC,3)=WORK(IMR,IGC,3)/FLXMER(IMR,IGC) + WORK(IMR,IGC)=WORK(IMR,IGC)/FLXMER(IMR,IGC) ENDIF 200 CONTINUE 210 CONTINUE - ENDIF *---- * SAVE ON LCM *---- - CALL LCMSIX(IPEDIT,'MACROLIB',1) - JPEDIT=LCMLID(IPEDIT,'GROUP',NGCOND) - DO 230 IGC=1,NGCOND - DO 220 IMR=1,NMERGE - HFACT(IMR)=REAL(WORK(IMR,IGC,3)) - 220 CONTINUE - KPEDIT=LCMDIL(JPEDIT,IGC) - CALL LCMPUT(KPEDIT,'H-FACTOR',NMERGE,2,HFACT) - 230 CONTINUE - CALL LCMSIX(IPEDIT,' ',2) + CALL LCMSIX(IPEDIT,'MACROLIB',1) + JPEDIT=LCMLID(IPEDIT,'GROUP',NGCOND) + DO 230 IGC=1,NGCOND + DO 220 IMR=1,NMERGE + HFACT(IMR)=REAL(WORK(IMR,IGC)) + 220 CONTINUE + KPEDIT=LCMDIL(JPEDIT,IGC) + CALL LCMPUT(KPEDIT,'H-FACTOR',NMERGE,2,HFACT) + 230 CONTINUE + CALL LCMSIX(IPEDIT,' ',2) + ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(WORK,FLXMER) DEALLOCATE(HFACT,SIG) - DEALLOCATE(INDX) RETURN *---- * FORMAT *---- 6000 FORMAT(/' EDIHFC: POWER DENSITY (W/cc) NORMALIZED TO 1 W TOTAL ', - > 'POWER '/' REGION',6X,'VOLUME',7X,'FISSION',7X,'CAPTURE',9X, - > 'TOTAL') - 6001 FORMAT(1X,I4,1P,4E14.5) + > 'POWER '/' REGION',6X,'VOLUME',7X,'FISSION') + 6001 FORMAT(1X,I4,1P,2E14.5) END diff --git a/Dragon/src/EDIMIC.f b/Dragon/src/EDIMIC.f index 025d1c4..e284110 100644 --- a/Dragon/src/EDIMIC.f +++ b/Dragon/src/EDIMIC.f @@ -3,8 +3,8 @@ 1 NDEPL,ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRINT, 2 NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW, 3 MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK, - 4 EIGINF,B2,DEN,ITYPE,IEVOL,LSISO,EMEVF,EMEVG,DECAY,YIELD,FIPI, - 5 FIFP,PYIELD,ITRANC,LISO,NMLEAK) + 4 EIGINF,B2,DEN,ITYPE,IEVOL,LSISO,EMEVF,DECAY,YIELD,FIPI,FIFP, + 5 PYIELD,ITRANC,LISO,NMLEAK) * *----------------------------------------------------------------------- * @@ -78,7 +78,6 @@ * 1 is used to force an isotope to be non-depleting. * LSISO flag for isotopes saved. * EMEVF fission production energy. -* EMEVG capture production energy. * DECAY radioactive decay constant. * YIELD group-ordered condensed fission product yield. * FIPI fissile isotope index assigned to each microlib isotope. @@ -104,7 +103,7 @@ 5 FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE),ITRANC,NMLEAK REAL TN(NBISO),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1), 1 AFLUXE(NREGIO,NGROUP,NW+1),EIGENK,EIGINF,B2(4), - 2 DEN(NBISO),EMEVF(NBISO),EMEVG(NBISO),DECAY(NBISO), + 2 DEN(NBISO),EMEVF(NBISO),DECAY(NBISO), 3 YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE) CHARACTER HVECT(NED)*8,HVOUT(NOUT)*8,CURNAM*12 LOGICAL LISO @@ -113,7 +112,7 @@ *---- PARAMETER (NSTATE=40,MAXESP=4) TYPE(C_PTR) JPLIB,KPLIB,JPFLUX,JPEDIT,KPEDIT - LOGICAL LOGIC,LSTRD,LAWR,LMEVF,LMEVG,LDECA,LWD,LONE + LOGICAL LOGIC,LSTRD,LAWR,LMEVF,LDECA,LWD,LONE CHARACTER CM*2,HNEW*12,TEXT8*8,TEXT12*12,HSMG*131,HNAMIS*12 INTEGER IPAR(NSTATE),IESP2(MAXESP+1) REAL B2T(3),EESP(MAXESP+1),EESP2(MAXESP+1) @@ -385,7 +384,6 @@ LAWR=.FALSE. LDECA=.FALSE. LMEVF=.FALSE. - LMEVG=.FALSE. DO 145 IW=1,MIN(NW+1,10) WRITE(HMAKE(IW),'(3HNWT,I1)') IW-1 IF(IADJ.EQ.1) WRITE(HMAKE(1+NW+IW),'(4HNWAT,I1)') IW-1 @@ -434,9 +432,6 @@ CALL LCMLEN(KPLIB,'MEVF',LENGTH,ITYLCM) IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVF',EMEVF(ISO)) LMEVF=(LENGTH.EQ.1).OR.(EMEVF(ISO).GT.0.0) - CALL LCMLEN(KPLIB,'MEVG',LENGTH,ITYLCM) - IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVG',EMEVG(ISO)) - LMEVG=(LENGTH.EQ.1).OR.(EMEVG(ISO).GT.0.0) CALL LCMLEN(KPLIB,'DECAY',LENGTH,ITYLCM) IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'DECAY',DECAY(ISO)) LDECA=(LENGTH.EQ.1).OR.(DECAY(ISO).GT.0.0) @@ -520,23 +515,6 @@ IF(LENGTH.GT.0) THEN CALL LCMGET(KPLIB,'H-FACTOR',GAR(1,5+NED+NL+3*NW)) HMAKE(5+NED+NL+3*NW)='H-FACTOR' - ELSE - IF(LMEVF) THEN - CALL LCMGET(KPLIB,'NFTOT',WORK) - HMAKE(5+NED+NL+3*NW)='H-FACTOR' - DO 190 IGR=1,NGROUP - GAR(IGR,5+NED+NL+3*NW)=GAR(IGR,5+NED+NL+3*NW)+ - 1 WORK(IGR)*EMEVF(ISO)*REAL(CONV) - 190 CONTINUE - ENDIF - IF(LMEVG) THEN - CALL LCMGET(KPLIB,'NG',WORK) - HMAKE(5+NED+NL+3*NW)='H-FACTOR' - DO 195 IGR=1,NGROUP - GAR(IGR,5+NED+NL+3*NW)=GAR(IGR,5+NED+NL+3*NW)+ - 1 WORK(IGR)*EMEVG(ISO)*REAL(CONV) - 195 CONTINUE - ENDIF ENDIF DO 200 IED=1,NED IF(HVECT(IED).EQ.'H-FACTOR') GO TO 200 @@ -811,7 +789,6 @@ CALL LCMPTC(KPEDIT,'ALIAS',12,HNEW) IF(LAWR) CALL LCMPUT(KPEDIT,'AWR',1,2,AWR) IF(LMEVF) CALL LCMPUT(KPEDIT,'MEVF',1,2,EMEVF(ISO)) - IF(LMEVG) CALL LCMPUT(KPEDIT,'MEVG',1,2,EMEVG(ISO)) IF(LDECA) CALL LCMPUT(KPEDIT,'DECAY',1,2,DECAY(ISO)) DO 380 J=1,MAXH IF(HMAKE(J).NE.' ') THEN diff --git a/Dragon/src/EDIRES.f b/Dragon/src/EDIRES.f index b49cf83..72eb11f 100644 --- a/Dragon/src/EDIRES.f +++ b/Dragon/src/EDIRES.f @@ -3,8 +3,8 @@ 1 NDEPL,ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRINT, 2 NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW, 3 MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK, - 4 EIGINF,B2,DEN,ITYPE,LSISO,EMEVF,EMEVG,DECAY,YIELD,FIPI,FIFP, - 5 PYIELD,ITRANC,LISO,NMLEAK) + 4 EIGINF,B2,DEN,ITYPE,LSISO,EMEVF,DECAY,YIELD,FIPI,FIFP,PYIELD, + 5 ITRANC,LISO,NMLEAK) * *----------------------------------------------------------------------- * @@ -76,7 +76,6 @@ * ITYPE type of each isotope. * LSISO flag for isotopes saved. * EMEVF fission production energy. -* EMEVG capture production energy. * DECAY radioactive decay constant. * YIELD group-ordered condensed fission product yield. * FIPI fissile isotope index assigned to each microlib isotope. @@ -100,8 +99,8 @@ 3 IGCOND(NGCOND),IMERGE(NREGIO),ITYPE(NBISO),LSISO(NBISO), 4 FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE),ITRANC,NMLEAK REAL TN(NBISO),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1), - 1 EIGENK,EIGINF,B2(4),DEN(NBISO),EMEVF(NBISO),EMEVG(NBISO), - 2 DECAY(NBISO),YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE) + 1 EIGENK,EIGINF,B2(4),DEN(NBISO),EMEVF(NBISO),DECAY(NBISO), + 2 YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE) CHARACTER HVECT(NED)*8,HVOUT(NOUT)*8,CURNAM*12 LOGICAL LISO *---- @@ -172,8 +171,8 @@ 1 ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRIN2,NGROUP, 2 NGCOND,NBMIX,NREGIO,NMERGE,0,0,ILEAKS,ILUPS,NW,MATCOD,VOLUME, 3 KEYFLX,TEXT12,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN, - 4 ITYPE,IEVOL2,LSIS2,EMEVF,EMEVG,DECAY,YIELD,FIPI,FIFP,PYIELD, - 5 ITRANC,LISO,NMLEAK) + 4 ITYPE,IEVOL2,LSIS2,EMEVF,DECAY,YIELD,FIPI,FIFP,PYIELD,ITRANC, + 5 LISO,NMLEAK) * CALL LCMSIX(IPEDIT,CURNAM,1) CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR) diff --git a/Dragon/src/EPCRMA.f b/Dragon/src/EPCRMA.f index 933683e..9dbcffe 100644 --- a/Dragon/src/EPCRMA.f +++ b/Dragon/src/EPCRMA.f @@ -53,7 +53,7 @@ TYPE(C_PTR) IPMIC INTEGER IPRINT,NGR,NXS,NCV,NMIXT,NIFISS,IMIX,ISOF,ITOTL, > ISCAT - CHARACTER*6 NAMDXS(NXS) + CHARACTER*8 NAMDXS(NXS) REAL DENSI INTEGER ICOV(NGR,NXS) REAL COV(NCV,NXS) diff --git a/Dragon/src/EPCRMS.f b/Dragon/src/EPCRMS.f index 5d8c72f..a2c06ff 100644 --- a/Dragon/src/EPCRMS.f +++ b/Dragon/src/EPCRMS.f @@ -37,7 +37,7 @@ *---- TYPE(C_PTR) IPMIC INTEGER IPRINT,NGR,NXS,NMIXT,NIFISS - CHARACTER*6 NAMDXS(NXS) + CHARACTER*8 NAMDXS(NXS) REAL XSMAC(NGR,NXS,NMIXT,NIFISS) *---- * Local parameters diff --git a/Dragon/src/EPCRMU.f b/Dragon/src/EPCRMU.f index 7021bee..910eab9 100644 --- a/Dragon/src/EPCRMU.f +++ b/Dragon/src/EPCRMU.f @@ -48,7 +48,7 @@ TYPE(C_PTR) IPEPC,IPMIC INTEGER IPRINT,NGR,NIS,NXS,NCV, > NBISO,NMIXT,NIFISS,ITOTL,ISCAT - CHARACTER*6 NAMDXS(NXS) + CHARACTER*8 NAMDXS(NXS) INTEGER NAMISO(3,NIS),NISOU(3,NBISO),ISOMIX(NBISO), > IDVF(2,NIS),IDMF(2,NBISO) *---- @@ -126,11 +126,11 @@ *---- * Get covariance matrices *---- - RECNAM='INDX'//NAMDXS(IXS)//' ' + RECNAM='INDX'//NAMDXS(IXS) CALL LCMLEN(IPEPC,RECNAM,ILCMLN,ILCMTY) IF(ILCMLN .EQ. NGR) THEN CALL LCMGET(IPEPC,RECNAM,ICOV(1,IXS)) - RECNAM=NAMDXS(IXS)//' ' + RECNAM=NAMDXS(IXS)//' ' CALL LCMGET(IPEPC,RECNAM,COV(1,IXS)) *---- * Generate random numbers from normal distribution diff --git a/Dragon/src/EVOBLD.f b/Dragon/src/EVOBLD.f index 46ab32c..3803d63 100644 --- a/Dragon/src/EVOBLD.f +++ b/Dragon/src/EVOBLD.f @@ -1,8 +1,8 @@ *DECK EVOBLD SUBROUTINE EVOBLD(IMPX,INR,IGLOB,NBMIX,NBISO,NCOMB,ISONAM,IPISO, 1 YDPL,VX,MILVO,JM,NVAR,NDFP,NSUPS,NREAC,NPAR,NFISS,XT,EPS1,EPS2, - 2 EXPMAX,H1,ITYPE,IDIRAC,FIT,DELTA,ENERG,KPAR,BPAR,YIELD,IDR,RER, - 3 RRD,AWR,FUELDN,SIG,VPH,VPHV,MIXPWR,VTOTD,IEVOLB,KFISS,KPF) + 2 EXPMAX,H1,ITYPE,IDIRAC,FIT,DELTA,ENERG,KPAR,BPAR,YIELD,IDR,RRD, + 3 AWR,FUELDN,SIG,VPH,VPHV,MIXPWR,VTOTD,IEVOLB,KFISS,KPF) * *----------------------------------------------------------------------- * @@ -76,9 +76,6 @@ * BPAR branching ratio for neutron induced reactions. * YIELD mixture-dependent fission yields. * IDR identifier for each depleting reaction. -* RER energy (Mev) per reaction. If RER(3,J)=0., the fission energy -* includes radiative capture energy. Neutrino energy is -* never included. * RRD sum of radioactive decay constants in 10**-8/s. * AWR mass of the nuclides in unit of neutron mass. * FUELDN fuel initial density and mass. @@ -117,8 +114,8 @@ 4 KPF(NDFP,NBMIX) REAL YDPL(NVAR+1,2,NCOMB),VX(NBMIX),XT(2),EPS1,EPS2,EXPMAX,H1,FIT, 1 DELTA(3),ENERG(NBMIX),BPAR(NPAR,NVAR),YIELD(NFISS,NDFP,NBMIX), - 2 RER(NREAC,NVAR+NSUPS),RRD(NVAR+NSUPS),AWR(NVAR),FUELDN(3), - 3 SIG(NVAR+1,NREAC+1,NBMIX,2),VPH(2),VPHV(NBMIX,2) + 2 RRD(NVAR+NSUPS),AWR(NVAR),FUELDN(3),SIG(NVAR+1,NREAC+1,NBMIX,2), + 3 VPH(2),VPHV(NBMIX,2) DOUBLE PRECISION VTOTD *---- * LOCAL VARIABLES @@ -126,20 +123,12 @@ TYPE(C_PTR) KPLIB CHARACTER TEXT8*8,HSMG*131 DOUBLE PRECISION GAR,GARD,XDRCST,EVJ,FITD,PHI2 - LOGICAL LCOOL,LSIMPL + LOGICAL LCOOL INTEGER, ALLOCATABLE, DIMENSION(:) :: MU1,IMA,LP,CHAIN *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(MU1(NVAR+1),IMA(NVAR+1),LP(NVAR)) -*---- -* CHECK IF ONLY THE HEAVY ISOTOPES ARE PRODUCING ENERGY. IN THIS CASE, -* SOME SIMPLIFICATIONS ARE POSSIBLE -*---- - LSIMPL=.TRUE. - DO 10 IS=1,NVAR - LSIMPL=LSIMPL.AND.(RER(3,IS).EQ.0.0) - 10 CONTINUE * EVJ=XDRCST('eV','J')*1.0E22 LCOOL=(INR.EQ.0) @@ -186,8 +175,8 @@ CALL XABORT(HSMG) ENDIF CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) - IF(((LENGT.GT.0).OR.(RER(3,IS).NE.0.0).OR. - 1 (AWR(IS).GT.210.0)).AND.(LP(IS).EQ.0)) THEN + IF(((LENGT.GT.0).OR.(AWR(IS).GT.210.0)).AND.(LP(IS).EQ.0)) + 1 THEN NVAR2=NVAR2+1 LP(IS)=NVAR2 ENDIF diff --git a/Dragon/src/EVODRV.f b/Dragon/src/EVODRV.f index cb9b40c..cd8b69f 100644 --- a/Dragon/src/EVODRV.f +++ b/Dragon/src/EVODRV.f @@ -113,8 +113,7 @@ INTEGER INDREC,IMPX,NBISO,NGROUP,NBMIX,ISONAM(3,NBISO), 1 ISONRF(3,NBISO),MIX(NBISO),IEVOL(NBISO),ISTYP(NBISO),NDEPL, 2 NSUPS,NREAC,NCOMB,ITYPE,INR,IEXTR,IGLOB,ISAT,IDIRAC,ITIXS, - 3 IFLMAC,IYLMIX,ISAVE,ISET,IDEPL,IPICK,MIXBRN(NBMIX), - 4 MIXPWR(NBMIX) + 3 IFLMAC,IYLMIX,ISAVE,ISET,IDEPL,IPICK,MIXBRN(NBMIX),MIXPWR(NBMIX) REAL DEN(NBISO),VX(NBMIX),EPS1,EPS2,EXPMAX,H1,FIT,XTI,XTF, 1 XT(2),FLUMIX(NGROUP,NBMIX) LOGICAL LMACRO @@ -136,7 +135,7 @@ 1 NDFP2,HREAC,IPIFI,IZAE INTEGER, ALLOCATABLE, DIMENSION(:,:) :: JM,INADPL,IEVOLB,KFISS, 1 KPAR,IDR,KPF - REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,RRD,AWR,PYIELD,TIMES + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,RERD,RRD,AWR,PYIELD,TIMES REAL, ALLOCATABLE, DIMENSION(:,:) :: BPAR,RER,VPHV REAL, ALLOCATABLE, DIMENSION(:,:,:) :: YDPL,YIELD,YIELD2 REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SIG @@ -191,7 +190,7 @@ NBESP=MAX(1,IDIM(10)) ALLOCATE(KPAR(NDEPL,NPAR),HREAC(2*NREAC),IDR(NREAC,NDEPL)) ALLOCATE(BPAR(NDEPL,NPAR),YIELD2(NBESP,NFISS,NDFP), - 1 RER(NREAC,NDEPL),RRD(NDEPL)) + 1 RER(NREAC,NDEPL),RERD(NDEPL),RRD(NDEPL)) CALL LCMGET(IPLIB,'ISOTOPESDEPL',INADPL) IF(IMPX.GT.1) THEN WRITE(IUNOUT,'(/38HEVODRV: DEPLETING ISOTOPES FROM CHAIN:)') @@ -207,6 +206,8 @@ CALL LCMGET(IPLIB,'CHARGEWEIGHT',IZAE) IF(NFISS*NDFP.GT.0) CALL LCMGET(IPLIB,'FISSIONYIELD',YIELD2) CALL LCMSIX(IPLIB,' ',2) + RERD(:NDEPL)=RER(1,:NDEPL) + DEALLOCATE(RER) *---- * SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES. *---- @@ -572,7 +573,7 @@ *---- CALL EVOSIG(IMPX,INR,IGLOB,NGROUP,NBMIX,NBISO,NCOMB,ISONAM, 1 IPISO,DEN,FLUMIX,VX,MILVO,JM,NVAR,NSUPS,NREAC,HREAC,IDR, - 2 RER,RRD,FIT,AWR,IZAE,FUELDN,NXSPER,DELTAT(1,IP),MIXPWR,PFACT, + 2 RERD,RRD,FIT,AWR,IZAE,FUELDN,NXSPER,DELTAT(1,IP),MIXPWR,PFACT, 3 SIG(1,1,1,IP),VPHV(1,IP)) NLENGT=(NVAR+1)*(NREAC+1)*NBMIX CALL LCMPUT(IPDEPL,'MICRO-RATES',NLENGT,2,SIG(1,1,1,IP)) @@ -627,7 +628,7 @@ *---- CALL EVOSIG(IMPX,INR,IGLOB,NGROUP,NBMIX,NBISO,NCOMB,ISONAM, 1 IPISO,DEN,FLUMIX,VX,MILVO,JM,NVAR,NSUPS,NREAC,HREAC,IDR, - 2 RER,RRD,FIT,AWR,IZAE,FUELDN,NXSPER,DELTAT(1,IP),MIXPWR,PFACT, + 2 RERD,RRD,FIT,AWR,IZAE,FUELDN,NXSPER,DELTAT(1,IP),MIXPWR,PFACT, 3 SIG(1,1,1,IP),VPHV(1,IP)) NLENGT=(NVAR+1)*(NREAC+1)*NBMIX CALL LCMPUT(IPDEPL,'MICRO-RATES',NLENGT,2,SIG(1,1,1,IP)) @@ -801,7 +802,7 @@ *---- CALL EVOBLD(IMPX,INR2,IGLOB,NBMIX,NBISO,NCOMB,ISONAM,IPISO, 1 YDPL,VX,MILVO,JM,NVAR,NDFP,NSUPS,NREAC,NPAR,NFISS,XT,EPS1,EPS2, - 2 EXPMAX,H1,ITYPE,IDIRAC,FIT,DELTA,ENERG,KPAR,BPAR,YIELD,IDR,RER, + 2 EXPMAX,H1,ITYPE,IDIRAC,FIT,DELTA,ENERG,KPAR,BPAR,YIELD,IDR, 3 RRD,AWR,FUELDN,SIG(1,1,1,1),VPH,VPHV(1,1),MIXPWR,VTOTD,IEVOLB, 4 KFISS,KPF) *---- @@ -868,7 +869,7 @@ * RELEASE THE ALLOCATED MEMORY *---- DEALLOCATE(IDR,HREAC,KPAR) - DEALLOCATE(RRD,RER,YIELD,BPAR) + DEALLOCATE(RRD,RERD,YIELD,BPAR) DEALLOCATE(KPF,KFISS) *---- * USE THE RESULT OF A DEPLETION CALCULATION IN THE FOLLOWING RUN diff --git a/Dragon/src/EVOSIG.f b/Dragon/src/EVOSIG.f index a9c282e..e10e503 100644 --- a/Dragon/src/EVOSIG.f +++ b/Dragon/src/EVOSIG.f @@ -49,9 +49,7 @@ * HREAC(1)='DECAY'; HREAC(2)='NFTOT'; * HREAC(3)='NG' ; HREAC(4)='N2N'; etc. * IDR identifier for each depleting reaction. -* RER energy (Mev) per reaction. If RER(3,J)=0., the fission energy -* is including radiative capture energy. Neutrino energy is -* never included. +* RER decay energy (Mev). * RRD sum of radioactive decay constants in 10**-8/s. * FIT flux normalization factor: * n/cm**2/s if INR=1; @@ -86,7 +84,7 @@ 1 MILVO(NCOMB),JM(NBMIX,NVAR+NSUPS),NVAR,NSUPS,NREAC, 2 HREAC(2,NREAC),IDR(NREAC,NVAR+NSUPS),IZAE(NVAR+NSUPS),NXSPER, 3 MIXPWR(NBMIX) - REAL DEN(NBISO),VX(NBMIX),RER(NREAC,NVAR+NSUPS),RRD(NVAR+NSUPS), + REAL DEN(NBISO),VX(NBMIX),RER(NVAR+NSUPS),RRD(NVAR+NSUPS), 1 FIT,AWR(NVAR+NSUPS),FUELDN(3),DELTAT(2),PFACT,VPHV(NBMIX), 2 SIG(NVAR+1,NREAC+1,NBMIX),FLUMIX(NGROUP,NBMIX) *---- @@ -94,7 +92,7 @@ *---- PARAMETER(IOUT=6,MAXREA=20) TYPE(C_PTR) KPLIB,KPLIB5 - CHARACTER HSMG*131,NAMDXS(MAXREA)*6 + CHARACTER HSMG*131,NAMDXS(MAXREA)*8 DOUBLE PRECISION GAR,GAR1,GAR2,GARD,XDRCST,EVJ,FITD,PHI,FNORM,VPH INTEGER IPRLOC LOGICAL LKERMA @@ -152,7 +150,7 @@ IS=NVAR+1 FACT=DEN(K)*VX(IBM) ENDIF - SIG(IS,NREAC+1,IBM)=SIG(IS,NREAC+1,IBM)+FACT*RER(1,IST)*RRD(IST) + SIG(IS,NREAC+1,IBM)=SIG(IS,NREAC+1,IBM)+FACT*RER(IST)*RRD(IST) IF(INR.EQ.0) GO TO 210 *---- * RECOVER KERMA FACTORS, IF AVAILABLE @@ -213,7 +211,7 @@ IF((IREAC.EQ.2).AND.(MOD(IDR(2,IST),100).EQ.5)) GO TO 120 IF(IMPX.GT.90) CALL LCMLIB(KPLIB) IF(IMPX.GT.3) THEN - WRITE(HSMG,'(17HEVOSIG: REACTION ,A6,18H IS MISSING FOR IS, + WRITE(HSMG,'(17HEVOSIG: REACTION ,A8,18H IS MISSING FOR IS, 1 7HOTOPE '',3A4,2H''.)') NAMDXS(IREAC-1),(ISONAM(I0,K),I0=1,3) WRITE(IOUT,'(1X,A)') HSMG ENDIF @@ -224,13 +222,6 @@ 130 CONTINUE SIG(IS,IREAC-1,IBM)=SIG(IS,IREAC-1,IBM)+1.0E-3*FACT*REAL(GAR)* 1 DELTAT(IXSPER) - ! if(LKERMA), add energy from lumped isotopes not present in the - ! microlib. Otherwise, add energy for all isotopes. - IF(IGLOB.NE.-1) THEN - ! Lumped energy is not included with EDEPMODE=0. - SIG(IS,NREAC,IBM)=SIG(IS,NREAC,IBM)+1.0E-3*FACT*RER(IREAC,IST)* - 1 REAL(GAR)*DELTAT(IXSPER) - ENDIF 140 CONTINUE 150 CONTINUE 210 CONTINUE diff --git a/Dragon/src/LIB.f b/Dragon/src/LIB.f index d8a8b5b..5a453f6 100644 --- a/Dragon/src/LIB.f +++ b/Dragon/src/LIB.f @@ -59,12 +59,12 @@ * LOCAL PARAMETERS *---- CHARACTER TEXT12*12,HSIGN*12,HVECT(MAXED)*8,HADD*8,NAMLCM*12, - > NAMMY*12 + > NAMMY*12,HHLIB*8,CFILNA*64 INTEGER ISTATE(NSTATE),IPRINT,NBISOX,NBMIXX,MAXMIX,INDREC, > NBISO,NGRO,NGT,NGF,NGFR,NL,ITRANC,ITIME,NLIB,NIDEPL, > NCOMB,NEDMAC,NBMIX,NRES,MAXISM,ILCMLN,ILCMTY,IED, > JED,KED,IDP,IBSTEP,MAXISO,NDEPL,NEDMA0,ITPROC,ISOADD, - > NADDXS,IPROB,IPROC,IMAC,NDEL,NFISS,IPRECI,STERN, + > NADDXS,IPROB,IPROC,IMAC,NDEL,NFISS,IPRECI,NEL,STERN, > STERNR REAL TMPDAY(3),DELT,TIMBRN,SVDEPS INTEGER IKSTEP @@ -373,7 +373,32 @@ IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// > ': INTEGER VALUE EXPECTED FOR CALENDF ACCURACY') ELSE IF(CARLIR(1:4) .EQ. 'DEPL') THEN - CALL LIBDEP(IPLIB,IPRINT,NIDEPL) + CFILNA='**UNKNOWN**' + NEL=0 + CALL REDGET(ITYPLU,NEL,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.1) THEN + CFILNA=' ' + ELSE IF((ITYPLU.EQ.3).AND.(CARLIR.EQ.'LIB:')) THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,HHLIB,DBLLIR) + IF(ITYPLU.NE.3) THEN + CALL XABORT('LIB: CHARACTER LIBRARY NAME REQUIRED.') + ELSE IF((HHLIB.NE.'DRAGON ').AND.(HHLIB.NE.'WIMSAECL').AND. + > (HHLIB.NE.'WIMSD4 ').AND.(HHLIB.NE.'WIMSE ').AND. + > (HHLIB.NE.'APLIB2 ').AND.(HHLIB.NE.'APLIB3 ').AND. + > (HHLIB.NE.'NDAS ').AND.(HHLIB.NE.'APXSM ') ) THEN + WRITE(HSMG,'(27HLIB: INVALID EVOL LIB TYPE ,A8)') HHLIB + CALL XABORT(HSMG) + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF((ITYPLU.NE.3).OR.(CARLIR.NE.'FIL:')) + > CALL XABORT('LIB: FIL: EXPECTED.') + CFILNA=' ' + CALL REDGET(ITYPLU,INTLIR,REALIR,CFILNA,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('LIB: CHARACTER DATA EXPECTED.') + ELSE + CALL XABORT('LIB: INVALID KEY WORD AFTER DEPL.') + ENDIF + CALL LIBDEP(IPLIB,HHLIB,CFILNA,NEL,IPRINT,NIDEPL) ELSE IF(CARLIR.EQ.'ADED') THEN CALL REDGET(ITYPLU,NEDMA0,REALIR,CARLIR,DBLLIR) IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR// diff --git a/Dragon/src/LIBA20.f b/Dragon/src/LIBA20.f index 73b65fc..0b2a2c1 100644 --- a/Dragon/src/LIBA20.f +++ b/Dragon/src/LIBA20.f @@ -74,7 +74,7 @@ 1 TYPSEG*8,HNAMIS*12,HNISOR*12,HNISSS*12,HSMG*131,TEXT2*2, 2 TEXT12*12 LOGICAL LPFIX,LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,LPTHOM,L104,LABS, - 1 LDIF,LFIS,LPWD,LPED + 1 LDIF,LFIS,LPWD,LPED,LH INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG DOUBLE PRECISION UU,XDRCST INTEGER ITHOMO(MAXHOM),ITEXT(20),ISFICH(3),IPAR(3) @@ -92,10 +92,11 @@ *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,KDS,LGS,NOM,NOMS, 1 NOMOB,VINTE,ITCARO,ITC104,ITS104,ITITLE,IZSECT,ISECTT,IFDG,IIAD, - 2 IDEPL + 2 IDEPL,IPR2 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, - 1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED + 1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED,QQNG, + 2 QQF,HFACT REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE @@ -106,7 +107,7 @@ *---- * SCRATCH STORAGE ALLOCATION *---- - ALLOCATE(IPR(7+2*(NL-1),NBISO),ITYPRO(NL),NFS(NGRO)) + ALLOCATE(IPR(7+2*(NL-1),NBISO),IPR2(NBISO),ITYPRO(NL),NFS(NGRO)) ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL), 1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) * @@ -317,7 +318,8 @@ IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS,NSEGM CALL LIBA27(NAMFIL,NBISO,NISOT,NSEGM,NL,ISONRF,ISHINA,MASKI, 1 NOM,NOMOB,IPR) - DEALLOCATE(NOM) + IPR2(:NBISO)=IPR(1,:NBISO) + !DEALLOCATE(NOM) IF(NISOTS.GT.0) DEALLOCATE(NOMS) CALL KDRCPU(TK2) TKT(1)=TK2-TK1 @@ -1304,13 +1306,46 @@ 600 CONTINUE ENDIF CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT) + + CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') ENDIF 610 CONTINUE *---- +* PROCESS H-FACTOR INFORMATION +*---- + ALLOCATE(QQNG(NISOT),QQF(NISOT)) + CALL LIBEAQ(NAMFIL,NISOT,IMPX,QQNG,QQF) + DO 620 IMX=1,NBISO + IF(MASKI(IMX)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + ISO=IPR2(IMX) + ALLOCATE(HFACT(NGRO)) + HFACT(:NGRO)=0.0 +* NG ENERGY. + VALUE=QQNG(ISO) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NG',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF +* FISSION ENERGIES. + VALUE=QQF(ISO) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NFTOT',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT) + DEALLOCATE(HFACT) + ENDIF + 620 CONTINUE + DEALLOCATE(QQF,QQNG) +*---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG) - DEALLOCATE(NFS,ITYPRO,IPR) + DEALLOCATE(NFS,ITYPRO,IPR2,IPR) RETURN * 800 FORMAT(/43H LIBA20: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.) diff --git a/Dragon/src/LIBA30.f b/Dragon/src/LIBA30.f index 8f5043f..f90461c 100644 --- a/Dragon/src/LIBA30.f +++ b/Dragon/src/LIBA30.f @@ -65,7 +65,7 @@ TYPE(C_PTR) KPLIB CHARACTER RECNAM*80,RECNA2*80,TEXT80*80,HNAMIS*12,HNISOR*12, 1 HSMG*131,TEXT12*12,CFILNA1*64,CFILNA2*64 - LOGICAL L104,LSIGS,LABSO,LFISS,LDIF + LOGICAL L104,LSIGS,LABSO,LFISS,LDIF,LH INTEGER RANK,TYPE,NBYTE,DIMSR(5) DOUBLE PRECISION XDRCST,DSUM REAL TKT(5) @@ -75,7 +75,7 @@ INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,ORANIS,ENRANG, 1 FSTTMP,TMPMON,ADDTMP,ITEMPA,ISPAOF,IAFAG,IFAGR,FLXADD INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR - REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,HFACT,TAUX, 1 AMASS,TEMP,TEMPM,XS,WGTFLX,BGXS,ABSOXS,DIFFXS,FISSXS,DK104 REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT @@ -84,7 +84,7 @@ * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IPR(2,NBISO),ITYPRO(NL)) - ALLOCATE(SECT(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) + ALLOCATE(SECT(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),HFACT(NGRO)) * ANEUT=REAL(XDRCST('Neutron mass','amu')) NGF=NGRO+1 @@ -419,7 +419,7 @@ LABSO=.TRUE. LDIF=.TRUE. CALL KDRCPU(TK1) - DO 600 IMX=1,NBISO + DO 570 IMX=1,NBISO KISEG=IPR(2,IMX) IF(KISEG.GT.0) THEN WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) @@ -482,27 +482,66 @@ ENDDO DEALLOCATE(TAUX,DK104,FISSXS,DIFFXS,ABSOXS,BGXS,TEMP) ENDIF - 600 CONTINUE + 570 CONTINUE CALL KDRCPU(TK2) TKT(3)=TK2-TK1 *---- +* PROCESS H-FACTOR INFORMATION +*---- + CALL KDRCPU(TK1) + DO 580 IMX=1,NBISO + IF(MASKI(IMX)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMLEN(KPLIB,'H-FACTOR',ILENG,ITYLCM) + IF(ILENG.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') + HFACT(:NGRO)=0.0 + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + WRITE(RECNAM,'(10HIsotopeXS/,A,8H/Energy/)') TRIM(HNISOR) + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM))) THEN + LH=.FALSE. + VALUE=0.0 + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM)//'/FISS')) THEN + WRITE(RECNA2,'(A,16HFISS/EnergyValue)') TRIM(RECNAM) + CALL hdf5_read_data(IPAP1,TRIM(RECNA2),VALUE) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NFTOT',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + ENDIF + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM)//'/MT-102')) THEN + WRITE(RECNA2,'(A,18HMT-102/EnergyValue)') TRIM(RECNAM) + CALL hdf5_read_data(IPAP1,TRIM(RECNA2),VALUE) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NG',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + ENDIF + IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT) + ENDIF + ENDIF + 580 CONTINUE + CALL KDRCPU(TK2) + TKT(2)=TKT(2)+TK2-TK1 +*---- * CHECK IF ALL REACTIONS HAVE BEEN PROCESSED. *---- - DO 575 IMX=1,NBISO - DO 570 I=1,2 + DO 600 IMX=1,NBISO + DO 590 I=1,2 IF(IPR(I,IMX).NE.0) THEN WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3) CALL XABORT(HSMG) ENDIF - 570 CONTINUE - 575 CONTINUE + 590 CONTINUE + 600 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,3) *---- * SCRATCH STORAGE DEALLOCATION *---- IF(NBFLX.GT.0) DEALLOCATE(WGTFLX,FLXADD) DEALLOCATE(DELTA,ENERG) - DEALLOCATE(XSTOT,SCAT,SIGS,SECT) + DEALLOCATE(HFACT,SCAT,SIGS,SECT) DEALLOCATE(ITYPRO,IPR) RETURN * diff --git a/Dragon/src/LIBADD.f b/Dragon/src/LIBADD.f index b7262c5..ba6829b 100644 --- a/Dragon/src/LIBADD.f +++ b/Dragon/src/LIBADD.f @@ -1,12 +1,12 @@ *DECK LIBADD - SUBROUTINE LIBADD (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ISONAM, - 1 IPISO,NIR,GIR) + SUBROUTINE LIBADD (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,NDEPL, + 1 ISONAM,ISONRF,IPISO,NIR,GIR) * *----------------------------------------------------------------------- * *Purpose: -* Add transport correction and Goldstein-Cohen data to a /microlib/ -* directory. +* Add transport correction, Goldstein-Cohen and H-FACTOR data to a +* /microlib/ directory. * *Copyright: * Copyright (C) 2002 Ecole Polytechnique de Montreal @@ -30,7 +30,9 @@ * ITRANC transport correction option (=0: no correction; =1: Apollo- * type; =2: recover TRANC record; =3: Wims-type; =4: leakage * correction alone). +* NDEPL number of depleting isotopes. * ISONAM alias name of each isotope. +* ISONRF library reference name of each isotope. * IPISO pointer array towards microlib isotopes. * NIR group index with an imposed IR slowing-down model (=0 for no * IR model). @@ -44,20 +46,24 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB,IPISO(NBISO) - INTEGER NBISO,IMPX,NGRO,NL,ITRANC,ISONAM(3,NBISO),NIR(NBISO) + INTEGER NBISO,IMPX,NGRO,NL,ITRANC,NDEPL,ISONAM(3,NBISO), + 1 ISONRF(3,NBISO),NIR(NBISO) LOGICAL MASKI(NBISO) REAL GIR(NBISO) *---- * LOCAL VARIABLES *---- - PARAMETER (IOUT=6) + PARAMETER (IOUT=6,NSTATE=40) + INTEGER ISTATE(NSTATE) TYPE(C_PTR) JPLIB,KPLIB - CHARACTER TEXT12*12,HSMG*131 + CHARACTER HSONAM*12,HSONRF*12,HSMG*131 *---- * ALLOCATABLE ARRAYS *---- REAL, ALLOCATABLE, DIMENSION(:) :: WORK,WR2,DELTA - REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT,RER + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HREAC + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HGAR *---- * SCRATCH STORAGE ALLOCATION *---- @@ -75,10 +81,32 @@ DO 15 IGR=1,NGRO DELTA(IGR)=LOG(DELTA(IGR)/DELTA(IGR+1)) 15 CONTINUE +*---- +* RECOVER DEPLETION DATA. +*---- + NREAC=0 + IF(NDEPL.NE.0) THEN + CALL LCMLEN(IPLIB,'DEPL-CHAIN',LENGTH,ITYLCM) + IF(LENGTH.EQ.0) THEN + CALL LCMLIB(IPLIB) + CALL XABORT('LIBADD: MISSING DEPL-CHAIN DATA.') + ENDIF + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NDEPL) CALL XABORT('LIBADD: INVALID NUMBER OF ' + 1 //'DEPLETING ISOTOPES.') + NREAC=ISTATE(8) + ALLOCATE(HGAR(NDEPL),RER(NREAC,NDEPL),HREAC(NREAC)) + CALL LCMGTC(IPLIB,'ISOTOPESDEPL',12,NDEPL,HGAR) + CALL LCMGET(IPLIB,'DEPLETE-ENER',RER) + CALL LCMGTC(IPLIB,'DEPLETE-IDEN',8,NREAC,HREAC) + CALL LCMSIX(IPLIB,' ',2) + ENDIF * DO 110 ISO=1,NBISO IF(MASKI(ISO)) THEN - WRITE(TEXT12,'(3A4)') ISONAM(1,ISO),ISONAM(2,ISO),ISONAM(3,ISO) + WRITE(HSONAM,'(3A4)') (ISONAM(I,ISO),I=1,3) + WRITE(HSONRF,'(3A4)') (ISONRF(I,ISO),I=1,3) KPLIB=IPISO(ISO) ! set ISO-th isotope IF(.NOT.C_ASSOCIATED(KPLIB)) GO TO 110 CALL LCMLEN(KPLIB,'NTOT0',ILENG,ITYLCM) @@ -86,7 +114,7 @@ JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') CALL LCMLIB(JPLIB) WRITE(HSMG,'(17H LIBADD: ISOTOPE ,A12,6H (ISO=,I6, - 1 17H) IS NOT DEFINED.)') TEXT12,ISO + 1 17H) IS NOT DEFINED.)') HSONAM,ISO CALL XABORT(HSMG) ENDIF * @@ -101,13 +129,13 @@ CALL LCMPUT(KPLIB,'NGOLD',NGRO,2,WORK) IF(IMPX.GT.1) THEN IF(GIR(ISO).EQ.-998.0) THEN - WRITE(IOUT,210) TEXT12,'PT',NIR(ISO) + WRITE(IOUT,210) HSONAM,'PT',NIR(ISO) ELSE IF(GIR(ISO).EQ.-999.0) THEN - WRITE(IOUT,210) TEXT12,'PTSL',NIR(ISO) + WRITE(IOUT,210) HSONAM,'PTSL',NIR(ISO) ELSE IF(GIR(ISO).EQ.-1000.0) THEN - WRITE(IOUT,210) TEXT12,'PTMC',NIR(ISO) + WRITE(IOUT,210) HSONAM,'PTMC',NIR(ISO) ELSE - WRITE(IOUT,200) TEXT12,GIR(ISO),NIR(ISO) + WRITE(IOUT,200) HSONAM,GIR(ISO),NIR(ISO) ENDIF ENDIF ENDIF @@ -135,7 +163,7 @@ CALL LCMLEN(KPLIB,'SCAT-SAVED',ILENG,ITYLCM) IF(ILENG.EQ.0) THEN WRITE(HSMG,'(37H LIBADD: NO SCAT-SAVED RECORD FOR ISO, - 1 5HTOPE ,A12,1H.)') TEXT12 + 1 5HTOPE ,A12,1H.)') HSONAM CALL XABORT(HSMG) ENDIF CALL XDRLGS(KPLIB,-1,0,1,1,1,NGRO,WR2,SCAT,ITY) @@ -165,11 +193,40 @@ * CORRECTIONS. CALL LCMPUT(KPLIB,'TRANC',NGRO,2,WORK) ENDIF +* +* ADD OR CORRECT H-FACTOR INFORMATION IN THE MICROLIB. + IF(NDEPL.NE.0) THEN + JDEPL=0 + DO IDEPL=1,NDEPL + JDEPL=IDEPL + IF(HSONRF.EQ.HGAR(IDEPL)) GO TO 80 + ENDDO + CYCLE + 80 WORK(:NGRO)=0.0 + CALL LCMLEN(KPLIB,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.NE.0) CALL LCMGET(KPLIB,'H-FACTOR',WORK) + DO IREA=2,NREAC + CALL LCMLEN(KPLIB,HREAC(IREA),LENGTH,ITYLCM) + IF(LENGTH.EQ.0) CYCLE + IF(LENGTH.GT.NGRO) CALL XABORT('LIBADD: WR2 OVERFLOW.') + WR2(:NGRO)=0.0 + CALL LCMGET(KPLIB,HREAC(IREA),WR2) + DO IG=1,LENGTH + WORK(IG)=WORK(IG)+RER(IREA,JDEPL)*WR2(IG)*1.0E6 + ENDDO + ENDDO ! IREA + CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,WORK) + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(42H LIBADD: ADD H-FACTOR INFORMATION TO ISOTO, + 1 3HPE ,A,1H.)') TRIM(HSONRF) + ENDIF + ENDIF ENDIF 110 CONTINUE *---- * SCRATCH STORAGE DEALLOCATION *---- + IF(NDEPL.NE.0) DEALLOCATE(HREAC,RER,HGAR) DEALLOCATE(DELTA,SCAT,WR2,WORK) RETURN * diff --git a/Dragon/src/LIBAPL.f b/Dragon/src/LIBAPL.f index 24efbcb..aa4367c 100644 --- a/Dragon/src/LIBAPL.f +++ b/Dragon/src/LIBAPL.f @@ -899,6 +899,11 @@ SIGA(I)=SIGA(I)+SIGS(I,1) 730 CONTINUE CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SIGA) +*---- +* VOID H-FACTOR +*---- + CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') GO TO 50 *---- * CHECK IF ALL NBISO ISOTOPES HAVE BEEN PROCESSED. diff --git a/Dragon/src/LIBDEP.F b/Dragon/src/LIBDEP.F index e1b539a..94ed383 100644 --- a/Dragon/src/LIBDEP.F +++ b/Dragon/src/LIBDEP.F @@ -1,5 +1,5 @@ *DECK LIBDEP - SUBROUTINE LIBDEP(IPLIB,IMPX,NDEPL) + SUBROUTINE LIBDEP(IPLIB,HHLIB,CFILNA,NEL,IMPX,NDEPL) * *----------------------------------------------------------------------- * @@ -18,6 +18,9 @@ *Parameters: input * IPLIB pointer to the internal microscopic cross section library * (L_LIBRARY signature). +* HHLIB library file type. +* CFILNA library file name. +* NEL user-defined number of depleting isotopes if CFILNA=' '. * IMPX print flag. * *Parameters: output @@ -34,19 +37,18 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB - INTEGER IMPX,NDEPL + INTEGER IMPX,NDEPL,NEL + CHARACTER HHLIB*8,CFILNA*64 *---- * LOCAL PARAMETERS *---- TYPE(C_PTR) IPDRL - INTEGER IOUT,NSTATE,MAXR,INDIC,NEL,IEVOT,NITMA,NDFI, - > NDFP,NHEAVY,NLIGHT,NOTHER,NSTABL,NREAC,NPAR, - > ITEXT4,I,J,ISTA,ILONG,ITYLCM,NBESP - REAL FLOTT + INTEGER IOUT,NSTATE,MAXR,IEVOT,NDFI,NDFP,NHEAVY,NLIGHT, + > NOTHER,NSTABL,NREAC,NPAR,ITEXT4,I,J,ISTA,ILONG, + > ITYLCM,NBESP PARAMETER (IOUT=6,NSTATE=40,MAXR=12) - DOUBLE PRECISION DBLINP - CHARACTER NMDEPL(MAXR)*8,TEXT4*4,HSMG*131,CFILNA*64, - > HHLIB*8,TEXT12*12,NAMLCM*12,NAMMY*12 + CHARACTER NMDEPL(MAXR)*8,TEXT4*4,HSMG*131,TEXT12*12, + > NAMLCM*12,NAMMY*12,HVERS*12 LOGICAL EMPTY,LCM,LEXIST INTEGER ISTATE(NSTATE) #if defined(HDF5_LIB) @@ -71,28 +73,11 @@ *---- * READ INFORMATION AVAILABLE ON INPUT *---- - CALL REDGET(INDIC,NEL,FLOTT,TEXT4,DBLINP) IEVOT=-99 NBESP=1 - IF(INDIC.EQ.1) THEN - IEVOT=0 - ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIB:')) THEN - CALL REDGET(INDIC,NITMA,FLOTT,HHLIB,DBLINP) - IF(INDIC.NE.3) THEN - CALL XABORT('LIBDEP: CHARACTER LIBRARY NAME REQUIRED.') - ELSE IF((HHLIB.NE.'DRAGON ') .AND. (HHLIB.NE.'WIMSAECL') .AND. - > (HHLIB.NE.'WIMSD4 ') .AND. (HHLIB.NE.'WIMSE ') .AND. - > (HHLIB.NE.'APLIB2 ') .AND. (HHLIB.NE.'APLIB3 ') .AND. - > (HHLIB.NE.'NDAS ') .AND. (HHLIB.NE.'APXSM ') ) THEN - WRITE(HSMG,'(30HLIBDEP: INVALID EVOL LIB TYPE ,A8)') HHLIB - CALL XABORT(HSMG) - ENDIF - CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DBLINP) - IF((INDIC.NE.3).OR.(TEXT4.NE.'FIL:')) - > CALL XABORT('LIBDEP: FIL: EXPECTED.') - CFILNA=' ' - CALL REDGET(INDIC,NITMA,FLOTT,CFILNA,DBLINP) - IF(INDIC.NE.3) CALL XABORT('LIBDEP: CHARACTER DATA EXPECTED.') + IF(CFILNA.EQ.' ') THEN + IEVOT=0 + ELSE IF(HHLIB.EQ.'DRAGON') THEN TEXT12=CFILNA(:12) CALL LCMINF(IPLIB,NAMLCM,NAMMY,EMPTY,ILONG,LCM) @@ -106,6 +91,15 @@ CALL XABORT(HSMG) ENDIF CALL LCMOP(IPDRL,TEXT12,2,2,0) + HVERS='**UNKNOWN**' + CALL LCMLEN(IPDRL,'VERSION',ILONG,ITYLCM) + IF(ILONG.NE.0) CALL LCMGTC(IPDRL,'VERSION',12,HVERS) + IF(IMPX.GT.0) WRITE (IOUT,6010) TRIM(TEXT12),TRIM(HVERS) + IF(HVERS.EQ.'RELEASE_2003') THEN + HSMG='LIBDEP: ***WARNING*** RELEASE_2003 DRAGLIBS ARE DE' + > //'PRECIATED.' + WRITE(IOUT,'(1X,A)') HSMG + ENDIF ENDIF CALL LCMLEN(IPDRL,'DEPL-CHAIN',ILONG,ITYLCM) IF(ILONG.EQ.0) THEN @@ -184,8 +178,6 @@ CALL XABORT('LIBDEP: THE HDF5 API IS NOT AVAILABLE(1).') #endif /* defined(HDF5_LIB) */ ENDIF - ELSE - CALL XABORT('LIBDEP: INVALID KEY WORD.') ENDIF IF(IEVOT.EQ.0.OR.IEVOT.GT.1) THEN *---- @@ -310,4 +302,5 @@ > ' NPAR ',I6,' (MAXIMUM NUMBER OF PARENT REACTIONS)'/ > ' NBESP ',I6,' (NUMBER OF ENERGY-DEPENDENT FISSION YIELD MAT', > 'RICES)'/) + 6010 FORMAT(/33H PROCESSING DRAGON LIBRARY NAMED ,A,9H VERSION ,A,1H.) END diff --git a/Dragon/src/LIBDRA.f b/Dragon/src/LIBDRA.f index 51438a9..e846822 100644 --- a/Dragon/src/LIBDRA.f +++ b/Dragon/src/LIBDRA.f @@ -63,7 +63,7 @@ *---- * LOCAL VARIABLES *---- - CHARACTER CD*4,HSMG*131,HTITLE*80,HNISOR*12,HNAMIS*12,HNUSIG*12, + CHARACTER CD*4,HSMG*131,HVERS*12,HNISOR*12,HNAMIS*12,HNUSIG*12, 1 HCHI*12 PARAMETER (IOUT=6,MAXTMP=50,NOTX=3) TYPE(C_PTR) KPLIB @@ -74,13 +74,14 @@ *---- * ALLOCATABLE ARRAYS *---- - INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS,ITYPRO,ITITLE + INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS,ITYPRO REAL, ALLOCATABLE, DIMENSION(:) :: AWR,DELTA,TOTAL,GOLD,ZNPHI, 1 ENER,BIN,EBIN,SIGS2,SCAT2,TOTAL2,SIGF2,CHI2,SADD2,GOLD2,BIN2, 2 ZNPHI2,CHI4G2 REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,SIGF,CHI,SADD,CHI4G REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSCAT,LADD + CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: HTITLE *---- * SCRATCH STORAGE ALLOCATION *---- @@ -95,20 +96,24 @@ NGF=NGRO+1 NGFR=0 NDEL=0 - IF(IMPX.GT.0) WRITE (IOUT,900) NAMFIL + HVERS='**UNKNOWN**' + CALL LCMLEN(IPDRL,'VERSION',LENGT,ITYLCM) + IF(LENGT.NE.0) CALL LCMGTC(IPDRL,'VERSION',12,HVERS) + IF(IMPX.GT.0) WRITE (IOUT,900) TRIM(NAMFIL),TRIM(HVERS) + IF(HVERS.EQ.'RELEASE_2003') THEN + WRITE(IOUT,'(46H LIBDRA: ***WARNING*** RELEASE_2003 DRAGLIBS A, + 1 15HRE DEPRECIATED.)') + ENDIF CALL LCMLEN(IPDRL,'README',LENGT,ITYLCM) IF((IMPX.GT.0).AND.(LENGT.GT.0)) THEN - ALLOCATE(ITITLE(LENGT)) - CALL LCMGET(IPDRL,'README',ITITLE) + LENGT=(LENGT-1)/20+1 + ALLOCATE(HTITLE(LENGT)) + CALL LCMGTC(IPDRL,'README',80,LENGT,HTITLE) WRITE (IOUT,940) - I2=0 - DO 10 J=0,LENGT/20 - I1=I2+1 - I2=MIN(I1+19,LENGT) - WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2) - WRITE (IOUT,'(1X,A80)') HTITLE + DO 10 J=1,LENGT + WRITE (IOUT,'(1X,A80)') HTITLE(J) 10 CONTINUE - DEALLOCATE(ITITLE) + DEALLOCATE(HTITLE) WRITE (IOUT,'(40H LIBDRA: NUMBER OF ISOTOPES IN MICROLIB=,I6)') 1 NBISO ENDIF @@ -157,18 +162,15 @@ CALL LCMGET(IPDRL,'AWR',AWR(IMX)) CALL LCMLEN(IPDRL,'README',LTITLE,ITYLCM) IF(LTITLE.GT.0) THEN - ALLOCATE(ITITLE(LTITLE)) - CALL LCMGET(IPDRL,'README',ITITLE) - IF(IMPX.GT.0) THEN - WRITE (IOUT,930) - I2=0 - DO 20 J=0,LTITLE/20 - I1=I2+1 - I2=MIN(I1+19,LTITLE) - WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2) - WRITE (IOUT,'(1X,A80)') HTITLE - 20 CONTINUE - ENDIF + LTITLE=(LTITLE-1)/20+1 + ALLOCATE(HTITLE(LTITLE)) + CALL LCMGTC(IPDRL,'README',80,LTITLE,HTITLE) + IF(IMPX.GT.0) THEN + WRITE (IOUT,930) + DO 20 J=1,LTITLE + WRITE (IOUT,'(1X,A80)') HTITLE(J) + 20 CONTINUE + ENDIF ENDIF *---- * RECOVER BIN TYPE INFORMATION (IF AVAILABLE). @@ -326,8 +328,8 @@ CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS) CALL LCMPUT(KPLIB,'AWR',1,2,AWR(IMX)) IF(LTITLE.GT.0) THEN - CALL LCMPUT(KPLIB,'README',LTITLE,3,ITITLE) - DEALLOCATE(ITITLE) + CALL LCMPTC(KPLIB,'README',80,LTITLE,HTITLE) + DEALLOCATE(HTITLE) ENDIF DO 220 IG=1,NGRO IF(TOTAL(IG).LT.0.0) THEN @@ -371,6 +373,8 @@ 260 CONTINUE ENDIF CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO) + CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') DO 340 IED=1,NED IF(LADD(IED).AND.(HVECT(IED)(:3).NE.'CHI') 1 .AND.(HVECT(IED)(:2).NE.'NU') @@ -407,7 +411,7 @@ DEALLOCATE(ITYPRO,NFS) RETURN * - 900 FORMAT(/33H PROCESSING DRAGON LIBRARY NAMED ,A12,1H.) + 900 FORMAT(/33H PROCESSING DRAGON LIBRARY NAMED ,A,9H VERSION ,A,1H.) 910 FORMAT(26HLIBDRA: MATERIAL/ISOTOPE ',A12,5H' = ',A12,9H' IS MISS, 1 25HING ON DRAGON FILE NAMED ,A12,10H (ISOTOPE=,I10,2H).) 920 FORMAT(/30H PROCESSING ISOTOPE/MATERIAL ',A12,11H' (HNISOR=',A12, diff --git a/Dragon/src/LIBE3R.f b/Dragon/src/LIBE3R.f index c644c52..045db16 100644 --- a/Dragon/src/LIBE3R.f +++ b/Dragon/src/LIBE3R.f @@ -51,7 +51,7 @@ DOUBLE PRECISION SUM PARAMETER (IOUT=6,MAXR2=12) PARAMETER (KDECAY=1,KFISSP=2,KCAPTU=3,KN2N=4,KN3N=5,KN4N=6) - CHARACTER RECNAM*80,RECNAM2*80,HSMG*131,NMDEPA(MAXR2)*6 + CHARACTER RECNAM*80,HSMG*131,NMDEPA(MAXR2)*6 *---- * ALLOCATABLE ARRAYS *---- @@ -141,6 +141,7 @@ * MAIN LOOP OVER ISOTOPES *---- NDFP2=0 + BPAX(:NBESP,:NEL+MAXR,:NEL)=0.0 DO ISO=1,NISOT ITZEA(ISO)=IZ(ISO)*10000+IA(ISO)*10 II=LEN(TRIM(NAMES(ISO))) @@ -171,22 +172,8 @@ ENDDO DEALLOCATE(LIST) ENDIF - WRITE(RECNAM,'(10HIsotopeXS/,A,8H/Energy/)') TRIM(NAMES(ISO)) - IF(hdf5_group_exists(IPAP1,TRIM(RECNAM))) THEN - IF(KPAX(NEL+KFISSP,ISO).EQ.1) THEN - WRITE(RECNAM2,'(A,16HFISS/EnergyValue)') TRIM(RECNAM) - CALL hdf5_read_data(IPAP1,TRIM(RECNAM2),VALUE) - BPAX(:,NEL+KFISSP,ISO)=VALUE - ENDIF - IF(KPAX(NEL+KCAPTU,ISO).EQ.1) THEN - WRITE(RECNAM2,'(A,18HMT-102/EnergyValue)') TRIM(RECNAM) - CALL hdf5_read_data(IPAP1,TRIM(RECNAM2),VALUE) - BPAX(:,NEL+KCAPTU,ISO)=VALUE - ENDIF - ENDIF IF(IMPX.GT.2) THEN - WRITE(IOUT,100) NAMES(ISO),BPAX(1,NEL+KDECAY,ISO), - 1 BPAX(1,NEL+KFISSP,ISO),BPAX(1,NEL+KCAPTU,ISO) + WRITE(IOUT,100) NAMES(ISO),BPAX(1,NEL+KDECAY,ISO) WRITE(IOUT,110) (NMDEPA(I),KPAX(NEL+I,ISO),I=1,MAXR) ENDIF *---- @@ -291,8 +278,7 @@ RETURN * 100 FORMAT(/44H LIBE3R: DECAY AND BURNOUT DATA FOR ISOTOPE=,A/ - 1 5X,6HDECAY=,1P,E12.5,7H E-8 /S,16H FISSION ENERGY=,E12.5,4H MEV, - 1 16H CAPTURE ENERGY=,E12.5,4H MEV) + 1 5X,6HDECAY=,1P,E12.5,7H E-8 /S) 110 FORMAT(5X,12(A6,2H= ,I1,2X)) 120 FORMAT(5X,14HPARENT NAMES: ,12A8/(19X,12A8)) END diff --git a/Dragon/src/LIBEAQ.f b/Dragon/src/LIBEAQ.f new file mode 100644 index 0000000..b969108 --- /dev/null +++ b/Dragon/src/LIBEAQ.f @@ -0,0 +1,254 @@ +*DECK LIBEAQ + SUBROUTINE LIBEAQ(CFILNA,NEL,IMPX,QQNG,QQF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover Q and pseudo-Q values from an APOLIB2 file. +* +*Copyright: +* Copyright (C) 2025 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): A. Hebert +* +*Parameters: input +* CFILNA APOLIB-2 file name. +* NEL number of isotopes on library. +* IMPX print flag. +* +*Parameters: output +* QQNG radiative capture Q value. +* QQF fission pseudo Q value. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CFILNA*(*) + INTEGER NEL,IMPX + REAL QQNG(NEL),QQF(NEL) +*---- +* LOCAL VARIABLES +*---- + EXTERNAL LIBA21 + INTEGER ISFICH(3),NITCA(5) + PARAMETER (IOUT=6) + CHARACTER TEXT20*20,NOMOBJ*20,TEXT12*12,TEXT16*16,TYPOBJ*8, + > TYPSEG*8,HNISOR*20,HSMG*131 + LOGICAL LPHEAD,LPCONS,LPFIX +*---- +* SCRATCH STORAGE ALLOCATION +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,NOMOB,KDS,LGS,ITCARO, + 1 NOM + TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR + INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM + REAL, POINTER, DIMENSION(:) :: RTSEGM +* + INTEGER TKCARO(31) + SAVE TKCARO + DATA TKCARO / + & 0, 1, 2, 3, 4, 5, 6, 30, 7, -8, + & 9, -10, 11, -12, 13, -14, 15, 16, -17, 18, + & -19, 20, -21, 22, 23, -24, 25, -26, 27, -28, + & 29 / +*---- +* OPEN AND PROBE THE APOLIB-2 FILE. +*---- + CALL AEXTPA(CFILNA,ISFICH) + IADRES=ISFICH(1) + NBOBJ=ISFICH(2) + LBLOC=ISFICH(3) + IUNIT=KDROPN(CFILNA,2,4,LBLOC) + IF(IUNIT.LE.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBEAQ: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// + 1 'E OPENED') + ENDIF +*---- +* INDEX THE APOLIB-2 FILE. +*---- + ALLOCATE(VINTE(2*NBOBJ)) + CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ) + IDKNO=1-TKCARO(14) + IDKTY=1-TKCARO(21) + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKNS=TKCARO(2)+1 + IDKLS=TKCARO(8) +* + NSEGM=0 + NMGY=0 + NISOT=0 + ALLOCATE(NOMOB(5*(NBOBJ-3)),KDS(NBOBJ-3),LGS(NBOBJ-3)) + LPHEAD=.FALSE. + LPCONS=.FALSE. + DO 80 IOBJ=3,NBOBJ + IDKOBJ=VINTE(2*IOBJ-1) + LGSEG=VINTE(2*IOBJ)+1 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IF(TYPOBJ.EQ.'APOLIB') THEN + DO 70 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LTESTS=ITCARO(IDKLS+IS) + IF(LTESTS.LE.0) GO TO 70 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR, + 1 ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LTESTS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1) + IF(TYPSEG.EQ.'PHEAD') THEN + LPHEAD=.TRUE. + CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP, + 1 ICHDKL,IDK,NV) + IF(NV.EQ.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBEAQ: NO ISOTOPES PRESENT ON APOLIB-2 '// + 1 'FILE NAMED: '//TEXT12) + ENDIF + NISOT=NV/20 + IF(NISOT.NE.NEL) CALL XABORT('LIBEAQ: INVALID NEL.') + ALLOCATE(NOM(5*NISOT)) + DO 20 ISO=1,NISOT + ISO2=(ISO-1)*5+1 + CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),HNISOR) + CALL LCMCAR(HNISOR,.TRUE.,NOM(ISO2)) + 20 CONTINUE + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 70 CONTINUE + ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN + NSEGM=NSEGM+1 + ISO2=(NSEGM-1)*5+1 + CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2)) + KDS(NSEGM)=IDKOBJ + LGS(NSEGM)=LGSEG + ELSE + CALL XABORT('LIBEAQ: WEIRD SEGMENT TYPE: '//TYPOBJ//' (1).') + ENDIF + DEALLOCATE(ITCARO) + 80 CONTINUE + IF(.NOT.LPHEAD) CALL XABORT('LIBEAQ: PHEAD SEGMENT NOT FOUND.') + DEALLOCATE(VINTE) +*---- +* SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES. +*---- + IF(IMPX.GT.2) WRITE(IOUT,'(/16H LIBEAQ: ISOTOPE,12X,4HQ-NG,9X, + 1 9HQ-FISSION)') + KISEG2=0 + DO 260 ISO=1,NISOT + ISO2=(ISO-1)*5+1 + CALL LCMCAR(TEXT16,.FALSE.,NOM(ISO2)) + TEXT20='ISOTOP'//TEXT16(:14) + CALL LCMCAR(TEXT20,.TRUE.,NITCA(1)) + DO 90 ISEG=1,NSEGM + ISEG2=(ISEG-1)*5+1 + IF(NITCA(1).EQ.NOMOB(ISEG2)) THEN + IF(NITCA(2).EQ.NOMOB(ISEG2+1)) THEN + IF(NITCA(3).EQ.NOMOB(ISEG2+2)) THEN + IF(NITCA(4).EQ.NOMOB(ISEG2+3)) THEN + IF(NITCA(5).EQ.NOMOB(ISEG2+4)) THEN + KISEG2=ISEG + GO TO 120 + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 90 CONTINUE + WRITE (HSMG,500) HNISOR,CFILNA + CALL XABORT(HSMG) +*---- +* ACTIVATION OF CORRESPONDING 'ISOTOP'//NAME SEGMENT. +*---- + 120 IDKOBJ=KDS(KISEG2) + LGSEG=LGS(KISEG2) + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) +*---- +* RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION. +*---- + LPFIX=.FALSE. + DO 160 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG) + LTESTS=ITCARO(IDKLS+IS) + IF(LTESTS.LE.0) GO TO 160 + JDKS=ITCARO(JDKDS+IS) + CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR) + CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /)) + CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /)) + CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /)) + TSEGM_PTR=LCMARA(LTESTS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /)) + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /)) + CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1) +*---- +* RECOVER Q VALUES. +*---- + IF(TYPSEG.EQ.'PFIX') THEN + LPFIX=.TRUE. +* NG ENERGY. + CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV) + IF(NV.NE.0) THEN + IF(RTSEGM(IDK).NE.0.0) QQNG(ISO)=RTSEGM(IDK) + ENDIF +* FISSION ENERGIES. + CALL AEXGNV(20,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NMGEF) + IF(NMGEF.NE.0) THEN + IF(RTSEGM(IDK+NMGEF-1).NE.0.0) QQF(ISO)=RTSEGM(IDK+NMGEF-1) + ENDIF + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 160 CONTINUE + IF(.NOT.LPFIX) CALL XABORT('LIBEAQ: NO PFIX SEGMENT.') + DEALLOCATE(ITCARO) + IF(IMPX.GT.2) WRITE(IOUT,'(9X,A16,1P,2E13.4)') TEXT16, + 1 QQNG(ISO),QQF(ISO) + 260 CONTINUE +* + DEALLOCATE(LGS,KDS,NOMOB,NOM) + IERR=KDRCLS(IUNIT,1) + IF(IERR.LT.0) THEN + TEXT12=CFILNA + CALL XABORT('LIBEAQ: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'// + 1 'E CLOSED') + ENDIF + RETURN +* + 500 FORMAT(26HLIBEAQ: MATERIAL/ISOTOPE ',A20,20H' IS MISSING ON APOL, + > 15HIB-2 FILE NAME ,A12,1H.) + END diff --git a/Dragon/src/LIBEAR.f b/Dragon/src/LIBEAR.f index 8b7746c..1bc1d67 100644 --- a/Dragon/src/LIBEAR.f +++ b/Dragon/src/LIBEAR.f @@ -30,7 +30,7 @@ * atomic number z*10000 (digits) + mass number a*10 + * energy state (0 = ground state, 1 = first state, etc.). * KPAX complete reaction type matrix. -* BPAX complete branching ratio matrix. +* BPAX complete branching ratio matrix. Q values are not recovered. * *----------------------------------------------------------------------- * @@ -50,7 +50,9 @@ CHARACTER CFILNA*(*),NMDEPL(MAXR)*8 INTEGER MAXR,NEL,ITNAM(3,NEL),ITZEA(NEL),KPAX(NEL+MAXR,NEL) REAL BPAX(NEL+MAXR,NEL) -* +*---- +* LOCAL VARIABLES +*---- EXTERNAL LIBA21 INTEGER ISFICH(3),NITCA(5) PARAMETER (IOUT=6) @@ -288,7 +290,6 @@ IF(NV.NE.0) THEN IF(RTSEGM(IDK).NE.0.0) THEN KPAX(NEL+3,ISO)=1 - BPAX(NEL+3,ISO)=RTSEGM(IDK) ENDIF ENDIF * AVAILABLE CROSS SECTION TYPES. @@ -305,7 +306,6 @@ IF(NMGEF.NE.0) THEN IF(RTSEGM(IDK+NMGEF-1).NE.0.0) THEN KPAX(NEL+2,ISO)=1 - BPAX(NEL+2,ISO)=RTSEGM(IDK+NMGEF-1) ENDIF ENDIF * RADIOACTIVE DECAY CONSTANTS. diff --git a/Dragon/src/LIBLIB.f b/Dragon/src/LIBLIB.f index 53abc67..59712d2 100644 --- a/Dragon/src/LIBLIB.f +++ b/Dragon/src/LIBLIB.f @@ -45,7 +45,7 @@ *---- TYPE(C_PTR) JPLIB,KPLIB INTEGER IPAR(NSTATE),NGRO,NL,ITRANC,ITIME,NLIB,NGF,IGRMAX,NED, - > NDEL,IPROC,ILENG,ITYLCM,IVOID,NBESP,ISOT,NPART,IOF + > NDEL,IPROC,ILENG,ITYLCM,IVOID,NBESP,ISOT,NPART,NDEPL,IOF CHARACTER HVECT(MAXED)*8,TEXT4*4,NAMLBT*8,TEXT12*12 *---- * ALLOCATABLE ARRAYS @@ -59,6 +59,7 @@ *---- * RECOVER INFORMATION FROM THE /MICROLIB/ DIRECTORY. *---- + CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) IF(NBISO.NE.IPAR(2)) CALL XABORT('LIBLIB: INCONSISTENT LIBRARY.') NGRO=IPAR(3) @@ -68,6 +69,7 @@ NLIB=IPAR(8) NGF=IPAR(9) IGRMAX=IPAR(10) + NDEPL=IPAR(11) NED=IPAR(13) IF(NED.GT.MAXED) CALL XABORT('LIBLIB: MAXED OVERFLOW.') NBESP=IPAR(16) @@ -151,7 +153,7 @@ *---- CALL LIBLIC (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ITIME,NLIB, 1 NED,HVECT,ISONA,ISONR,IPISO,ISHIN,TMPIS,IHLIB,ILLIB,NAME,NTFG, - 2 LSHI,SN,SB,NIR,GIR,NGF,IGRMAX,NDEL,NBESP,NPART,IPROC) + 2 LSHI,SN,SB,NIR,GIR,NGF,IGRMAX,NDEL,NBESP,NPART,IPROC,NDEPL) *---- * RESET ISOTOPE ALIAS. *---- diff --git a/Dragon/src/LIBLIC.F b/Dragon/src/LIBLIC.F index a669c9d..8079f3a 100644 --- a/Dragon/src/LIBLIC.F +++ b/Dragon/src/LIBLIC.F @@ -1,7 +1,8 @@ *DECK LIBLIC SUBROUTINE LIBLIC (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ITIME, 1 NLIB,NED,HVECT,ISONAM,ISONRF,IPISO,ISHINA,TMPISO,IHLIB,ILLIB, - 2 INAME,NTFG,LSHI,SN,SB,NIR,GIR,NGF,IGRMAX,NDEL,NBESP,NPART,IPROC) + 2 INAME,NTFG,LSHI,SN,SB,NIR,GIR,NGF,IGRMAX,NDEL,NBESP,NPART,IPROC, + 3 NDEPL) * *----------------------------------------------------------------------- * @@ -63,6 +64,7 @@ * NBESP number of energy-dependent fission spectra. * NPART number of particles. * IPROC type of library processing. +* NDEPL number of depleting isotopes. * *----------------------------------------------------------------------- * @@ -76,7 +78,7 @@ *---- TYPE(C_PTR) IPLIB,IPISO(NBISO) INTEGER NBISO,IMPX,NGRO,NL,ITRANC,ITIME,NLIB,NED,NGF,IGRMAX,NDEL, - > NBESP,NPART,IPROC,ISONAM(3,NBISO),ISONRF(3,NBISO), + > NBESP,NPART,IPROC,NDEPL,ISONAM(3,NBISO),ISONRF(3,NBISO), > ISHINA(3,NBISO),IHLIB(2,NBISO,4),ILLIB(NBISO),INAME(16,NLIB), > NTFG(NBISO),LSHI(NBISO),NIR(NBISO) LOGICAL MASKI(NBISO) @@ -238,8 +240,8 @@ ENDIF * * COMPUTE THE TRANSPORT XS AND ADD COMPLEMENTARY INFORMATION. - CALL LIBADD(IPLIB,NBIS,MASKI(IND1),IMPX,NGRO,NL,ITRANC, - 1 ISONAM(1,IND1),IPISO(IND1),NIR(IND1),GIR(IND1)) + CALL LIBADD(IPLIB,NBIS,MASKI(IND1),IMPX,NGRO,NL,ITRANC,NDEPL, + 1 ISONAM(1,IND1),ISONRF(1,IND1),IPISO(IND1),NIR(IND1),GIR(IND1)) ENDIF * IND1=IND1+NBIS diff --git a/Dragon/src/LIBND1.f b/Dragon/src/LIBND1.f index 7827a6a..e99a274 100644 --- a/Dragon/src/LIBND1.f +++ b/Dragon/src/LIBND1.f @@ -67,7 +67,7 @@ TYPE(C_PTR) KPLIB INTEGER I,I0,IERR,HEADER(16),NISOLB,NGFIS,NGTHER,MAXTMP,MAXDIL, 1 MAXTDN,MAXPN,NF,NP1,IND,IHEAD(200),NBTEM,NBDIL,ISOID,IG,IG1,NL2, - 2 IJ,IM,IMX,IOF,J,ITYPRO(2) + 2 IJ,IM,IMX,IOF,J,ITYPRO(2),LENGT,ITYLCM REAL RHEAD(200),WW,SUM DOUBLE PRECISION XDRCST,ANEUT CHARACTER TEXT8*8,HSMG*131,HNAMIS*12,HNISOR*12 @@ -258,6 +258,10 @@ GAR1(NGF+1:NGRO,7)=0.0 CALL LCMPUT(KPLIB,'N2N',NGRO,2,GAR1(1,7)) * +* H-FACTOR + CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') +* * P0 differential scattering XS CALL XSDISO(7002,5015,IND,LOAD,IERR) GAR1(:NGRO,5)=0.0 diff --git a/Dragon/src/LIBSUB.f b/Dragon/src/LIBSUB.f index 63095de..12adc45 100644 --- a/Dragon/src/LIBSUB.f +++ b/Dragon/src/LIBSUB.f @@ -129,6 +129,7 @@ *---- CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR) NL=IPAR(4) + NDEPL=IPAR(11) NED=IPAR(13) NDEL=IPAR(19) IF(NED.GT.0) THEN @@ -185,6 +186,15 @@ * FIND THE DILUTION VALUES. NDIL=0 CALL LCMOP(IPTMP,'*TEMPORARY*',0,1,0) + IF(NDEPL.GT.0) THEN + CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILENG,ITYLCM) + IF(ILENG.EQ.0)CALL XABORT('LIBSUB: MISSING DEPL-CHAIN DATA.') + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMSIX(IPTMP,'DEPL-CHAIN',1) + CALL LCMEQU(IPLIB,IPTMP) + CALL LCMSIX(IPTMP,' ',2) + CALL LCMSIX(IPLIB,' ',2) + ENDIF WRITE(HNISOR,'(3A4)') (ISONRF(I0,ISOT),I0=1,3) WRITE(NAMLBT,'(2A4)') IHLIB(1,ISOT,1),IHLIB(2,ISOT,1) ALLOCATE(INAME(16*NLIB)) diff --git a/Dragon/src/LIBWD4.f b/Dragon/src/LIBWD4.f index 4262efa..e65ff05 100644 --- a/Dragon/src/LIBWD4.f +++ b/Dragon/src/LIBWD4.f @@ -49,10 +49,10 @@ *---- TYPE(C_PTR) IPLIB,IPISO(NBISO) INTEGER NDPROC - PARAMETER (NDPROC=10) + PARAMETER (NDPROC=11) INTEGER IPRINT,NGROUP,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), > ISHINA(3,NBISO),NGF,NGFR - CHARACTER NAMFIL*8,NAMDXS(NDPROC)*6 + CHARACTER NAMFIL*8,NAMDXS(NDPROC)*8 LOGICAL MASKI(NBISO) REAL TN(NBISO),SN(NGROUP,NBISO),SB(NGROUP,NBISO) *---- @@ -116,12 +116,11 @@ *---- * DATA *---- - SAVE NBATOM,NAMDXS - DATA NBATOM - > /1,2,16,12/ - DATA NAMDXS - > /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', - > 'NU ','NG ','N2N ','NGOLD ','NWT0 '/ + SAVE NBATOM,NAMDXS + DATA NBATOM /1,2,16,12/ + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF ','NFTOT ', + > 'CHI ','NU ','NG ','N2N ', + > 'NGOLD ','NWT0 ','H-FACTOR'/ *---- * SCRATCH STORAGE ALLOCATION * ITYPRO cross section processed diff --git a/Dragon/src/LIBWE.f b/Dragon/src/LIBWE.f index b37f331..a68f198 100644 --- a/Dragon/src/LIBWE.f +++ b/Dragon/src/LIBWE.f @@ -49,10 +49,10 @@ *---- TYPE(C_PTR) IPLIB,IPISO(NBISO) INTEGER NDPROC - PARAMETER (NDPROC=10) + PARAMETER (NDPROC=11) INTEGER IPRINT,NGROUP,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), > ISHINA(3,NBISO),NGF,NGFR - CHARACTER NAMFIL*8,NAMDXS(NDPROC)*6 + CHARACTER NAMFIL*8,NAMDXS(NDPROC)*8 LOGICAL MASKI(NBISO) REAL TN(NBISO),SN(NGROUP,NBISO),SB(NGROUP,NBISO) *---- @@ -115,10 +115,10 @@ *---- * DATA *---- - SAVE NAMDXS - DATA NAMDXS - > /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', - > 'NU ','NG ','N2N ','NGOLD ','NWT0 '/ + SAVE NAMDXS + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF ','NFTOT ', + > 'CHI ','NU ','NG ','N2N ', + > 'NGOLD ','NWT0 ','H-FACTOR'/ *---- * SCRATCH STORAGE ALLOCATION * ITYPRO cross section processed diff --git a/Dragon/src/LIBWIM.f b/Dragon/src/LIBWIM.f index b70c13d..a6ff486 100644 --- a/Dragon/src/LIBWIM.f +++ b/Dragon/src/LIBWIM.f @@ -47,7 +47,7 @@ * SUBROUTINE ARGUMENTS *---- INTEGER NDPROC - PARAMETER (NDPROC=10) + PARAMETER (NDPROC=11) TYPE(C_PTR) IPLIB,IPISO(NBISO) INTEGER IPRINT,NGROUP,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO), > ISHINA(3,NBISO),NGF,NGFR @@ -67,7 +67,7 @@ *---- * LOCAL VARIABLES *---- - CHARACTER NAMDXS(NDPROC)*6,HNAMIS*12,HNISOR*12,HSHIR*8, + CHARACTER NAMDXS(NDPROC)*8,HNAMIS*12,HNISOR*12,HSHIR*8, > README*96,FMT*6 INTEGER IHGAR(24),IP1,NPROC,IUNIT,KDROPN,II,NEL,NGR,NGTHER, > MXSCT,NGX,IG,ILOCX,ILOCY,ILOCS,NRDT,JSO,ITC,IDRES,IEL, @@ -133,8 +133,9 @@ * DATA *---- SAVE NAMDXS - DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', - > 'NU ','NG ','N2N ','NGOLD ','NWT0 '/ + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF ','NFTOT ', + > 'CHI ','NU ','NG ','N2N ', + > 'NGOLD ','NWT0 ','H-FACTOR'/ *---- * SCRATCH STORAGE ALLOCATION * ITYPRO cross section processed diff --git a/Dragon/src/LIBXS2.f b/Dragon/src/LIBXS2.f index 2fdd82c..403f1ed 100644 --- a/Dragon/src/LIBXS2.f +++ b/Dragon/src/LIBXS2.f @@ -53,7 +53,6 @@ PARAMETER (IOUT=6) CHARACTER TEXT20*20,TEXT12*12,HNISOR*20,HITNAM*20,HSMG*131 DOUBLE PRECISION DBLINP - REAL E458(9) *---- * SCRATCH STORAGE ALLOCATION *---- @@ -115,19 +114,15 @@ CALL LCMLEN(IPAP,'EGAMM',NV,ITYLCM) IF(NV.NE.0) THEN KPAX(NEL+3,ISO)=1 - CALL LCMGET(IPAP,'EGAMM',BPAX(NEL+3,ISO)) ENDIF * FISSION ENERGIES. CALL LCMLEN(IPAP,'EF',NV,ITYLCM) IF(NV.NE.0) THEN KPAX(NEL+2,ISO)=1 - CALL LCMGET(IPAP,'EF',BPAX(NEL+2,ISO)) ENDIF CALL LCMLEN(IPAP,'ENER_458',NV,ITYLCM) IF(NV.NE.0) THEN KPAX(NEL+2,ISO)=1 - CALL LCMGET(IPAP,'ENER_458',E458) - BPAX(NEL+2,ISO)=E458(8) ENDIF * RADIOACTIVE DECAY CONSTANTS. CALL LCMLEN(IPAP,'LAMBD0',NCHANN,ITYLCM) diff --git a/Dragon/src/LIBXS4.f b/Dragon/src/LIBXS4.f index 6debb37..459809d 100644 --- a/Dragon/src/LIBXS4.f +++ b/Dragon/src/LIBXS4.f @@ -68,20 +68,20 @@ CHARACTER TEXT20*20,TEXT80*80,HNAMIS*12,HNISOR*12,HNISSS*12, 1 HSMG*131,TEXT2*2,TEXT12*12 LOGICAL LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,L104,LABS,LDIF, - 1 LFIS,LPWD,LPED + 1 LFIS,LPWD,LPED,LH INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG DOUBLE PRECISION UU,XDRCST INTEGER ITHOMO(MAXHOM),ITEXT(20) - REAL TKT(5) + REAL TKT(5),E458(9) *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,NOM,NOMS,ISECTT, - 1 IFDG,IIAD,IDEPL + 1 IFDG,IIAD,IDEPL,IPR2 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, 1 DELTF,SIGTF,SIGAF,SIGFF,ENER,AMASS,TEMP,TEMPS,SEQHO,PWD,PED,DKA, - 2 DKD,DKF,DK104 + 2 DKD,DKF,DK104,HFACT REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,CHID REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE @@ -89,7 +89,7 @@ *---- * SCRATCH STORAGE ALLOCATION *---- - ALLOCATE(IPR(2,NBISO),ITYPRO(NL),NFS(NGRO)) + ALLOCATE(IPR(2,NBISO),IPR2(NBISO),ITYPRO(NL),NFS(NGRO)) ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL), 1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) * @@ -180,6 +180,7 @@ WRITE (HSMG,780) HNISOR,NAMFIL CALL XABORT(HSMG) 20 IPR(1,IMX)=KISO + IPR2(IMX)=KISO * IF((NISOTS.GT.0).AND.(HNISSS.NE.' ')) THEN KISO=0 @@ -199,8 +200,8 @@ ENDIF ENDIF 50 CONTINUE - DEALLOCATE(NOM) IF(NISOTS.GT.0) DEALLOCATE(NOMS) + DEALLOCATE(NOM) CALL KDRCPU(TK2) TKT(1)=TK2-TK1 *---- @@ -877,7 +878,6 @@ ENDIF CALL LCMSIX(IPAP,' ',2) ! QFIXS 560 CONTINUE - CALL LCMCL(IPAP,1) *---- * CHECK IF ALL REACTIONS HAVE BEEN PROCESSED. *---- @@ -891,11 +891,15 @@ 575 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,5) *---- -* ADD NG CROSS SECTIONS. +* LOOP OVER ISOTOPES *---- + CALL LCMSIX(IPAP,'QFIX',1) DO 610 IMX=1,NBISO IF(MASKI(IMX)) THEN KPLIB=IPISO(IMX) ! set IMX-th isotope +*---- +* PROCESS NG INFORMATION +*---- CALL LCMGET(KPLIB,'NTOT0',SECT) CALL LCMLEN(KPLIB,'SIGS00',LENGT,ITYLCM) IF(LENGT.EQ.NGRO) THEN @@ -919,14 +923,65 @@ 600 CONTINUE ENDIF CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT) +*---- +* PROCESS H-FACTOR INFORMATION +*---- + CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') + ISO=IPR2(IMX) + IF(ISO.EQ.0) CYCLE + WRITE(TEXT12,'(4HISOT,I8.8)') ISO + CALL LCMSIX(IPAP,TEXT12,1) + CALL LCMSIX(IPAP,'ISOTOP',1) + LH=.FALSE. + VALUE=0.0 + ALLOCATE(HFACT(NGRO)) + HFACT(:NGRO)=0.0 +* NG ENERGY. + CALL LCMLEN(IPAP,'EGAMM',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMGET(IPAP,'EGAMM',VALUE) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NG',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + ENDIF +* FISSION ENERGIES. + CALL LCMLEN(IPAP,'EF',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMGET(IPAP,'EF',VALUE) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NFTOT',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + GO TO 605 + ENDIF + ENDIF + CALL LCMLEN(IPAP,'ENER_458',NV,ITYLCM) + IF(NV.NE.0) THEN + CALL LCMGET(IPAP,'ENER_458',E458) + VALUE=E458(8) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NFTOT',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + ENDIF + 605 IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT) + DEALLOCATE(HFACT) + CALL LCMSIX(IPAP,' ',2) ! ISOTOP + CALL LCMSIX(IPAP,' ',2) ! TEXT12 ENDIF 610 CONTINUE + CALL LCMSIX(IPAP,' ',2) ! QFIX + CALL LCMCL(IPAP,1) *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(AMASS) DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG) - DEALLOCATE(NFS,ITYPRO,IPR) + DEALLOCATE(NFS,ITYPRO,IPR2,IPR) RETURN * 780 FORMAT(26HLIBXS4: MATERIAL/ISOTOPE ',A12,20H' IS MISSING ON APOL, diff --git a/Dragon/src/TRAXS.f b/Dragon/src/TRAXS.f index 7a077ca..3588589 100644 --- a/Dragon/src/TRAXS.f +++ b/Dragon/src/TRAXS.f @@ -54,7 +54,6 @@ DO ICOPY=1,NCOPY1 TEXT12=TCOPY1(ICOPY) CALL LCMLEN(IPMAC2,TEXT12,ILONG,ITYLCM) - print *,'TRAXS: transpose=',TEXT12,' ILONG=',ILONG IF(ILONG.GT.0) THEN CALL LCMGET(IPMAC2,TEXT12,GAR1) ALLOCATE(XIOF(ILONG)) diff --git a/Dragon/src/XDRLGS.f b/Dragon/src/XDRLGS.f index e91b8f6..cb21321 100644 --- a/Dragon/src/XDRLGS.f +++ b/Dragon/src/XDRLGS.f @@ -66,7 +66,7 @@ INTEGER NPROC,IGAR(MAXGAR),IODIV,LONG,ITYP,LONG2,ILEG, > IXSR,IXSTN,IG,JG,NXSCMP,IGTO,IGMIN,IGMAX,IGFROM CHARACTER*12 NAMXS - CHARACTER NAMLEG*2,NORD*6,HCM(0:10)*2 + CHARACTER NAMLEG*2,NORD*4,HCM(0:10)*2 INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ REAL, ALLOCATABLE, DIMENSION(:) :: XSSCMP DATA HCM /'00','01','02','03','04','05','06','07','08', @@ -78,13 +78,13 @@ * IODIV=0 IF(IORD.EQ.1) THEN - NORD=' ' + NORD=' ' IODIV=1 ELSE IF(IORD.EQ.2) THEN - NORD=' LIN' + NORD=' LIN' IODIV=2 ELSE IF(IORD.EQ.3) THEN - NORD=' QUA' + NORD=' QUA' IODIV=4 ENDIF NPROC=MAXLEG-MINLEG+1 @@ -265,14 +265,14 @@ IXSR=IXSR+1 IXSTN=MOD(ITYPRO(ILEG)/IODIV,2) IF(IXSTN.NE.0) THEN - WRITE(NAMXS,'(A4,I2.2,A6)') 'SIGS',ILEG-1,NORD + WRITE(NAMXS,'(A4,I2.2,2X,A4)') 'SIGS',ILEG-1,NORD WRITE(IOUT,6000) NAMXS WRITE(IOUT,6010) (XSREC(IG,IXSR),IG=1,NGROUP) *---- * SCAT(IGTO,IGFROM) REPRESENT SCATTERING CROSS SECTION * FROM GROUP "IGFROM" TO GROUP "IGTO" *---- - WRITE(NAMXS,'(A4,I2.2,A6)') 'SCAT',ILEG-1,NORD + WRITE(NAMXS,'(A4,I2.2,2X,A4)') 'SCAT',ILEG-1,NORD WRITE(IOUT,6000) NAMXS DO IGFROM=1,NGROUP WRITE(IOUT,6001) IGFROM diff --git a/Dragon/src/XDRLXS.f b/Dragon/src/XDRLXS.f index d49a89f..08e416a 100644 --- a/Dragon/src/XDRLXS.f +++ b/Dragon/src/XDRLXS.f @@ -43,23 +43,20 @@ TYPE(C_PTR) IPLIB INTEGER IGS,IPRINT,NPROC,IORD,NGROUP REAL XSREC(NGROUP,NPROC) - CHARACTER NAMDXS(NPROC)*6,NORD*6 + CHARACTER NAMDXS(NPROC)*8,NORD*4 *---- * LOCAL VARIABLES *---- INTEGER IOUT PARAMETER (IOUT=6) - INTEGER IODIV,IXSR,IG,JG,ILENG,ITYLCM + INTEGER IXSR,IG,JG,ILENG,ITYLCM * IF(IORD.EQ.1) THEN - NORD=' ' - IODIV=1 + NORD=' ' ELSE IF(IORD.EQ.2) THEN - NORD=' LIN' - IODIV=2 + NORD=' LIN' ELSE IF(IORD.EQ.3) THEN - NORD=' QUA' - IODIV=4 + NORD=' QUA' ENDIF IF(NPROC.LE.0) THEN CALL XABORT('XDRLXS: ZERO OR NEGATIVE VALUE OF NPROC') @@ -69,11 +66,13 @@ *---- * SAVE LOCAL DEFAULT XS IF REQUIRED *---- -* +! CALL LCMLEN(IPLIB,'H-FACTOR',ILENG,ITYLCM) +! IF(ILENG.NE.0) CALL LCMDEL(IPLIB,'H-FACTOR') DO 100 IXSR=1,NPROC *---- * FIND IF XS NOT ALL 0.0 *---- + IF(NAMDXS(IXSR).EQ.'H-FACTOR') GO TO 115 DO 110 IG=1,NGROUP IF(XSREC(IG,IXSR).NE.0.0) GO TO 115 110 CONTINUE diff --git a/Dragon/src/g2s_convert.f90 b/Dragon/src/g2s_convert.f90 index 1f28bb0..10e4e11 100644 --- a/Dragon/src/g2s_convert.f90 +++ b/Dragon/src/g2s_convert.f90 @@ -377,7 +377,6 @@ subroutine g2s_convert(impx,ipAl,ipZa,ipSal) read(ipAl,'(10i7)',end=100) (idummy, i=1,nbNode) read(ipAl,'(a12)') text12 if (text12 == ' ') read(ipAl,'(a12)') text12 - print *,'read=',text12 if (text12 /= ' Fin:') call XABORT('g2s_convert: keyword Fin: expected.') ! ! set nbfold |