Initial commit from Polytechnique Montreal

1 files changed, 525 insertions, 0 deletions

diff --git a/Donjon/src/MCRMAC.f b/Donjon/src/MCRMAC.f
new file mode 100644
index 0000000..5c819da
--- /dev/null
+++ b/Donjon/src/MCRMAC.f
@@ -0,0 +1,525 @@
+*DECK MCRMAC
+      SUBROUTINE MCRMAC(IPMAC,IPMPO,IACCS,NMIL,NMIX,NGRP,LADFM,IMPX,
+     1 HEQUI,HMASL,NCAL,HEDIT,NSURFD,NALBP,ILUPS,MIXC,TERP,LPURE,B2)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build the Macrolib by scanning the NCAL elementary calculations of
+* a HDF5 file and weighting them with TERP factors.
+*
+*Copyright:
+* Copyright (C) 2022 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* A. Hebert
+*
+*Parameters: input
+* IPMAC   address of the output Macrolib LCM object.
+* IPMPO   pointer to the MPO file.
+* IACCS   =0 macrolib is created; =1 ... is updated.
+* NMIL    number of material mixtures in the MPO file.
+* NMIX    maximum number of material mixtures in the Macrolib.
+* NGRP    number of energy groups.
+* LADFM   type of discontinuity factors (.true.: diagonal; .false.: GxG).
+* IMPX    print parameter (equal to zero for no print).
+* HEQUI   keyword of SPH-factor set to be recovered.
+* HMASL   keyword of MASL data set to be recovered.
+* NCAL    number of elementary calculations in the MPO file.
+* HEDIT   name of output group for a (multigroup mesh, output geometry)
+*         couple (generally equal to 'output_0').
+* NSURFD  number of discontinuity factors.
+* NALBP   number of physical albedos per energy group.
+* ILUPS   up-scattering removing flag (=1 to remove up-scattering from
+*         output cross-sections).
+* MIXC    mixture index in the MPO file corresponding to each Microlib.
+*         mixture. Equal to zero if a Microlib mixture is not updated.
+* TERP    interpolation factors.
+* LPURE   =.true. if the interpolation is a pure linear interpolation 
+*         with TERP factors.
+* B2      buckling.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE hdf5_wrap
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMAC,IPMPO
+      INTEGER IACCS,NMIL,NMIX,NGRP,IMPX,NCAL,NSURFD,NALBP,ILUPS,
+     1 MIXC(NMIX)
+      REAL TERP(NCAL,NMIX),B2
+      LOGICAL LADFM,LPURE
+      CHARACTER(LEN=80) HEQUI,HMASL
+      CHARACTER(LEN=12) HEDIT
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER, PARAMETER::IOUT=6
+      INTEGER, PARAMETER::MAX1D=40
+      INTEGER, PARAMETER::MAX2D=20
+      INTEGER, PARAMETER::MAXED=30
+      INTEGER, PARAMETER::MAXNFI=1
+      INTEGER, PARAMETER::MAXNL=6
+      INTEGER, PARAMETER::NSTATE=40
+      INTEGER, PARAMETER::MAXRES=MAX1D-8
+      INTEGER I, J, I1D, I2D, IBM, IBMOLD, ICAL, IDEL, IDF, IED, IGMAX,
+     & IGMIN, IGR, JGR, IL, ILONG, IOF, IPOSDE, ITRANC, ITYLCM, LENGTH,
+     & N1D, N2D, NDEL, NED, NEDTMP, NF, NFTMP, NL, NLTMP, IMC, ID, ID_E,
+     & ID_G, NENERG, NGEOME, IACCOLD, NALBP2, RANK, NBYTE, TYPE,
+     & DIMSR(5)
+      REAL FLOTVA, WEIGHT, B2R
+      TYPE(C_PTR) JPMAC,KPMAC,IPTMP,JPTMP,KPTMP
+      INTEGER ISTATE(NSTATE)
+      LOGICAL LMAKE1(MAX1D),LMAKE2(MAX2D),LWD,LALBG
+      CHARACTER TEXT8*8,TEXT12*12,CM*2,HMAK1(MAX1D)*12,HMAK2(MAX2D)*12,
+     1 HVECT(MAXED)*8,RECNAM*80
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,IJJB,NJJB,IPOSB
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID
+      REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,GAR4B,WORK1,WORK2,VOLMI2,
+     1 ENERG,VOSAP,WDLA
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SPH
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GAR2,GAR3
+      REAL, POINTER, DIMENSION(:) :: FLOT
+      TYPE(C_PTR) FLOT_PTR
+*----
+*  DATA STATEMENTS
+*----
+      DATA HMAK1 / 'FLUX-INTG','NTOT0','OVERV','DIFF','FLUX-INTG-P1',
+     1 'NTOT1','H-FACTOR','TRANC',MAXRES*' '/
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(IJJ(NMIX),NJJ(NMIX),IPOS(NMIX),IJJB(NMIL),NJJB(NMIL),
+     1 IPOSB(NMIL))
+      ALLOCATE(GAR1(NMIX,NGRP,MAX1D),GAR2(NMIX,MAXNFI,NGRP,MAX2D),
+     1 GAR3(NMIX,NGRP,NGRP,MAXNL),GAR4(NMIX*NGRP),GAR4B(NMIL*NGRP),
+     2 VOLMI2(NMIX))
+      IACCOLD=IACCS ! for ADF
+*----
+*  MACROLIB INITIALIZATION
+*----
+      LMAKE1(:MAX1D)=.FALSE.
+      LMAKE2(:MAX2D)=.FALSE.
+      GAR1(:NMIX,:NGRP,:MAX1D)=0.0
+      GAR2(:NMIX,:MAXNFI,:NGRP,:MAX2D)=0.0
+      GAR3(:NMIX,:NGRP,:NGRP,:MAXNL)=0.0
+      VOLMI2(:NMIX)=0.0
+      IBMOLD=0
+      N1D=0
+      N2D=0
+      NDEL=0
+      NL=0
+      NF=0
+      NED=0
+      ITRANC=0
+      IDF=0
+      N1D=0
+      N2D=0
+*----
+*  READ EXISTING MACROLIB INFORMATION
+*----
+      IF(IACCS.EQ.0) THEN
+        TEXT12='L_MACROLIB'
+        CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12)
+      ELSE
+        CALL LCMGTC(IPMAC,'SIGNATURE',12,TEXT12)
+        IF(TEXT12.NE.'L_MACROLIB') THEN
+          CALL XABORT('MCRMAC: SIGNATURE OF INPUT MACROLIB IS '//TEXT12
+     1    //'. L_MACROLIB EXPECTED.')
+        ENDIF
+        CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+        IF(ISTATE(1).NE.NGRP) THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF ENERGY GROUPS(2).')
+        ELSE IF(ISTATE(2).NE.NMIX) THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF MIXTURES(2).')
+        ENDIF
+        NL=ISTATE(3)
+        NF=ISTATE(4)
+        IF(NF.GT.MAXNFI) CALL XABORT('MCRMAC: MAXNFI OVERFLOW(1).')
+        NED=ISTATE(5)
+        ITRANC=ISTATE(6)
+        NDEL=ISTATE(7)
+        IDF=ISTATE(12)
+        IF(NED.GT.MAXED) CALL XABORT('MCRMAC: MAXED OVERFLOW(1).')
+        CALL LCMGTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT)
+        N1D=8+NED+NL
+        N2D=2*(NDEL+1)
+        IF(NL.GT.MAXNL) CALL XABORT('MCRMAC: MAXNL OVERFLOW(1).')
+        IF(N1D.GT.MAX1D) CALL XABORT('MCRMAC: MAX1D OVERFLOW(1).')
+        IF(N2D.GT.MAX2D) CALL XABORT('MCRMAC: MAX2D OVERFLOW(1).')
+        DO 10 IED=1,NED
+        HMAK1(8+IED)=HVECT(IED)
+   10   CONTINUE
+        DO 20 IL=1,NL
+        WRITE(CM,'(I2.2)') IL-1
+        HMAK1(8+NED+IL)='SIGS'//CM
+   20   CONTINUE
+        HMAK2(1)='NUSIGF'
+        HMAK2(2)='CHI'
+        DO 30 IDEL=1,NDEL
+        WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL
+        HMAK2(2+2*(IDEL-1)+1)=TEXT8
+        WRITE(TEXT8,'(3HCHI,I2.2)') IDEL
+        HMAK2(2+2*(IDEL-1)+2)=TEXT8
+   30   CONTINUE
+        CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+        JPMAC=LCMGID(IPMAC,'GROUP')
+        DO 150 IGR=1,NGRP
+        KPMAC=LCMGIL(JPMAC,IGR)
+        DO 60 I1D=1,N1D
+        CALL LCMLEN(KPMAC,HMAK1(I1D),ILONG,ITYLCM)
+        IF(ILONG.NE.0) THEN
+          CALL LCMGET(KPMAC,HMAK1(I1D),GAR1(1,IGR,I1D))
+          DO 50 IBM=1,NMIX
+          DO 40 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=0.0
+   40     CONTINUE
+   50     CONTINUE
+        ENDIF
+   60   CONTINUE
+        DO 100 I2D=1,N2D
+        CALL LCMLEN(KPMAC,HMAK2(I2D),ILONG,ITYLCM)
+        IF(ILONG.NE.0) THEN
+          CALL LCMGET(KPMAC,HMAK2(I2D),GAR2(1,1,IGR,I2D))
+          DO 90 I=1,NF
+          DO 80 IBM=1,NMIX
+          DO 70 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR2(IBM,I,IGR,I2D)=0.0
+   70     CONTINUE
+   80     CONTINUE
+   90     CONTINUE
+        ENDIF
+  100   CONTINUE
+        DO 140 IL=1,NL
+        WRITE(CM,'(I2.2)') IL-1
+        ILONG=1
+        IF(IL.GT.1) CALL LCMLEN(KPMAC,'SCAT'//CM,ILONG,ITYLCM)
+        IF(ILONG.NE.0) THEN
+          CALL LCMGET(KPMAC,'SCAT'//CM,GAR4)
+          CALL LCMGET(KPMAC,'NJJS'//CM,NJJ)
+          CALL LCMGET(KPMAC,'IJJS'//CM,IJJ)
+          CALL LCMGET(KPMAC,'IPOS'//CM,IPOS)
+          DO 130 IBM=1,NMIX
+          IPOSDE=IPOS(IBM)
+          DO 120 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1
+          GAR3(IBM,JGR,IGR,IL)=GAR4(IPOSDE)
+          DO 110 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR3(IBM,JGR,IGR,IL)=0.0
+  110     CONTINUE
+          IPOSDE=IPOSDE+1
+  120     CONTINUE
+  130     CONTINUE
+        ENDIF
+  140   CONTINUE
+  150   CONTINUE
+      ENDIF
+*----
+*  SET ENERGY MESH AND ZONE VOLUMES
+*----
+      CALL hdf5_read_data(IPMPO,"/energymesh/NENERGYMESH",NENERG)
+      CALL hdf5_read_data(IPMPO,"/geometry/NGEOMETRY",NGEOME)
+      CALL hdf5_read_data(IPMPO,"/output/OUPUTID",OUPUTID)
+      READ(HEDIT,'(7X,I2)') ID
+      ID_G=0
+      ID_E=0
+      DO I=1,NGEOME
+        DO J=1,NENERG
+          IF(OUPUTID(J,I).EQ.ID) THEN
+            ID_G=I-1
+            ID_E=J-1
+            GO TO 160
+          ENDIF
+        ENDDO
+      ENDDO
+      CALL XABORT('MCRMAC: no ID found in /output/OUPUTID.')
+  160 WRITE(RECNAM,'(23H/energymesh/energymesh_,I0)') ID_E
+      CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"/ENERGY",ENERG)
+      IF(SIZE(ENERG,1)-1.NE.NGRP) CALL XABORT('MCRMAC: INVALID NGRP VA'
+     1 //'LUE.')
+      DO IGR=1,NGRP+1
+        ENERG(IGR)=ENERG(IGR)/1.0E-6
+      ENDDO
+      WRITE(RECNAM,'(19H/geometry/geometry_,I0,1H/)') ID_G
+      CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ZONEVOLUME",VOSAP)
+*----
+*  OVERALL ELEMENTARY CALCULATION LOOP
+*----
+      DO 300 ICAL=1,NCAL
+      DO 170 IBM=1,NMIX ! mixtures in Macrolib
+      WEIGHT=TERP(ICAL,IBM)
+      IF(WEIGHT.NE.0.0) GO TO 180
+  170 CONTINUE
+      GO TO 300
+*----
+*  PRODUCE AN ELEMENTARY MACROLIB
+*----
+  180 CALL LCMOP(IPTMP,'*ELEMENTARY*',0,1,0)
+      ALLOCATE(SPH(NMIL+NALBP,NGRP))
+      CALL LCMPUT(IPTMP,'ENERGY',NGRP+1,2,ENERG)
+      B2R=B2
+      CALL SPHMPO(IPMPO,IPTMP,ICAL,IMPX,HEQUI,HMASL,NMIL,NALBP,NGRP,
+     1 HEDIT,VOSAP,ILUPS,SPH,B2R)
+*----
+*  RECOVER MACROLIB PARAMETERS
+*----
+      CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE)
+      NLTMP=ISTATE(3)
+      NFTMP=ISTATE(4)
+      NEDTMP=ISTATE(5)
+      IF(NLTMP.GT.MAXNL) CALL XABORT('MCRMAC: MAXNL OVERFLOW(2).')
+      IF(NFTMP.GT.MAXNFI) CALL XABORT('MCRMAC: MAXNFI OVERFLOW(2).')
+      IF(NEDTMP.GT.MAXED) CALL XABORT('MCRMAC: MAXED OVERFLOW(2).')
+      IF(IACCS.EQ.0) THEN
+        IF(ISTATE(1).NE.NGRP) THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF ENERGY GROUPS(3).')
+        ELSE IF(ISTATE(2).NE.NMIL) THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF MIXTURES(3).')
+        ENDIF
+        NL=NLTMP
+        NF=NFTMP
+        NED=NEDTMP
+        ITRANC=ISTATE(6)
+        NDEL=ISTATE(7)
+        IDF=ISTATE(12)
+        CALL LCMGTC(IPTMP,'ADDXSNAME-P0',8,NED,HVECT)
+        N1D=8+NED+NL
+        N2D=2*(NDEL+1)
+        IF(N1D.GT.MAX1D) CALL XABORT('MCRMAC: MAX1D OVERFLOW(2).')
+        IF(N2D.GT.MAX2D) CALL XABORT('MCRMAC: MAX2D OVERFLOW(2).')
+        DO 190 IED=1,NED
+        HMAK1(8+IED)=HVECT(IED)
+  190   CONTINUE
+        DO 200 IL=1,NL
+        WRITE(CM,'(I2.2)') IL-1
+        HMAK1(8+NED+IL)='SIGS'//CM
+  200   CONTINUE
+        HMAK2(1)='NUSIGF'
+        HMAK2(2)='CHI'
+        DO 210 IDEL=1,NDEL
+        WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL
+        HMAK2(2+2*(IDEL-1)+1)=TEXT8
+        WRITE(TEXT8,'(3HCHI,I2.2)') IDEL
+        HMAK2(2+2*(IDEL-1)+2)=TEXT8
+  210   CONTINUE
+      ELSE
+        IF(NLTMP.GT.NL) CALL XABORT('MCRMAC: NL OVERFLOW.')
+        ITRANC=MAX(ITRANC,ISTATE(6))
+        IF(ISTATE(1).NE.NGRP) THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF ENERGY GROUPS(3).')
+        ELSE IF(ISTATE(2).NE.NMIL)THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF MIXTURES(3).')
+        ELSE IF((NFTMP.NE.0).AND.(NFTMP.NE.NF)) THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF FISSILE ISOTOPES(3).')
+        ELSE IF(ISTATE(7).NE.NDEL) THEN
+          CALL XABORT('MCRMAC: INVALID NUMBER OF PRECURSOR GROUPS(3).')
+        ELSE IF(LADFM.AND.(ISTATE(12).NE.IDF)) THEN
+          CALL XABORT('MCRMAC: INVALID TYPE OF ADF DIRECTORY.')
+        ENDIF
+      ENDIF
+*----
+*  SPH CORRECTION OF MACROLIB INFORMATION
+*----
+      IMC=1 ! SPH correction for SPN macro-calculation
+      CALL SPHCMA(IPTMP,IMPX,IMC,NMIL,NGRP,NFTMP,NEDTMP,NALBP,SPH)
+      DEALLOCATE(SPH)
+*----
+*  RECOVER VOLUMES, ENERGY GROUPS, EDIT NAMES, AND LAMBDA-D.
+*----
+      CALL LCMLEN(IPTMP,'VOLUME',ILONG,ITYLCM)
+      IF(ILONG.EQ.NMIL) THEN
+        DO 220 IBM=1,NMIX ! mixtures in Macrolib
+        IBMOLD=MIXC(IBM) ! mixture in MPO file
+        IF(IBMOLD.NE.0) VOLMI2(IBM)=VOSAP(IBMOLD)
+  220   CONTINUE
+      ENDIF
+      CALL LCMLEN(IPTMP,'ENERGY',ILONG,ITYLCM)
+      IF(ILONG.EQ.NGRP+1) CALL LCMGET(IPTMP,'ENERGY',ENERG)
+      CALL LCMLEN(IPTMP,'LAMBDA-D',LENGTH,ITYLCM)
+      LWD=(LENGTH.EQ.NDEL).AND.(NDEL.GT.0)
+      IF(LWD) THEN
+        ALLOCATE(WDLA(NDEL))
+        CALL LCMGET(IPTMP,'LAMBDA-D',WDLA)
+        CALL LCMPUT(IPMAC,'LAMBDA-D',NDEL,2,WDLA)
+        DEALLOCATE(WDLA)
+      ENDIF
+*----
+*  PERFORM INTERPOLATION
+*----
+      JPTMP=LCMGID(IPTMP,'GROUP')
+      DO 290 IBM=1,NMIX ! mixtures in Macrolib
+      WEIGHT=TERP(ICAL,IBM)
+      IF(WEIGHT.EQ.0.0) GO TO 290
+      IBMOLD=MIXC(IBM) ! mixture in MPO file
+      IF(IBMOLD.EQ.0) GO TO 290
+*
+      DO 280 IGR=1,NGRP
+      KPTMP=LCMGIL(JPTMP,IGR)
+      DO 230 I1D=1,N1D
+      CALL LCMLEN(KPTMP,HMAK1(I1D),ILONG,ITYLCM)
+      IF(ILONG.NE.0) THEN
+        CALL LCMGPD(KPTMP,HMAK1(I1D),FLOT_PTR)
+        CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /))
+        FLOTVA=FLOT(IBMOLD)
+        IF(FLOTVA.NE.0.0) LMAKE1(I1D)=.TRUE.
+        IF((.NOT.LPURE).AND.(I1D.EQ.4)) FLOTVA=1.0/FLOTVA
+        GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)+WEIGHT*FLOTVA
+      ENDIF
+  230 CONTINUE
+      IF(ISTATE(4).GT.0) THEN
+        DO 250 I2D=1,N2D
+        CALL LCMLEN(KPTMP,HMAK2(I2D),ILONG,ITYLCM)
+        IF(ILONG.NE.0) THEN
+          CALL LCMGPD(KPTMP,HMAK2(I2D),FLOT_PTR)
+          CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /))
+          DO 240 I=1,NF
+          IOF=(IBMOLD-1)*NF+I
+          IF(FLOT(IOF).NE.0.0) LMAKE2(I2D)=.TRUE.
+          GAR2(IBM,I,IGR,I2D)=GAR2(IBM,I,IGR,I2D)+WEIGHT*FLOT(IOF)
+  240     CONTINUE
+        ENDIF
+  250   CONTINUE
+      ENDIF
+      DO 270 IL=1,NLTMP
+      WRITE(CM,'(I2.2)') IL-1
+      CALL LCMLEN(KPTMP,'SCAT'//CM,ILONG,ITYLCM)
+      IF(ILONG.NE.0) THEN
+        CALL LCMGET(KPTMP,'SCAT'//CM,GAR4B)
+        CALL LCMGET(KPTMP,'NJJS'//CM,NJJB)
+        CALL LCMGET(KPTMP,'IJJS'//CM,IJJB)
+        CALL LCMGET(KPTMP,'IPOS'//CM,IPOSB)
+        IPOSDE=IPOSB(IBMOLD)
+        DO 260 JGR=IJJB(IBMOLD),IJJB(IBMOLD)-NJJB(IBMOLD)+1,-1
+        GAR3(IBM,JGR,IGR,IL)=GAR3(IBM,JGR,IGR,IL)+WEIGHT*GAR4B(IPOSDE)
+        IPOSDE=IPOSDE+1
+  260   CONTINUE
+      ENDIF
+  270 CONTINUE
+  280 CONTINUE
+  290 CONTINUE
+      CALL LCMCL(IPTMP,2)
+  300 CONTINUE
+*----
+*  WRITE INTERPOLATED MACROLIB INFORMATION
+*----
+      CALL LCMPUT(IPMAC,'VOLUME',NMIX,2,VOLMI2)
+      CALL LCMPUT(IPMAC,'ENERGY',NGRP+1,2,ENERG)
+      IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT)
+      JPMAC=LCMLID(IPMAC,'GROUP',NGRP)
+      DO 410 IGR=1,NGRP
+      KPMAC=LCMDIL(JPMAC,IGR)
+      DO 350 I1D=1,N1D
+      IF(LMAKE1(I1D)) THEN
+        IF((.NOT.LPURE).AND.(I1D.EQ.4)) THEN
+          DO 320 IBM=1,NMIX
+          DO 310 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=1./GAR1(IBM,IGR,I1D)
+  310     CONTINUE
+  320     CONTINUE
+        ELSE IF(I1D.EQ.7) THEN
+          DO 340 IBM=1,NMIX
+          DO 330 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)*
+     1    1.0E6 ! convert MeV to eV
+  330     CONTINUE
+  340     CONTINUE
+        ENDIF
+        CALL LCMPUT(KPMAC,HMAK1(I1D),NMIX,2,GAR1(1,IGR,I1D))
+      ENDIF
+  350 CONTINUE
+      DO 360 I2D=1,N2D
+      IF(LMAKE2(I2D).AND.(NF.GT.0)) THEN
+        CALL LCMPUT(KPMAC,HMAK2(I2D),NMIX*NF,2,GAR2(1,1,IGR,I2D))
+      ENDIF
+  360 CONTINUE
+      DO 400 IL=1,NL
+      WRITE(CM,'(I2.2)') IL-1
+      IPOSDE=0
+      DO 390 IBM=1,NMIX
+      IPOS(IBM)=IPOSDE+1
+      IGMIN=IGR
+      IGMAX=IGR
+      DO 370 JGR=1,NGRP
+      IF(GAR3(IBM,JGR,IGR,IL).NE.0.0) THEN
+        IGMIN=MIN(IGMIN,JGR)
+        IGMAX=MAX(IGMAX,JGR)
+      ENDIF
+  370 CONTINUE
+      IJJ(IBM)=IGMAX
+      NJJ(IBM)=IGMAX-IGMIN+1
+      DO 380 JGR=IGMAX,IGMIN,-1
+      IPOSDE=IPOSDE+1
+      GAR4(IPOSDE)=GAR3(IBM,JGR,IGR,IL)
+  380 CONTINUE
+  390 CONTINUE
+      IF(IPOSDE.GT.0) THEN
+        CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,GAR4)
+        CALL LCMPUT(KPMAC,'NJJS'//CM,NMIX,1,NJJ)
+        CALL LCMPUT(KPMAC,'IJJS'//CM,NMIX,1,IJJ)
+        CALL LCMPUT(KPMAC,'IPOS'//CM,NMIX,1,IPOS)
+        CALL LCMPUT(KPMAC,'SIGW'//CM,NMIX,2,GAR3(1,IGR,IGR,IL))
+      ENDIF
+  400 CONTINUE
+  410 CONTINUE
+      IACCS=1
+*----
+*  UPDATE STATE-VECTOR
+*----
+      ISTATE(2)=NMIX
+      ISTATE(3)=NL
+      ISTATE(4)=NF
+      ISTATE(5)=NED
+      ISTATE(6)=ITRANC
+      CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE)
+*----
+*  INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS)
+*----
+      IF(B2.NE.0.0) THEN
+        IF(IMPX.GT.0) WRITE(IOUT,'(/31H MCRMAC: INCLUDE LEAKAGE IN THE,
+     1  14H MACROLIB (B2=,1P,E12.5,2H).)') B2
+        JPMAC=LCMGID(IPMAC,'GROUP')
+        ALLOCATE(WORK1(NMIX),WORK2(NMIX))
+        DO 430 IGR=1,NGRP
+          KPMAC=LCMGIL(JPMAC,IGR)
+          CALL LCMGET(KPMAC,'NTOT0',WORK1)
+          CALL LCMGET(KPMAC,'DIFF',WORK2)
+          DO 420 IBM=1,NMIX
+            IF(MIXC(IBM).NE.0) WORK1(IBM)=WORK1(IBM)+B2*WORK2(IBM)
+  420     CONTINUE
+          CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,WORK1)
+  430   CONTINUE
+        DEALLOCATE(WORK2,WORK1)
+      ENDIF
+*----
+*  PROCESS ADF and physical albedos (if required)
+*----
+      LALBG=.TRUE.
+      IF(NALBP.GT.0) THEN
+        WRITE(RECNAM,'(8H/output/,A,16H/statept_0/flux/)') TRIM(HEDIT)
+        CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NALBP",NALBP2)
+        IF(NALBP2.NE.NALBP) CALL XABORT('MCRMAC: INVALID NALBP.')
+        CALL hdf5_info(IPMPO,TRIM(RECNAM)//"ALBEDOGxG",RANK,TYPE,NBYTE,
+     &  DIMSR)
+        IF(TYPE.NE.99) LALBG=.FALSE.
+      ENDIF
+      CALL MCRAGF(IPMAC,IPMPO,IACCOLD,NMIL,NMIX,NGRP,NALBP,LALBG,LADFM,
+     1 IMPX,NCAL,TERP,MIXC,NSURFD,HEDIT,VOSAP,VOLMI2,IDF)
+      IF(NSURFD.GT.0) THEN
+        CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+        ISTATE(12)=IDF ! ADF information
+        CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE)
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(VOSAP,ENERG)
+      DEALLOCATE(VOLMI2,GAR4B,GAR4,GAR3,GAR2,GAR1)
+      DEALLOCATE(IPOSB,NJJB,IJJB,IPOS,NJJ,IJJ)
+      RETURN
+      END