Resolve "Depreciate use of Version 4 and 5.0 Draglibs"

1 files changed, 17 insertions, 9 deletions

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))