*DECK SCRSAP
      SUBROUTINE SCRSAP(IPMAC,IPSAP,IACCS,NMIL,NMIX,NGRP,IMPX,HEQUI,
     1 NCAL,MIXC,TERP,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.
* IPSAP   address of the Saphyb object.
* 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   name of SPH-factor set to be recovered.
* NCAL    number of elementary calculations in the Saphyb.
* MIXC    mixture index in the Saphyb corresponding to each Microlib
*         mixture. Equal to zero if a Microlib mixture is not updated.
* TERP    interpolation factors.
* B2      buckling
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      PARAMETER (MAX1D=40,MAX2D=20,MAXNL=5,MAXNFI=50)
      TYPE(C_PTR) IPMAC,IPSAP
      INTEGER IACCS,NMIL,NMIX,NGRP,IMPX,NCAL,MIXC(NMIX)
      REAL TERP(NCAL,NMIX),B2
      CHARACTER HEQUI*80
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) JPMAC,KPMAC,IPTMP,JPTMP,KPTMP
      PARAMETER (NSTATE=40,IOUT=6,MAXED=30,MAXRES=MAX1D-7)
      INTEGER ISTATE(NSTATE),DIMSAP(50)
      LOGICAL LMAKE1(MAX1D),LMAKE2(MAX2D)
      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
      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',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))
*----
*  MACROLIB INITIALIZATION
*----
      CALL LCMGET(IPSAP,'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
      CALL XDLSET(LMAKE1,MAX1D,.FALSE.)
      CALL XDLSET(LMAKE2,MAX2D,.FALSE.)
      CALL XDRSET(GAR1,NMIX*NGRP*MAX1D,0.0)
      CALL XDRSET(GAR2,NMIX*MAXNFI*NGRP*MAX2D,0.0)
      CALL XDRSET(GAR3,NMIX*NGRP*NGRP*MAXNL,0.0)
      ALLOCATE(XVOLM(NMIX),ENERG(NGRP+1))
      CALL XDRSET(XVOLM,NMIX,0.0)
      CALL XDRSET(ENERG,NGRP+1,0.0)
      IBMOLD=0
      N1D=0
      N2D=0
      NDEL=0
      NL=0
      NF=0
      ITRANC=0
*----
*  READ EXISTING MACROLIB INFORMATION
*----
      IF(IACCS.EQ.0) THEN
        TEXT12='L_MACROLIB'
        CALL LCMPTC(IPMAC,'SIGNATURE',12,1,TEXT12)
      ELSE
        CALL LCMGTC(IPMAC,'SIGNATURE',12,1,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)
        NED=ISTATE(5)
        ITRANC=ISTATE(6)
        NDEL=ISTATE(7)
        NWGTH=ISTATE(10)
        IF(NED.GT.MAXED) CALL XABORT('SCRSAP: MAXED OVERFLOW(1).')
        CALL LCMGTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT)
        N1D=7+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
   20   HMAK1(7+IED)=HVECT(IED)
        DO 30 IL=1,NL
        WRITE(CM,'(I2.2)') IL-1
   30   HMAK1(7+NED+IL)='SIGS'//CM
        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 100 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(I1D.EQ.4) GAR1(IBM,IGR,I1D)=1.0/GAR1(IBM,IGR,I1D)
          DO 50 IBMOLD=1,NMIL
          IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=0.0
   50     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 70 I=1,NF
          DO 70 IBM=1,NMIX
          DO 70 IBMOLD=1,NMIL
          IF(MIXC(IBM).EQ.IBMOLD) GAR2(IBM,I,IGR,I2D)=0.0
   70     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 90 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
   90     IPOSDE=IPOSDE+1
        ENDIF
  100   CONTINUE
      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))
      CALL SPHSAP(IPSAP,IPTMP,ICAL,IMPX,HEQUI,NMIL,NGRP,SPH)
*----
*  RECOVER MACROLIB PARAMETERS
*----
      CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE)
      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=ISTATE(3)
        NF=ISTATE(4)
        NED=ISTATE(5)
        ITRANC=ISTATE(6)
        NDEL=ISTATE(7)
        NWGTH=ISTATE(10)
        IF(NED.GT.MAXED) CALL XABORT('SCRSAP: MAXED OVERFLOW(2).')
        CALL LCMGTC(IPTMP,'ADDXSNAME-P0',8,NED,HVECT)
        N1D=7+NED+NL
        N2D=2*(NDEL+1)
        IF(NL.GT.MAXNL) CALL XABORT('SCRSAP: MAXNL OVERFLOW(2).')
        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
  130   HMAK1(7+IED)=HVECT(IED)
        DO 140 IL=1,NL
        WRITE(CM,'(I2.2)') IL-1
  140   HMAK1(7+NED+IL)='SIGS'//CM
        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
        NLTMP=NL
        NFTMP=NF
      ELSE
        NLTMP=ISTATE(3)
        NFTMP=ISTATE(4)
        IF(NLTMP.GT.MAXNL) CALL XABORT('SCRSAP: MAXNL OVERFLOW(3).')
        IF(NFTMP.GT.MAXNFI) CALL XABORT('SCRSAP: MAXNFI OVERFLOW.')
        NL=MAX(NL,NLTMP)
        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(10).NE.NWGTH) THEN
          CALL XABORT('SCRSAP: INVALID FLUX ANISOTROPY(3).')
        ENDIF
      ENDIF
*----
*  SPH CORRECTION OF MACROLIB INFORMATION
*----
      CALL SPHCMA(IPTMP,IMPX,NMIL,NGRP,NWGTH,NFTMP,NED,SPH)
      DEALLOCATE(SPH)
*----
*  RECOVER KEFF, VOLUMES, ENERGY GROUPS AND EDIT NAMES.
*----
      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)
*----
*  PERFORM INTERPOLATION
*----
      JPTMP=LCMGID(IPTMP,'GROUP')
      DO 200 IGR=1,NGRP
      KPTMP=LCMGIL(JPTMP,IGR)
      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
      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(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
  174     GAR2(IBM,I,IGR,I2D)=GAR2(IBM,I,IGR,I2D)+WEIGHT*
     1    FLOT(IOF)
        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)
  180   IPOSDE=IPOSDE+1
      ENDIF
  190 CONTINUE
  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)
      DEALLOCATE(ENERG,XVOLM)
      IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT)
      JPMAC=LCMLID(IPMAC,'GROUP',NGRP)
      DO 360 IGR=1,NGRP
      KPMAC=LCMDIL(JPMAC,IGR)
      DO 320 I1D=1,N1D
      IF(LMAKE1(I1D)) THEN
        IF(I1D.EQ.4) THEN
          DO 310 IBM=1,NMIX
  310     GAR1(IBM,IGR,I1D)=1.0/GAR1(IBM,IGR,I1D)
        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
  340 GAR4(IPOSDE)=GAR3(IBM,JGR,IGR,IL)
  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
      IACCS=1
*----
*  UPDATE STATE-VECTOR
*----
      ISTATE(2)=NMIX
      ISTATE(3)=NL
      ISTATE(4)=NF
      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
        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(GAR4B,GAR4,GAR3,GAR2,GAR1)
      DEALLOCATE(IPOSB,NJJB,IJJB,IPOS,NJJ,IJJ)
      RETURN
      END
