Initial commit from Polytechnique Montreal

1 files changed, 534 insertions, 0 deletions

diff --git a/Donjon/src/SCRSAP.f b/Donjon/src/SCRSAP.f
new file mode 100644
index 0000000..b51a4ab
--- /dev/null
+++ b/Donjon/src/SCRSAP.f
@@ -0,0 +1,534 @@
+*DECK SCRSAP
+      SUBROUTINE SCRSAP(IPMAC,IPMEM,IACCS,NMIL,NMIX,NGRP,IMPX,HEQUI,
+     1 HMASL,NCAL,NSURFD,ILUPS,MIXC,TERP,LPURE,B2)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build the Macrolib by scanning the NCAL elementary calculations of
+* a Saphyb and weighting them with TERP factors.
+*
+*Copyright:
+* Copyright (C) 2012 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* A. Hebert
+*
+*Parameters: input
+* IPMAC   address of the output Macrolib LCM object.
+* IPMEM   pointer to the memory-resident Saphyb.
+* IACCS   =0 macrolib is created; =1 ... is updated.
+* NMIL    number of material mixtures in the Saphyb.
+* NMIX    maximum number of material mixtures in the Macrolib.
+* NGRP    number of energy groups.
+* 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 Saphyb.
+* NSURFD  number of discontinuity factors.
+* ILUPS   up-scattering removing flag (=1 to remove up-scattering from
+*         output cross-sections).
+* MIXC    mixture index in the Saphyb 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
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMAC,IPMEM
+      INTEGER IACCS,NMIL,NMIX,NGRP,IMPX,NCAL,NSURFD,ILUPS,MIXC(NMIX)
+      REAL TERP(NCAL,NMIX),B2
+      CHARACTER HEQUI*4,HMASL*4
+      LOGICAL LPURE
+*----
+*  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=5
+      INTEGER, PARAMETER::NSTATE=40
+      INTEGER, PARAMETER::MAXRES=MAX1D-8
+      REAL FLOTVA, WEIGHT, FKEFF, B2R
+      INTEGER I, I1D, I2D, IBM, IBMOLD, ICAL, IDEL, IDF, IED, IGMAX,
+     & IGMIN, IGR, IKEFF, IL, ILONG, IMC, IOF, IPOSDE, ITRANC, ITYLCM,
+     & ITYPE, JGR, LENGTH, N1D, N2D, NDEL, NED, NEDTMP, NF, NFTMP, NL,
+     & NLTMP, NTYPE, NALBP
+      TYPE(C_PTR) JPMAC,KPMAC,IPTMP,JPTMP,KPTMP
+      INTEGER ISTATE(NSTATE),DIMSAP(50)
+      LOGICAL LMAKE1(MAX1D),LMAKE2(MAX2D),LWD
+      CHARACTER TEXT8*8,TEXT12*12,CM*2,HMAK1(MAX1D)*12,HMAK2(MAX2D)*12,
+     1 HVECT(MAXED)*8
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,IJJB,NJJB,IPOSB
+      REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,GAR4B,WORK1,WORK2,XVOLM,
+     1 ENERG,VOSAP,WDLA,FMASL,FMASLB
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SPH
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1,ADF2
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GAR2,GAR3
+      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF
+      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 ADF2(NMIX,NGRP,NSURFD),FMASL(NMIX),FMASLB(NMIX))
+      ALLOCATE(HADF(NSURFD))
+*----
+*  MACROLIB INITIALIZATION
+*----
+      CALL LCMGET(IPMEM,'DIMSAP',DIMSAP)
+      IF(DIMSAP(7).NE.NMIL) THEN
+        CALL XABORT('SCRSAP: INVALID NUMBER OF MIXTURES(1).')
+      ELSE IF(DIMSAP(19).NE.NCAL) THEN
+        CALL XABORT('SCRSAP: INVALID NUMBER OF CALCULATIONS(1).')
+      ELSE IF(DIMSAP(20).NE.NGRP) THEN
+        CALL XABORT('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(1).')
+      ENDIF
+      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
+      FMASL(:NMIX)=0.0
+      IF(NSURFD.GT.0) ADF2(:NMIX,:NGRP,:NSURFD)=0.0
+      ALLOCATE(XVOLM(NMIX),ENERG(NGRP+1))
+      XVOLM(:NMIX)=0.0
+      ENERG(:NGRP+1)=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('SCRSAP: 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('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(2).')
+        ELSE IF(ISTATE(2).NE.NMIX) THEN
+          CALL XABORT('SCRSAP: INVALID NUMBER OF MIXTURES(2).')
+        ENDIF
+        NL=ISTATE(3)
+        NF=ISTATE(4)
+        IF(NF.GT.MAXNFI) CALL XABORT('SCRSAP: MAXNFI OVERFLOW(1).')
+        NED=ISTATE(5)
+        ITRANC=ISTATE(6)
+        NDEL=ISTATE(7)
+        IDF=ISTATE(12)
+        IF(NED.GT.MAXED) CALL XABORT('SCRSAP: 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('SCRSAP: MAXNL OVERFLOW(1).')
+        IF(N1D.GT.MAX1D) CALL XABORT('SCRSAP: MAX1D OVERFLOW(1).')
+        IF(N2D.GT.MAX2D) CALL XABORT('SCRSAP: MAX2D OVERFLOW(1).')
+        DO 20 IED=1,NED
+        HMAK1(8+IED)=HVECT(IED)
+   20   CONTINUE
+        DO 30 IL=1,NL
+        WRITE(CM,'(I2.2)') IL-1
+        HMAK1(8+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
+        CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+        CALL LCMGET(IPMAC,'VOLUME',XVOLM)
+        JPMAC=LCMGID(IPMAC,'GROUP')
+        DO 105 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 55 IBM=1,NMIX
+          DO 50 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=0.0
+   50     CONTINUE
+   55     CONTINUE
+        ENDIF
+   60   CONTINUE
+        DO 80 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 72 I=1,NF
+          DO 71 IBM=1,NMIX
+          DO 70 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR2(IBM,I,IGR,I2D)=0.0
+   70     CONTINUE
+   71     CONTINUE
+   72     CONTINUE
+        ENDIF
+   80   CONTINUE
+        DO 100 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 95 IBM=1,NMIX
+          IPOSDE=IPOS(IBM)
+          DO 90 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1
+          GAR3(IBM,JGR,IGR,IL)=GAR4(IPOSDE)
+          DO 85 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR3(IBM,JGR,IGR,IL)=0.0
+   85     CONTINUE
+          IPOSDE=IPOSDE+1
+   90     CONTINUE
+   95     CONTINUE
+        ENDIF
+  100   CONTINUE
+  105   CONTINUE
+        IF(IDF.EQ.2) THEN
+          CALL LCMSIX(IPMAC,'ADF',1)
+          CALL LCMGTC(IPMAC,'HADF',8,NSURFD,HADF)
+          DO ITYPE=1,NSURFD
+            CALL LCMGET(IPMAC,HADF(ITYPE),ADF2(1,1,ITYPE))
+          ENDDO
+          CALL LCMSIX(IPMAC,' ',2)
+        ENDIF
+      ENDIF
+*----
+*  OVERALL ELEMENTARY CALCULATION LOOP
+*----
+      DO 210 ICAL=1,NCAL
+      DO 110 IBM=1,NMIX ! mixtures in Macrolib
+      WEIGHT=TERP(ICAL,IBM)
+      IF(WEIGHT.NE.0.0) GO TO 120
+  110 CONTINUE
+      GO TO 210
+*----
+*  PRODUCE AN ELEMENTARY MACROLIB (IF IPTMP=0)
+*----
+  120 CALL LCMOP(IPTMP,'*ELEMENTARY*',0,1,0)
+      ALLOCATE(SPH(NMIL,NGRP))
+      B2R=B2
+      CALL SCRSPH(IPMEM,IPTMP,ICAL,IMPX,HEQUI,HMASL,NMIL,NGRP,ILUPS,
+     1 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('SCRMAC: MAXNL OVERFLOW(2).')
+      IF(NFTMP.GT.MAXNFI) CALL XABORT('SCRMAC: MAXNFI OVERFLOW(2).')
+      IF(NEDTMP.GT.MAXED) CALL XABORT('SCRMAC: MAXED OVERFLOW(2).')
+      IF(IACCS.EQ.0) THEN
+        IF(ISTATE(1).NE.NGRP) THEN
+          CALL XABORT('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(3).')
+        ELSE IF(ISTATE(2).NE.NMIL) THEN
+          CALL XABORT('SCRSAP: 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('SCRSAP: MAX1D OVERFLOW(2).')
+        IF(N2D.GT.MAX2D) CALL XABORT('SCRSAP: MAX2D OVERFLOW(2).')
+        DO 130 IED=1,NED
+        HMAK1(8+IED)=HVECT(IED)
+  130   CONTINUE
+        DO 140 IL=1,NL
+        WRITE(CM,'(I2.2)') IL-1
+        HMAK1(8+NED+IL)='SIGS'//CM
+  140   CONTINUE
+        HMAK2(1)='NUSIGF'
+        HMAK2(2)='CHI'
+        DO 150 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
+  150   CONTINUE
+      ELSE
+        IF(NLTMP.GT.NL) CALL XABORT('SCRMAC: NL OVERFLOW.')
+        ITRANC=MAX(ITRANC,ISTATE(6))
+        IF(ISTATE(1).NE.NGRP) THEN
+          CALL XABORT('SCRSAP: INVALID NUMBER OF ENERGY GROUPS(3).')
+        ELSE IF(ISTATE(2).NE.NMIL)THEN
+          CALL XABORT('SCRSAP: INVALID NUMBER OF MIXTURES(3).')
+        ELSE IF(ISTATE(5).NE.NED) THEN
+          CALL XABORT('SCRSAP: INVALID NUMBER OF EDIT REACTIONS(3).')
+        ELSE IF((NFTMP.NE.0).AND.(NFTMP.NE.NF)) THEN
+          CALL XABORT('SCRSAP: INVALID NUMBER OF FISSILE ISOTOPES(3).')
+        ELSE IF(ISTATE(7).NE.NDEL) THEN
+          CALL XABORT('SCRSAP: INVALID NUMBER OF PRECURSOR GROUPS(3).')
+        ELSE IF(ISTATE(12).NE.IDF) THEN
+          CALL XABORT('SCRSAP: INVALID TYPE OF ADF DIRECTORY.')
+        ENDIF
+      ENDIF
+*----
+*  SPH CORRECTION OF MACROLIB INFORMATION
+*----
+      IMC=1 ! SPH correction for SPN macro-calculation
+      NALBP=0 ! no albedo correction
+      CALL SPHCMA(IPTMP,IMPX,IMC,NMIL,NGRP,NFTMP,NEDTMP,NALBP,SPH)
+      DEALLOCATE(SPH)
+*----
+*  RECOVER KEFF, VOLUMES, ENERGY GROUPS, EDIT NAMES, AND LAMBDA-D.
+*----
+      CALL LCMLEN(IPTMP,'K-EFFECTIVE',IKEFF,ITYLCM)
+      IF(IKEFF.EQ.1) CALL LCMGET(IPTMP,'K-EFFECTIVE',FKEFF)
+      CALL LCMLEN(IPTMP,'VOLUME',ILONG,ITYLCM)
+      IF(ILONG.EQ.NMIL) THEN
+        ALLOCATE(VOSAP(NMIL))
+        CALL LCMGET(IPTMP,'VOLUME',VOSAP)
+        DO 160 IBM=1,NMIX ! mixtures in Macrolib
+        IBMOLD=MIXC(IBM) ! mixture in Saphyb
+        IF(IBMOLD.NE.0) XVOLM(IBM)=VOSAP(IBMOLD)
+  160   CONTINUE
+        DEALLOCATE(VOSAP)
+      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
+*----
+*  RECOVER MASL INFORMATION
+*----
+      IF(HMASL.NE.' ') CALL LCMGET(IPTMP,'MASL',FMASLB)
+*----
+*  PERFORM INTERPOLATION
+*----
+      JPTMP=LCMGID(IPTMP,'GROUP')
+      DO 200 IBM=1,NMIX ! mixtures in Macrolib
+      WEIGHT=TERP(ICAL,IBM)
+      IF(WEIGHT.EQ.0.0) GO TO 200
+      IBMOLD=MIXC(IBM) ! mixture in Saphyb
+      IF(IBMOLD.EQ.0) GO TO 200
+      IF(HMASL.NE.' ') FMASL(IBM)=FMASL(IBM)+WEIGHT*FMASLB(IBMOLD)
+*
+      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
+        LMAKE1(I1D)=.TRUE.
+        CALL LCMGPD(KPTMP,HMAK1(I1D),FLOT_PTR)
+        CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /))
+        FLOTVA=FLOT(IBMOLD)
+        IF((.NOT.LPURE).AND.(I1D.EQ.4)) FLOTVA=1.0/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
+          LMAKE2(I2D)=.TRUE.
+          CALL LCMGPD(KPTMP,HMAK2(I2D),FLOT_PTR)
+          CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /))
+          DO 174 I=1,NF
+          IOF=(IBMOLD-1)*NF+I
+          GAR2(IBM,I,IGR,I2D)=GAR2(IBM,I,IGR,I2D)+WEIGHT*FLOT(IOF)
+  174     CONTINUE
+        ENDIF
+  175   CONTINUE
+      ENDIF
+      DO 190 IL=1,NLTMP
+      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,GAR4B)
+        CALL LCMGET(KPTMP,'NJJS'//CM,NJJB)
+        CALL LCMGET(KPTMP,'IJJS'//CM,IJJB)
+        CALL LCMGET(KPTMP,'IPOS'//CM,IPOSB)
+        IPOSDE=IPOSB(IBMOLD)
+        DO 180 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
+  180   CONTINUE
+      ENDIF
+  190 CONTINUE
+  195 CONTINUE
+*----
+*  PROCESS ADF INFORMATION
+*----
+      IF(IDF.EQ.2) THEN
+        CALL LCMSIX(IPTMP,'ADF',1)
+        CALL LCMGET(IPTMP,'NTYPE',NTYPE)
+        IF(NTYPE.NE.NSURFD) CALL XABORT('SCRSAP: INVALID NTYPE VALUE.')
+        CALL LCMGTC(IPTMP,'HADF',8,NSURFD,HADF)
+        DO ITYPE=1,NSURFD
+          CALL LCMGET(IPTMP,HADF(ITYPE),GAR4)
+          DO IGR=1,NGRP
+            ADF2(IBM,IGR,ITYPE)=ADF2(IBM,IGR,ITYPE)+WEIGHT*GAR4(IGR)
+          ENDDO
+        ENDDO
+        CALL LCMSIX(IPTMP,' ',2)
+      ENDIF
+  200 CONTINUE
+      CALL LCMCL(IPTMP,2)
+  210 CONTINUE
+*----
+*  WRITE INTERPOLATED MACROLIB INFORMATION
+*----
+      IF(IKEFF.EQ.1) CALL LCMPUT(IPMAC,'K-EFFECTIVE',1,2,FKEFF)
+      CALL LCMPUT(IPMAC,'VOLUME',NMIX,2,XVOLM)
+      CALL LCMPUT(IPMAC,'ENERGY',NGRP+1,2,ENERG)
+      IF(HMASL.NE.' ') CALL LCMPUT(IPMAC,'MASL',NMIX,2,FMASL)
+      DEALLOCATE(ENERG,XVOLM)
+      IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT)
+      JPMAC=LCMLID(IPMAC,'GROUP',NGRP)
+      DO 365 IGR=1,NGRP
+      KPMAC=LCMDIL(JPMAC,IGR)
+      DO 320 I1D=1,N1D
+      IF(LMAKE1(I1D)) THEN
+        IF((.NOT.LPURE).AND.(I1D.EQ.4)) THEN
+          DO 311 IBM=1,NMIX
+          DO 310 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=1./GAR1(IBM,IGR,I1D)
+  310     CONTINUE
+  311     CONTINUE
+        ELSE IF(I1D.EQ.7) THEN
+          DO 316 IBM=1,NMIX
+          DO 315 IBMOLD=1,NMIL
+          IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)*
+     1    1.0E6 ! convert MeV to eV
+  315     CONTINUE
+  316     CONTINUE
+        ENDIF
+        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
+  365 CONTINUE
+      IF(IDF.EQ.2) THEN
+        CALL LCMSIX(IPMAC,'ADF',1)
+        CALL LCMPUT(IPMAC,'NTYPE',1,1,NSURFD)
+        CALL LCMPTC(IPMAC,'HADF',8,NSURFD,HADF)
+        DO ITYPE=1,NSURFD
+          CALL LCMPUT(IPMAC,HADF(ITYPE),NMIX*NGRP,2,ADF2(1,1,ITYPE))
+        ENDDO
+        CALL LCMSIX(IPMAC,' ',2)
+      ENDIF
+      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 SCRSAP: INCLUDE LEAKAGE IN THE,
+     1  14H MACROLIB (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(MIXC(IBM).NE.0) 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(HADF)
+      DEALLOCATE(FMASLB,FMASL,ADF2,GAR4B,GAR4,GAR3,GAR2,GAR1)
+      DEALLOCATE(IPOSB,NJJB,IJJB,IPOS,NJJ,IJJ)
+      RETURN
+      END