Initial commit from Polytechnique Montreal

1 files changed, 451 insertions, 0 deletions

diff --git a/Donjon/src/PCRMAC.f b/Donjon/src/PCRMAC.f
new file mode 100644
index 0000000..06cf5af
--- /dev/null
+++ b/Donjon/src/PCRMAC.f
@@ -0,0 +1,451 @@
+*DECK PCRMAC
+      SUBROUTINE PCRMAC(MAXNIS,IPMAC,IACCS,NMIX,NGRP,NGFF,IMPX,NCAL,
+     1 TERP,NISO,HISO,CONC,LMIXC,XS_CALC,B2)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build the macrolib by scanning the NCAL elementary calculations and
+* weighting them with TERP factors.
+*
+*Copyright:
+* Copyright (C) 2019 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* A. Hebert
+*
+*Parameters: input
+* MAXNIS  maximum value of NISO(I) in user data.
+* IPMAC   address of the output macrolib LCM object.
+* IACCS   =0 macrolib is created; =1 ... is updated.
+* NMIX    maximum number of material mixtures in the macrolib.
+* NGRP    number of energy groups.
+* NGFF    number of group form factors per energy group.
+* IMPX    print parameter (equal to zero for no print).
+* NCAL    number of elementary calculations in the PMAXS file.
+* TERP    interpolation factors.
+* NISO    number of user-selected isotopes.
+* HISO    name of the user-selected isotopes.
+* CONC    user-defined number density of the user-selected isotopes.
+* LMIXC   flag set to .true. for fuel-map mixtures to process.
+* XS_CALC pointers towards PMAXS elementary calculations.
+* B2      buckling
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE PCRDATA
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMAC
+      INTEGER MAXNIS,IACCS,NMIX,NGRP,NGFF,IMPX,NCAL,NISO(NMIX),
+     1 HISO(2,NMIX,MAXNIS)
+      REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2
+      LOGICAL LMIXC(NMIX)
+      TYPE(XSBLOCK_ITEM) XS_CALC(NCAL)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER, PARAMETER::IOUT=6
+      INTEGER, PARAMETER::MAXED=30
+      INTEGER, PARAMETER::MAX1D=40
+      INTEGER, PARAMETER::MAX2D=20
+      INTEGER, PARAMETER::MAXIFX=5
+      INTEGER, PARAMETER::MAXNFI=50
+      INTEGER, PARAMETER::MAXNL=6
+      INTEGER, PARAMETER::MAXRES=MAX1D-10
+      INTEGER, PARAMETER::NSTATE=40
+      REAL FLOTVA, WEIGHT
+      INTEGER I0, I1D, I2D, IBM, ICAL, IDEL, IDF, IED, IGMAX, IGMIN,
+     & IGR, ILONG, IL, IPOSDE, ISO, ITRAN, ITSTMP, ITYLCM, I, JGR,
+     & KSO1, KSO, MAXMIX, N1D, N2D, NBISO, NDEL, NED,NF, NL, NTYPE
+      INTEGER ISTATE(NSTATE),NFINF,IACCOLD
+      REAL TMPDAY(3)
+      LOGICAL LMAKE1(MAX1D),LMAKE2(MAX2D),LFAST
+      CHARACTER TEXT8*8,TEXT12*12,HHISO*8,CM*2,HMAK1(MAX1D)*12,
+     1 HMAK2(MAX2D)*12,HVECT(MAXED)*8
+      TYPE(C_PTR) IPTMP,JPTMP,KPTMP,JPMAC,KPMAC
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,ISOMI
+      REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,XVOLM,WORK1,WORK2
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUX
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GAR2,GAR3
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKL
+      INTEGER, POINTER, DIMENSION(:) :: ISONA
+      REAL, POINTER, DIMENSION(:) :: DENIS,FLOT
+      TYPE(C_PTR) ISONA_PTR,DENIS_PTR,FLOT_PTR
+      DATA HMAK1 / 'FLUX-INTG','NTOT0','OVERV','DIFF','DIFFX','DIFFY',
+     1             'DIFFZ','FLUX-INTG-P1','NTOT1','H-FACTOR',MAXRES*' '/
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(IJJ(NMIX),NJJ(NMIX),IPOS(NMIX))
+      ALLOCATE(FLUX(NGRP,2),GAR1(NMIX,NGRP,MAX1D),
+     1 GAR2(NMIX,MAXNFI,NGRP,MAX2D),GAR3(NMIX,NGRP,NGRP,MAXNL),
+     2 GAR4(NMIX*NGRP))
+*
+      IACCOLD=IACCS ! for ADF and GFF 
+      NTYPE=0
+      NFINF=0
+*----
+*  MACROLIB INITIALIZATION
+*----
+      IF(IACCS.EQ.0) THEN
+*        PMAXS values:
+         NL=1
+         NF=0
+         ITRAN=0
+         NDEL=NDLAY
+*         IDF=NTDF
+*         NGFF=NRODS
+         IDF=0
+         NGFF=0
+         NED=1
+         HVECT(1)='H-FACTOR'
+         IF(NXST.GE.7) THEN
+           NED=2
+           HVECT(2)='NFTOT'
+         ENDIF
+         IF(NXST.EQ.8) THEN
+           NED=3
+           HVECT(3)='DETEC'
+         ENDIF
+         TEXT12='L_MACROLIB'
+         CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12)
+         ISTATE(:NSTATE)=0
+         ISTATE(1)=NGRP
+         ISTATE(2)=NMIX
+         ISTATE(3)=NL
+         ISTATE(5)=NED
+         ISTATE(6)=ITRAN
+         ISTATE(7)=NDEL
+         ISTATE(12)=IDF
+         ISTATE(16)=NGFF
+         CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE)
+         CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT)
+      ELSE
+         CALL LCMGTC(IPMAC,'SIGNATURE',12,TEXT12)
+         IF(TEXT12.NE.'L_MACROLIB') THEN
+          CALL XABORT('PCRMAC: SIGNATURE IS '//TEXT12//'. L_MACROLIB E'
+     1    //'XPECTED.')
+         ENDIF
+         CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+         IF(ISTATE(1).NE.NGRP) THEN
+            CALL XABORT('PCRMAC: INVALID NUMBER OF ENERGY GROUPS(2).')
+         ELSE IF(ISTATE(2).NE.NMIX) THEN
+            CALL XABORT('PCRMAC: INVALID NUMBER OF MIXTURES(2).')
+         ENDIF
+         NL=ISTATE(3)
+         NF=ISTATE(4)
+         NED=ISTATE(5)
+         NDEL=ISTATE(7)
+         IDF=ISTATE(12)
+         NGFF=ISTATE(16)
+         IF(NED.GT.MAXED) CALL XABORT('PCRMAC: MAXED OVERFLOW(2).')
+         IF(NED.GT.0) CALL LCMGTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT)
+         IF(IDF.EQ.1) THEN
+           NTYPE=1
+         ELSE IF((IDF.EQ.3).AND.(IACCOLD.NE.0)) THEN
+           CALL LCMSIX(IPMAC,'ADF',1)
+           CALL LCMGET(IPMAC,'NTYPE',NTYPE)
+           CALL LCMSIX(IPMAC,' ',2)
+         ENDIF
+         IF((NGFF.NE.0).AND.(IACCOLD.NE.0)) THEN
+           CALL LCMSIX(IPMAC,'GFF',1)
+           CALL LCMLEN(IPMAC,'FINF_NUMBER ',NFINF,ITYLCM)
+           IF(NFINF.GT.MAXIFX) CALL XABORT('PCRMAC: MAXIFX OVERFLOW.')
+           CALL LCMSIX(IPMAC,' ',2)
+         ENDIF
+      ENDIF
+      N1D=10+NED+NL
+      N2D=2*(NDEL+1)
+      IF(NL.GT.MAXNL) CALL XABORT('PCRMAC: MAXNL OVERFLOW.')
+      IF(N1D.GT.MAX1D) CALL XABORT('PCRMAC: MAX1D OVERFLOW.')
+      IF(N2D.GT.MAX2D) CALL XABORT('PCRMAC: MAX2D OVERFLOW.')
+      LMAKE1(:N1D)=.FALSE.
+      LMAKE2(:N2D)=.FALSE.
+      GAR1(:NMIX,:NGRP,:N1D)=0.0
+      GAR2(:NMIX,:MAXNFI,:NGRP,:N2D)=0.0
+      GAR3(:NMIX,:NGRP,:NGRP,:NL)=0.0
+      DO 20 IED=1,NED
+      HMAK1(10+IED)=HVECT(IED)
+   20 CONTINUE
+      DO 30 IL=1,NL
+      WRITE(CM,'(I2.2)') IL-1
+      HMAK1(10+NED+IL)='SIGS'//CM
+   30 CONTINUE
+      HMAK2(1)='NUSIGF'
+      HMAK2(2)='CHI'
+      DO 40 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
+   40 CONTINUE
+*----
+*  READ EXISTING MACROLIB INFORMATION
+*----
+      ALLOCATE(XVOLM(NMIX))
+      XVOLM(:NMIX)=0.0
+      IF(IACCS.NE.0) THEN   ! IACCS
+        CALL LCMGET(IPMAC,'VOLUME',XVOLM)
+        JPMAC=LCMGID(IPMAC,'GROUP')
+        DO 80 IGR=1,NGRP
+        KPMAC=LCMGIL(JPMAC,IGR)
+        DO 60 I1D=1,N1D
+        CALL LCMLEN(KPMAC,HMAK1(I1D),ILONG,ITYLCM)
+        IF(ILONG.NE.0) THEN
+          LMAKE1(I1D)=.TRUE.
+          CALL LCMGET(KPMAC,HMAK1(I1D),GAR1(1,IGR,I1D))
+          DO 50 IBM=1,NMIX
+          IF(LMIXC(IBM)) GAR1(IBM,IGR,I1D)=0.0
+   50     CONTINUE
+        ENDIF
+   60   CONTINUE
+        DO 65 I2D=1,N2D
+        CALL LCMLEN(KPMAC,HMAK2(I2D),ILONG,ITYLCM)
+        IF(ILONG.NE.0) THEN
+          LMAKE2(I2D)=.TRUE.
+          CALL LCMGET(KPMAC,HMAK2(I2D),GAR2(1,1,IGR,I2D))
+          DO 64 I=1,NF
+          DO 63 IBM=1,NMIX
+          IF(LMIXC(IBM)) GAR2(IBM,I,IGR,I2D)=0.0
+   63     CONTINUE
+   64     CONTINUE
+        ENDIF
+   65   CONTINUE
+        DO 75 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 71 IBM=1,NMIX
+          IPOSDE=IPOS(IBM)
+          DO 70 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1
+          GAR3(IBM,JGR,IGR,IL)=GAR4(IPOSDE)
+          IF(LMIXC(IBM)) GAR3(IBM,JGR,IGR,IL)=0.0
+          IPOSDE=IPOSDE+1
+   70     CONTINUE
+   71     CONTINUE
+        ENDIF
+   75   CONTINUE
+   80   CONTINUE
+      ENDIF   ! IACCS
+*----
+*  OVERALL ELEMENTARY CALCULATION LOOP
+*----
+      LFAST=.TRUE.
+      DO 85 IBM=1,NMIX
+      LFAST=LFAST.AND.((.NOT.LMIXC(IBM)).OR.(NISO(IBM).EQ.0))
+   85 CONTINUE
+      DO 210 ICAL=1,NCAL
+      IPTMP=C_NULL_PTR
+      DO 200 IBM=1,NMIX
+      WEIGHT=TERP(ICAL,IBM)
+      IF((.NOT.LMIXC(IBM)).OR.(WEIGHT.EQ.0.0)) GO TO 200
+*----
+*  PRODUCE AN ELEMENTARY MACROLIB (IF IPTMP=C_NULL_PTR)
+*----
+      IF(.NOT.C_ASSOCIATED(IPTMP)) THEN
+        CALL LCMOP(IPTMP,'*ELEMENTARY*',0,1,0)
+        CALL PCRONE(IMPX,ICAL,IPTMP,NCAL,NGRP,XS_CALC)
+        IF(IMPX.GT.0) THEN
+          WRITE(IOUT,'(33H PCRMAC: PMAXS ACCESS FOR MIXTURE,I8,5H AND ,
+     1    11HCALCULATION,I8,9H. WEIGHT=,1P,E12.4)') IBM,ICAL,WEIGHT
+          IF(IMPX.GT.50) CALL LCMLIB(IPTMP)
+        ENDIF
+        CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE)
+        NBISO=ISTATE(2)
+        IF(ISTATE(1).NE.1) CALL XABORT('PCRMAC: INVALID NUMBER OF MATE'
+     1  //'RIAL MIXTURES IN THE PMAXS FILE.')
+        IF(ISTATE(3).NE.NGRP) CALL XABORT('PCRMAC: INVALID NUMBER OF E'
+     1  //'NERGY GROUPS IN THE PMAXS FILE.')
+        ALLOCATE(MASKL(NGRP))
+        MASKL(:NGRP)=.TRUE.
+        CALL LCMGPD(IPTMP,'ISOTOPESUSED',ISONA_PTR)
+        CALL LCMGPD(IPTMP,'ISOTOPESDENS',DENIS_PTR)
+        CALL C_F_POINTER(ISONA_PTR,ISONA,(/ NBISO /))
+        CALL C_F_POINTER(DENIS_PTR,DENIS,(/ NBISO /))
+        DO 110 ISO=1,NBISO
+        WRITE(TEXT8,'(2A4)') (ISONA(3*(ISO-1)+I0),I0=1,2)
+        KSO1=0
+        DO 90 KSO=1,NISO(IBM) ! user-selected isotope
+        WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2)
+        IF(TEXT8.EQ.HHISO) THEN
+          KSO1=KSO
+          GO TO 100
+        ENDIF
+   90   CONTINUE
+  100   IF(KSO1.GT.0) DENIS(ISO)=CONC(IBM,KSO1)
+  110   CONTINUE
+        MAXMIX=1
+        ITSTMP=0
+        TMPDAY(1)=0.0
+        TMPDAY(2)=0.0
+        TMPDAY(3)=0.0
+        ALLOCATE(ISOMI(NBISO))
+        ISOMI(:NBISO)=1
+        CALL LIBMIX(IPTMP,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,
+     1              .TRUE.,MASKL,ITSTMP,TMPDAY)
+        CALL LCMPPD(IPTMP,'ISOTOPESDENS',NBISO,2,DENIS_PTR)
+        DEALLOCATE(ISOMI,MASKL)
+      ENDIF
+*----
+*  PERFORM INTERPOLATION
+*----
+      CALL LCMSIX(IPTMP,'MACROLIB',1)
+      CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE)
+      IF(NF.EQ.0) NF=ISTATE(4)
+      IF(NF.GT.MAXNFI) CALL XABORT('PCRMAC: MAXNFI OVERFLOW.')
+      IF(ISTATE(1).NE.NGRP) THEN
+         CALL XABORT('PCRMAC: INVALID NUMBER OF ENERGY GROUPS(3).')
+      ELSE IF(ISTATE(2).NE.1)THEN
+         CALL XABORT('PCRMAC: INVALID NUMBER OF MIXTURES(3).')
+      ELSE IF(ISTATE(3).NE.NL) THEN
+         CALL XABORT('PCRMAC: INVALID NUMBER OF LEGENDRE ORDERS(3).')
+      ELSE IF((ISTATE(4).NE.0).AND.(ISTATE(4).NE.NF)) THEN
+         CALL XABORT('PCRMAC: INVALID NUMBER OF FISSILE ISOTOPES(3).')
+      ELSE IF((ISTATE(5).NE.NED).AND.(ISTATE(5).GT.0)) THEN
+         CALL XABORT('PCRMAC: INVALID NUMBER OF EDIT REACTIONS(3).')
+      ELSE IF((ISTATE(7).NE.NDEL).AND.(ISTATE(7).GT.0)) THEN
+         CALL XABORT('PCRMAC: INVALID NUMBER OF PRECURSOR GROUPS(3).')
+      ENDIF
+      JPTMP=LCMGID(IPTMP,'GROUP')
+      DO 195 IGR=1,NGRP
+      KPTMP=LCMGIL(JPTMP,IGR)
+      DO 170 I1D=1,N1D
+      CALL LCMLEN(KPTMP,HMAK1(I1D),ILONG,ITYLCM)
+      IF(ILONG.NE.0) THEN
+        IF(ILONG.NE.1) CALL XABORT('PCRMAC: FLOTVA OVERFLOW.')
+        LMAKE1(I1D)=.TRUE.
+        CALL LCMGET(KPTMP,HMAK1(I1D),FLOTVA)
+        GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)+WEIGHT*FLOTVA
+      ENDIF
+  170 CONTINUE
+      IF(ISTATE(4).GT.0) THEN
+        DO 175 I2D=1,N2D
+        CALL LCMLEN(KPTMP,HMAK2(I2D),ILONG,ITYLCM)
+        IF(ILONG.NE.0) THEN
+          IF(ILONG.NE.NF) CALL XABORT('PCRMAC: FLOT OVERFLOW.')
+          LMAKE2(I2D)=.TRUE.
+          CALL LCMGPD(KPTMP,HMAK2(I2D),FLOT_PTR)
+          CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /))
+          DO 174 I=1,NF
+          GAR2(IBM,I,IGR,I2D)=GAR2(IBM,I,IGR,I2D)+WEIGHT*FLOT(I)
+  174     CONTINUE
+        ENDIF
+  175   CONTINUE
+      ENDIF
+      DO 190 IL=1,NL
+      WRITE(CM,'(I2.2)') IL-1
+      ILONG=1
+      IF(IL.GT.1) CALL LCMLEN(KPTMP,'SCAT'//CM,ILONG,ITYLCM)
+      IF(ILONG.NE.0) THEN
+        CALL LCMGET(KPTMP,'SCAT'//CM,GAR4)
+        CALL LCMGET(KPTMP,'NJJS'//CM,NJJ)
+        CALL LCMGET(KPTMP,'IJJS'//CM,IJJ)
+        CALL LCMGET(KPTMP,'IPOS'//CM,IPOS)
+        IPOSDE=IPOS(1)
+        DO 180 JGR=IJJ(1),IJJ(1)-NJJ(1)+1,-1
+        GAR3(IBM,JGR,IGR,IL)=GAR3(IBM,JGR,IGR,IL)+WEIGHT*GAR4(IPOSDE)
+        IPOSDE=IPOSDE+1
+  180   CONTINUE
+      ENDIF
+  190 CONTINUE
+  195 CONTINUE
+      CALL LCMSIX(IPTMP,' ',2)
+      IF(.NOT.LFAST) CALL LCMCL(IPTMP,2)
+  200 CONTINUE
+      IF(C_ASSOCIATED(IPTMP)) CALL LCMCL(IPTMP,2)
+  210 CONTINUE
+*----
+*  WRITE INTERPOLATED MACROLIB INFORMATION
+*----
+      CALL LCMPUT(IPMAC,'VOLUME',NMIX,2,XVOLM)
+      DEALLOCATE(XVOLM)
+      JPMAC=LCMLID(IPMAC,'GROUP',NGRP)
+      DO 370 IGR=1,NGRP
+      KPMAC=LCMDIL(JPMAC,IGR)
+      DO 320 I1D=1,N1D
+      IF(LMAKE1(I1D)) THEN
+        CALL LCMPUT(KPMAC,HMAK1(I1D),NMIX,2,GAR1(1,IGR,I1D))
+      ENDIF
+  320 CONTINUE
+      DO 325 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
+  325 CONTINUE
+      DO 360 IL=1,NL
+      WRITE(CM,'(I2.2)') IL-1
+      IPOSDE=0
+      DO 350 IBM=1,NMIX
+      IPOS(IBM)=IPOSDE+1
+      IGMIN=IGR
+      IGMAX=IGR
+      DO 330 JGR=1,NGRP
+      IF(GAR3(IBM,JGR,IGR,IL).NE.0.0) THEN
+        IGMIN=MIN(IGMIN,JGR)
+        IGMAX=MAX(IGMAX,JGR)
+      ENDIF
+  330 CONTINUE
+      IJJ(IBM)=IGMAX
+      NJJ(IBM)=IGMAX-IGMIN+1
+      DO 340 JGR=IGMAX,IGMIN,-1
+      IPOSDE=IPOSDE+1
+      GAR4(IPOSDE)=GAR3(IBM,JGR,IGR,IL)
+  340 CONTINUE
+  350 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
+  360 CONTINUE
+  370 CONTINUE
+      IACCS=1
+*----
+*  UPDATE STATE-VECTOR
+*----
+      CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+      ISTATE(4)=MAX(ISTATE(4),NF)
+      IF(LMAKE1(4)) ISTATE(9)=1
+      IF(LMAKE1(5)) ISTATE(9)=2
+      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(6,'(/34H PCRMAC: INCLUDE LEAKAGE IN THE MA,
+     1  11HCROLIB (B2=,1P,E12.5,2H).)') B2
+        JPMAC=LCMGID(IPMAC,'GROUP')
+        ALLOCATE(WORK1(NMIX),WORK2(NMIX))
+        DO 520 IGR=1,NGRP
+          KPMAC=LCMGIL(JPMAC,IGR)
+          CALL LCMGET(KPMAC,'NTOT0',WORK1)
+          CALL LCMGET(KPMAC,'DIFF',WORK2)
+          DO 510 IBM=1,NMIX
+            IF(LMIXC(IBM)) WORK1(IBM)=WORK1(IBM)+B2*WORK2(IBM)
+  510     CONTINUE
+          CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,WORK1)
+  520   CONTINUE
+        DEALLOCATE(WORK2,WORK1)
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(GAR4,GAR3,GAR2,GAR1,FLUX)
+      DEALLOCATE(IPOS,NJJ,IJJ)
+      RETURN
+      END