*DECK SCRLIB
      SUBROUTINE SCRLIB(MAXNIS,MAXISO,IPLIB,IPSAP,IACCS,NMIX,NGRP,IMPX,
     1 HEQUI,NCAL,ITER,MY1,MY2,MD1,MD2,TERP,NISO,LISO,HISO,CONC,MIXC,
     2 LRES,B2,VTOT,YLDS,DECAYC)
*
*-----------------------------------------------------------------------
*
*Purpose:
* build the Microlib by scanning the NCAL elementary calculations in
* a Saphyb and weighting them with TERP factors.
*
*Copyright:
* Copyright (C) 2012 Ecole Polytechnique de Montreal
*
*Author(s): A. Hebert
*
*Parameters: input
* MAXNIS  maximum value of NISO(I) in user data.
* MAXISO  maximum allocated space for output Microlib TOC information.
* IPLIB   address of the output Microlib LCM object.
* IPSAP   address of the Saphyb object.
* IACCS   =0 Microlib is created; =1 ... is updated.
* NMIX    maximum number of material mixtures in the Microlib.
* 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.
* ITER    completion flag (=0: compute the macrolib).
* MY1     number of fissile isotopes including macroscopic sets.
* MY2     number of fission fragment.
* MD1     number of types of radioactive decay reactions.
* MD2     number of isotopes in output tables.
* TERP    interpolation factors.
* NISO    number of user-selected isotopes.
* LISO    type of treatment (=.true.: ALL; =.false.: ONLY).
* HISO    name of the user-selected isotopes.
* CONC    user-defined number density of the user-selected isotopes. A
*         value of -99.99 is set to indicate that the Saphyb value is
*         used.
* MIXC    mixture index in the Saphyb corresponding to each Microlib
*         mixture. Equal to zero if a Microlib mixture is not updated.
* LRES    =.true. if the interpolation is done without updating isotopic 
*         densities
* B2      buckling
* VTOT    volume of updated core.
* YLDS    fission yields.
* DECAYC  radioactive decay constants.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLIB,IPSAP
      INTEGER MAXNIS,MAXISO,IACCS,NMIX,NGRP,IMPX,NCAL,ITER,MY1,MY2,MD1,
     1 MD2,NISO(NMIX),HISO(2,NMIX,MAXNIS),MIXC(NMIX)
      REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2
      DOUBLE PRECISION VTOT,YLDS(MY1,MY2),DECAYC(MD1,MD2)
      LOGICAL LISO(NMIX),LRES
      CHARACTER HEQUI*80
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) JPLIB,KPLIB
      PARAMETER (NSTATE=40,MAXREA=50,MAXMAC=2,MAXDIV=3,MAXLOC=10,IOUT=6)
      CHARACTER TEXT12*12,HSMG*131,HVECT2(MAXREA)*8,NOMREA(MAXREA)*12,
     1 LOCTYP(MAXLOC)*4,LOCNAM(MAXLOC)*80,IDVAL(MAXDIV)*4,HHISO*8,
     2 NOMMAC(MAXMAC)*8,TEXT4*4,TEXT8*8,HRESID*8
      INTEGER ISTATE(NSTATE),DIMSAP(50)
      REAL VALDIV(MAXDIV),TMPDAY(3)
      LOGICAL LUSER,LSPH,LSTRD
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX2,ITOTM,IRESM,INOMIS,
     1 IADRX,ISOTS,LOCAD,ISADRX,LENGDX,LENGDP,IDATA,ISONA,ISOMI,ITOD2
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE2,HNAM2
      REAL, ALLOCATABLE, DIMENSION(:) :: DENS2,DENS3,VOL2,VOLMI2,SPH,
     1 ENER,XVOLM,CONCE,NWT0,SIGS,SS2D,XS,RVALO,FLUXS,RDATA,SIGSB,
     2 SS2DB,XSB,DENIS,GAR1,GAR2,LAMB,CHIRS,BETAR,INVELS,CHIRSB,BETARB,
     3 INVELSB,SURF
      REAL, ALLOCATABLE, DIMENSION(:,:) :: DENS1,FACT,YLDS2,DECAY2,
     1 SURFLX,ADF2
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DENS0,FLUX
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LXS,MASK,MASKL
      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(IMIX2(MAXISO),ITOD2(MAXISO),HUSE2(3,MAXISO),
     1 HNAM2(3,MAXISO))
      ALLOCATE(DENS2(MAXISO),DENS3(MAXISO),VOL2(MAXISO),VOLMI2(NMIX),
     1 FLUX(NMIX,NGRP,2),SPH(NGRP))
*----
*  MICROLIB INITIALIZATION
*----
      IF(NMIX.GT.9999) CALL XABORT('SCRLIB: NMIX OVERFLOW.')
      CALL XDRSET(VOLMI2,NMIX,0.0)
      CALL XDRSET(DENS2,MAXISO,0.0)
      CALL XDRSET(VOL2,MAXISO,0.0)
      CALL XDISET(IMIX2,MAXISO,0)
      CALL XDISET(ITOD2,MAXISO,0)
      IF(IACCS.EQ.0) THEN
         IF(LRES) CALL XABORT('SCRLIB: RES OPTION IS INVALID.')
         NBISO2=0
         NED2=0
         TEXT12='L_LIBRARY'
         CALL LCMPTC(IPLIB,'SIGNATURE',12,1,TEXT12)
      ELSE
         CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
         IF(ISTATE(1).NE.NMIX) CALL XABORT('SCRLIB: INVALID NUMBER OF '
     1   //'MATERIAL MIXTURES IN THE MICROLIB.')
         IF(ISTATE(3).NE.NGRP) CALL XABORT('SCRLIB: INVALID NUMBER OF '
     1   //'ENERGY GROUPS IN THE MICROLIB.')
         NBISO2=ISTATE(2)
         IF(NBISO2.GT.MAXISO) CALL XABORT('SCRLIB: MAXISO OVERFLOW(1).')
         NED2=ISTATE(13)
         IF(NED2.GT.MAXREA) CALL XABORT('SCRLIB: MAXREA OVERFLOW.')
         CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
           CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMI2)
         ELSE
           CALL XDRSET(VOLMI2,NMIX,0.0)
         ENDIF
         CALL LCMGET(IPLIB,'ISOTOPESUSED',HUSE2)
         CALL LCMGET(IPLIB,'ISOTOPERNAME',HNAM2)
         CALL LCMGET(IPLIB,'ISOTOPESDENS',DENS2)
         CALL LCMGET(IPLIB,'ISOTOPESVOL',VOL2)
         CALL LCMGET(IPLIB,'ISOTOPESMIX',IMIX2)
         CALL LCMGET(IPLIB,'ISOTOPESTODO',ITOD2)
         IF(NED2.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2)
      ENDIF
*----
*  RECOVER SAPHYB CHARACTERISTICS
*----
      CALL LCMLEN(IPSAP,'DIMSAP',ILENG,ITYLCM)
      IF(ILENG.EQ.0) CALL XABORT('SCRLIB: INVALID SAPHYB.')
      CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)
      IF(NGRP.NE.DIMSAP(20)) THEN
        CALL XABORT('SCRLIB: INVALID VALUE OF NGRP.')
      ENDIF
      NLAM=DIMSAP(3)   ! number of radioactive decay reactions
      NREA=DIMSAP(4)   ! number of neutron-induced reactions
      NISOP=DIMSAP(5)  ! number of particularized isotopes
      NMAC=DIMSAP(6)   ! number of macroscopic sets
      NMIL=DIMSAP(7)   ! number of mixtures in the Saphyb
      NPARL=DIMSAP(11) ! number of local variables
      NADRX=DIMSAP(18) ! number of address sets
      NCALS=DIMSAP(19) ! number of elementary calculations in the Saphyb
      NPRC=DIMSAP(31)  ! number of delayed neutron precursor groups
      NISOTS=DIMSAP(32) ! number of isotopes in edition tables
      IF(IMPX.GT.1) THEN
        WRITE(6,'(30H SCRLIB: number of reactions =,I3)') NREA
        WRITE(6,'(48H SCRLIB: number of radioactive decay reactions =,
     1  I3)') NLAM
        WRITE(6,'(46H SCRLIB: number of neutron-induced reactions =,
     1  I3)') NREA
        WRITE(6,'(44H SCRLIB: number of particularized isotopes =,I4)')
     1  NISOP
        WRITE(6,'(37H SCRLIB: number of macroscopic sets =,I2)') NMAC
        WRITE(6,'(29H SCRLIB: number of mixtures =,I5)') NMIL
        WRITE(6,'(36H SCRLIB: number of local variables =,I4)') NPARL
        WRITE(6,'(33H SCRLIB: number of address sets =,I4)') NADRX
        WRITE(6,'(33H SCRLIB: number of calculations =,I7)') NCALS
        WRITE(6,'(34H SCRLIB: number of energy groups =,I4)') NGRP
        WRITE(6,'(37H SCRLIB: number of precursor groups =,I4)') NPRC
        WRITE(6,'(46H SCRLIB: number of isotopes in output tables =,
     1  I4)') NISOTS
      ENDIF
      IF(NREA.GT.MAXREA) CALL XABORT('SCRLIB: MAXREA OVERFLOW')
      IF(NMAC.GT.MAXMAC) CALL XABORT('SCRLIB: MAXMAC OVERFLOW')
*----
*  RECOVER INFORMATION FROM constphysiq DIRECTORY.
*----
      ALLOCATE(ENER(NGRP+1))
      CALL LCMSIX(IPSAP,'constphysiq',1)
      CALL LCMGET(IPSAP,'ENRGS',ENER)
      CALL LCMSIX(IPSAP,' ',2)
      DO IGR=1,NGRP+1
        ENER(IGR)=ENER(IGR)/1.0E-6
      ENDDO
      CALL LCMPUT(IPLIB,'ENERGY',NGRP+1,2,ENER)
      DO IGR=1,NGRP
        ENER(IGR)=LOG(ENER(IGR)/ENER(IGR+1))
      ENDDO
      CALL LCMPUT(IPLIB,'DELTAU',NGRP,2,ENER)
      DEALLOCATE(ENER)
*----
*  RECOVER INFORMATION FROM contenu DIRECTORY.
*----
      ALLOCATE(ITOTM(NMIL),IRESM(NMIL))
      CALL LCMSIX(IPSAP,'contenu',1)
      IF(NREA.GT.0) THEN
        CALL LCMGTC(IPSAP,'NOMREA',12,NREA,NOMREA)
        IF(IMPX.GT.1) THEN
          WRITE(6,'(29H SCRLIB: Available reactions:/(1X,10A13))')
     1    (NOMREA(I),I=1,NREA)
        ENDIF
      ENDIF
      CALL LCMGET(IPSAP,'TOTMAC',ITOTM)
      CALL LCMGET(IPSAP,'RESMAC',IRESM)
      ALLOCATE(INOMIS((NISOP+NMAC)*2))
      NBISO1=NISOP
      IF(NISOP.GT.0) CALL LCMGET(IPSAP,'NOMISO',INOMIS)
      IF(NMAC.GT.0) THEN
        CALL LCMLEN(IPSAP,'NOMMAC',ILONG,ITYLCM)
        IF(ILONG.GT.2*MAXMAC) CALL XABORT('SCRLIB: MAXMAC OVERFLOW')
        CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,NOMMAC)
        HHISO='*MAC*RES'
        READ(HHISO,'(2A4)') (INOMIS(2*NBISO1+I0),I0=1,2)
        NBISO1=NBISO1+1
      ENDIF
      CALL LCMSIX(IPSAP,' ',2)
      IF(NBISO1.EQ.0) CALL XABORT('SCRLIB: NO CROSS SECTIONS FOUND.')
      IF(NBISO1.GT.MAXISO) CALL XABORT('SCRLIB: MAXISO OVERFLOW.')
*----
*  RECOVER INFORMATION FROM adresses DIRECTORY.
*----
      NL=0
      IF(NADRX.GT.0) THEN
        ALLOCATE(IADRX((NREA+2)*(NISOP+NMAC)*NADRX))
        CALL LCMSIX(IPSAP,'adresses',1)
        CALL LCMGET(IPSAP,'ADRX',IADRX)
        CALL LCMSIX(IPSAP,' ',2)
        DO IAD=1,NADRX
          DO ISO=1,NISOP+NMAC
            IOF=(NREA+2)*(NISOP+NMAC)*(IAD-1)+(NREA+2)*(ISO-1)+NREA+1
            NL=MAX(NL,IADRX(IOF))
            IOF=(NREA+2)*(NISOP+NMAC)*(IAD-1)+(NREA+2)*(ISO-1)+NREA+2
            NL=MAX(NL,IADRX(IOF))
          ENDDO
        ENDDO
      ENDIF
      IF(IMPX.GT.1) THEN
        WRITE(6,'(36H SCRLIB: number of Legendre orders =,I4)') NL
      ENDIF
*----
*  RECOVER INFORMATION FROM geom DIRECTORY.
*----
      NSURFD=0
      IDF=0
      CALL LCMSIX(IPSAP,'geom',1)
      ALLOCATE(XVOLM(NMIL))
      CALL LCMGET(IPSAP,'XVOLMT',XVOLM)
      CALL LCMLEN(IPSAP,'outgeom',ILONG,ITYLCM)
      IF(ILONG.NE.0) THEN
        CALL LCMSIX(IPSAP,'outgeom',1)
        CALL LCMLEN(IPSAP,'SURF',NSURFD,ITYLCM)
        IF(IMPX.GT.1) THEN
          WRITE(6,'(42H SCRLIB: number of discontinuity factors =,I4/)')
     1    NSURFD
        ENDIF
        CALL LCMSIX(IPSAP,' ',2)
      ENDIF
      ALLOCATE(SURFLX(NSURFD,NGRP),SURF(NSURFD))
      IF(NSURFD.GT.0) THEN
        IDF=2
        CALL LCMSIX(IPSAP,'outgeom',1)
        CALL LCMGET(IPSAP,'SURF',SURF)
        CALL LCMSIX(IPSAP,' ',2)
      ENDIF
      CALL LCMSIX(IPSAP,' ',2)
*----
*  LOOP OVER SAPHYB MIXTURES TO COMPUTE DENS0(NMIL,NCAL,NBISO1)
*----
      ALLOCATE(DENS0(NMIL,NCAL,NBISO1))
      IF(NISOTS.GT.0) ALLOCATE(ISOTS(NISOTS*2))
      CALL XDRSET(DENS0,NBISO1*NCAL*NMIL,0.0)
      ALLOCATE(CONCE(NISOTS))
      DO 30 IBMOLD=1,NMIL
      DO ICAL=1,NCAL
        DO IBM=1,NMIX
          IF((TERP(ICAL,IBM).NE.0.0).AND.(MIXC(IBM).EQ.IBMOLD)) GO TO 10
        ENDDO
        CYCLE
  10    WRITE(TEXT12,'(4Hcalc,I8)') ICAL
        CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM)
        IF(ILENG.EQ.0) THEN
          WRITE(HSMG,'(29HSCRLIB: MISSING CALCULATION '',A12,2H''.)')
     1    TEXT12
          CALL XABORT(HSMG)
        ENDIF
        CALL LCMSIX(IPSAP,TEXT12,1) ! step up to calc
        CALL LCMSIX(IPSAP,'info',1)
        IF(NISOTS.GT.0) CALL LCMGET(IPSAP,'ISOTS',ISOTS)
        CALL LCMSIX(IPSAP,' ',2)
        WRITE(TEXT12,'(4Hmili,I8)') IBMOLD
        CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM)
        IF(ILENG.EQ.0) THEN
          WRITE(HSMG,'(29HSCRLIB: MISSING MIXTURE '',A12,2H''.)') TEXT12
          CALL XABORT(HSMG)
        ENDIF
        CALL LCMSIX(IPSAP,TEXT12,1) ! step up to mili
        CALL LCMGET(IPSAP,'CONCES',CONCE)
        DO ISO=1,NISOP
          DO IS2=1,NISOTS
            ISOKEP=IS2
            IF(INOMIS(2*(ISO-1)+1).NE.ISOTS(2*(IS2-1)+1)) CYCLE
            IF(INOMIS(2*(ISO-1)+2).NE.ISOTS(2*(IS2-1)+2)) CYCLE
            GO TO 20
          ENDDO
          CYCLE
   20     DENS0(IBMOLD,ICAL,ISO)=CONCE(ISOKEP)
        ENDDO
        CALL LCMSIX(IPSAP,' ',2) ! step down from mili
        CALL LCMSIX(IPSAP,' ',2) ! step down from calc
      ENDDO
   30 CONTINUE
      DEALLOCATE(CONCE)
*----
*  LOOP OVER MICROLIB MIXTURES
*----
      ALLOCATE(ISADRX(NMIL),LENGDX(NMIL),LENGDP(NMIL))
      ALLOCATE(NWT0(NGRP),SIGS(NGRP*NL*(NISOP+NMAC)),
     1 SS2D(NGRP*NGRP*NL*(NISOP+NMAC)),XS(NGRP*NREA*(NISOP+NMAC)))
      ALLOCATE(LXS(NREA))
      ALLOCATE(LAMB(NPRC),CHIRS(NGRP*NPRC),BETAR(NPRC),INVELS(NGRP))
      CALL XDRSET(LAMB,NPRC,0.0)
      CALL XDRSET(CHIRS,NGRP*NPRC,0.0)
      CALL XDRSET(BETAR,NPRC,0.0)
      CALL XDRSET(INVELS,NGRP,0.0)
      ALLOCATE(CHIRSB(NGRP*NPRC),BETARB(NPRC),INVELSB(NGRP))
      ALLOCATE(DENS1(NBISO1,NCAL),FACT(NBISO1,NCAL))
      DO 100 IBM=1,NMIX
      IBMOLD=MIXC(IBM)
      IF(IBMOLD.EQ.0) GO TO 100
      IF(NISO(IBM).GT.MAXNIS) CALL XABORT('SCRLIB: MAXNIS OVERFLOW.')
      VOLMI2(IBM)=XVOLM(IBMOLD)
      IMAC=ITOTM(IBMOLD)
      IRES=IRESM(IBMOLD)
*----
*  COMPUTE THE NUMBER DENSITIES OF EACH ELEMENTARY CALCULATION.
*----
      CALL XDRSET(DENS1,NBISO1*NCAL,0.0)
      CALL XDRSET(DENS3,NBISO1,0.0)
      DO ICAL=1,NCAL
        WEIGHT=TERP(ICAL,IBM)
        IF(WEIGHT.EQ.0.0) CYCLE
        DO ISO=1,NISOP
          LUSER=.FALSE.
          WRITE(TEXT8,'(2A4)') (INOMIS(2*(ISO-1)+I0),I0=1,2)
          KSO1=0
          DO KSO=1,NISO(IBM) ! user-selected isotope
            WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2)
            IF(TEXT8.EQ.HHISO) THEN
              KSO1=KSO
              LUSER=(CONC(IBM,KSO1).NE.-99.99)
              GO TO 35
            ENDIF
          ENDDO
   35     IF(LUSER) THEN
            DENS1(ISO,ICAL)=CONC(IBM,KSO1)
            CYCLE
          ENDIF
          IF(.NOT.LISO(IBM)) CYCLE
          DENS1(ISO,ICAL)=DENS0(IBMOLD,ICAL,ISO)
        ENDDO
        IF(NMAC.GT.0) DENS1(NISOP+1,ICAL)=1.0
        DO ISO=1,NBISO1
          DENS3(ISO)=DENS3(ISO)+WEIGHT*DENS1(ISO,ICAL)
        ENDDO
      ENDDO
      CALL XDRSET(FACT,NBISO1*NCAL,1.0)
      DO ICAL=1,NCAL
        IF(TERP(ICAL,IBM).EQ.0.0) CYCLE
        DO ISO=1,NBISO1
          IF(DENS3(ISO).GT.DENS1(ISO,ICAL)*1.0E-9) THEN
            FACT(ISO,ICAL)=DENS1(ISO,ICAL)/DENS3(ISO)
          ENDIF
        ENDDO
      ENDDO
*----
*  INITIALIZE WORKING ARRAYS.
*----
      CALL XDRSET(NWT0,NGRP,0.0)
      CALL XDRSET(SIGS,NGRP*NL*NBISO1,0.0)
      CALL XDRSET(SS2D,NGRP*NGRP*NL*NBISO1,0.0)
      CALL XDRSET(XS,NGRP*NREA*NBISO1,0.0)
      CALL XDLSET(LXS,NREA,.FALSE.)
*----
*  MAIN LOOP OVER ELEMENTARY CALCULATIONS
*----
      LSTRD=.FALSE.
      DO 60 ICAL=1,NCAL
      WEIGHT=TERP(ICAL,IBM)
      IF(WEIGHT.EQ.0.0) GO TO 60
*----
*  RECOVER INFORMATION FROM caldir DIRECTORY.
*----
      WRITE(TEXT12,'(4Hcalc,I8)') ICAL
      CALL LCMSIX(IPSAP,TEXT12,1) ! step up to calc
      IF(NPRC.GT.0) THEN
        CALL XDRSET(CHIRSB,NGRP*NPRC,0.0)
        CALL XDRSET(BETARB,NPRC,0.0)
        CALL XDRSET(INVELSB,NGRP,0.0)
      ENDIF
      CALL LCMSIX(IPSAP,'info',1)
      LSPH=.FALSE.
      IF(NPARL.GT.0) THEN
        CALL LCMGET(IPSAP,'NLOC',NLOC)
        IF(NLOC.GT.MAXLOC) CALL XABORT('SCRLIB: MAXLOC OVERFLOW')
        CALL LCMGTC(IPSAP,'LOCTYP',4,NLOC,LOCTYP)
        CALL LCMGTC(IPSAP,'LOCNAM',80,NLOC,LOCNAM)
        ALLOCATE(LOCAD(NLOC+1))
        CALL LCMGET(IPSAP,'LOCADR',LOCAD)
        DO ILOC=1,NLOC
          LSPH=((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCNAM(ILOC).EQ.HEQUI))
          IF(LSPH) EXIT
        ENDDO
      ENDIF
      CALL LCMGET(IPSAP,'ISADRX',ISADRX)
      CALL LCMGET(IPSAP,'LENGDX',LENGDX)
      CALL LCMGET(IPSAP,'LENGDP',LENGDP)
      IF(NISOTS.GT.0) CALL LCMGET(IPSAP,'ISOTS',ISOTS)
      CALL LCMSIX(IPSAP,' ',2)
      CALL LCMSIX(IPSAP,'divers',1)
      CALL LCMLEN(IPSAP,'NVDIV',ILENG,ITYLCM)
      IF(ILENG.EQ.0) THEN
        NVDIV=0
      ELSE
        CALL LCMGET(IPSAP,'NVDIV',NVDIV)
      ENDIF
      B2SAP=0.0
      IF(NVDIV.GT.0) THEN
        IF(NVDIV.GT.MAXDIV) CALL XABORT('SCRLIB: MAXDIV OVERFLOW.')
        CALL LCMGTC(IPSAP,'IDVAL',4,NVDIV,IDVAL)
        CALL LCMGET(IPSAP,'VALDIV',VALDIV)
        DO I=1,NVDIV
          IF(IMPX.GT.3) THEN
            WRITE(6,'(9H SCRLIB: ,I3,2X,A,1H=,1P,E13.5)') I,IDVAL(I),
     1      VALDIV(I)
          ENDIF
          IF(IDVAL(I).EQ.'B2') B2SAP=VALDIV(I)
        ENDDO
      ENDIF
      LSTRD=LSTRD.OR.(B2SAP.EQ.0.0)
*
      CALL LCMLEN(IPSAP,'NPR',ILONG,ITYLCM)
      IF((NPRC.GT.0).AND.(ILONG.EQ.1)) THEN
        CALL LCMGET(IPSAP,'NPR',NPR)
        IF(NPR.NE.NPRC) CALL XABORT('SCRLIB: NPR INCONSISTENCY(1).')
        CALL LCMGET(IPSAP,'LAMBRS',LAMB)
        CALL LCMGET(IPSAP,'CHIRS',CHIRSB)
        CALL LCMGET(IPSAP,'BETARS',BETARB)
        CALL LCMGET(IPSAP,'INVELS',INVELSB)
      ENDIF
      CALL LCMSIX(IPSAP,' ',2)
*----
*  SELECT SAPHYB MIXTURE IBMOLD.
*----
      IF(NADRX.EQ.0) CALL XABORT('SCRLIB: NO ADDRESS SETS AVAILABLE.')
      WRITE(TEXT12,'(4Hmili,I8)') IBMOLD
      CALL LCMLEN(IPSAP,TEXT12,ILENG,ITYLCM)
      IF(ILENG.EQ.0) THEN
        WRITE(HSMG,'(29HSCRLIB: MISSING MIXTURE '',A12,2H''.)') TEXT12
        CALL XABORT(HSMG)
      ENDIF
      CALL LCMSIX(IPSAP,TEXT12,1) ! step up to mili
      CALL XDRSET(SPH,NGRP,1.0)
      IF(LSPH) THEN
        ALLOCATE(RVALO(LOCAD(NLOC+1)-1))
        CALL LCMGET(IPSAP,'RVALOC',RVALO)
        DO ILOC=1,NLOC
          IF((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCNAM(ILOC).EQ.HEQUI)) THEN
            IF(LOCAD(ILOC+1)-LOCAD(ILOC).NE.NGRP) THEN
              CALL XABORT('SCRLIB: INVALID NUMBER OF COMPONENTS FOR '
     1        //'SPH FACTORS')
            ENDIF
            DO IGR=1,NGRP
              SPH(IGR)=RVALO(LOCAD(ILOC)+IGR-1)
            ENDDO
          ENDIF
        ENDDO
        DEALLOCATE(RVALO)
      ENDIF
      IF(NPARL.GT.0) DEALLOCATE(LOCAD)
      IAD=ISADRX(IBMOLD)
      NDATAX=LENGDX(IBMOLD)
      NDATAP=LENGDP(IBMOLD)
      ALLOCATE(FLUXS(NGRP),RDATA(NDATAX),IDATA(NDATAP))
      CALL LCMGET(IPSAP,'FLUXS',FLUXS)
      CALL LCMGET(IPSAP,'RDATAX',RDATA)
      CALL LCMGET(IPSAP,'IDATAP',IDATA)
      DO I=1,NGRP
        NWT0(I)=NWT0(I)+WEIGHT*FLUXS(I)/(XVOLM(IBMOLD)*SPH(I))
      ENDDO
      ALLOCATE(SIGSB(NGRP*NL),SS2DB(NGRP*NGRP*NL),XSB(NGRP*NREA))
      IF(NISOP.NE.0) THEN
        DO ISO=1,NISOP
          FACT0=FACT(ISO,ICAL)
          CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP,
     1    ISO,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS)
          DO IGR=1,NGRP
            DO IL=1,NL
              I=(IL-1)*NGRP+IGR
              J=(ISO-1)*NGRP*NL+I
              SIGS(J)=SIGS(J)+FACT0*SPH(IGR)*WEIGHT*SIGSB(I)
            ENDDO
          ENDDO
          DO IGR=1,NGRP
            DO JGR=1,NGRP
              DO IL=1,NL
                I=(IL-1)*NGRP*NGRP+(JGR-1)*NGRP+IGR
                J=(ISO-1)*NGRP*NGRP*NL+I
                SS2D(J)=SS2D(J)+FACT0*SPH(JGR)*WEIGHT*SS2DB(I)
              ENDDO
            ENDDO
          ENDDO
          DO IGR=1,NGRP
            DO IREA=1,NREA
              I=(IREA-1)*NGRP+IGR
              J=(ISO-1)*NGRP*NREA+I
              IF(NOMREA(IREA).EQ.'SPECTRE') THEN
                XS(J)=XS(J)+WEIGHT*XSB(I)
              ELSE IF(NOMREA(IREA).EQ.'FUITES') THEN
                IF(B2SAP.NE.0.0) THEN
                  XSECT=XSB(I)/B2SAP
                  XS(J)=XS(J)+FACT0*WEIGHT*XSECT/SPH(IGR)
                ENDIF
              ELSE
                XS(J)=XS(J)+FACT0*SPH(IGR)*WEIGHT*XSB(I)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
        IF(IRES.NE.0) THEN
          CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP,
     1    NISOP+IRES,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS)
          DO IGR=1,NGRP
            DO IL=1,NL
              I=(IL-1)*NGRP+IGR
              J=NISOP*NGRP*NL+I
              SIGS(J)=SIGS(J)+SPH(IGR)*WEIGHT*SIGSB(I)
            ENDDO
          ENDDO
          DO IGR=1,NGRP
            DO JGR=1,NGRP
              DO IL=1,NL
                I=(IL-1)*NGRP*NGRP+(JGR-1)*NGRP+IGR
                J=NISOP*NGRP*NGRP*NL+I
                SS2D(J)=SS2D(J)+SPH(JGR)*WEIGHT*SS2DB(I)
              ENDDO
            ENDDO
          ENDDO
          DO IGR=1,NGRP
            DO IREA=1,NREA
              I=(IREA-1)*NGRP+IGR
              J=NISOP*NGRP*NREA+I
              IF(NOMREA(IREA).EQ.'SPECTRE') THEN
                XS(J)=XS(J)+WEIGHT*XSB(I)
              ELSE IF(NOMREA(IREA).EQ.'FUITES') THEN
                IF(B2SAP.NE.0.0) THEN
                  XSECT=XSB(I)/B2SAP
                  XS(J)=XS(J)+WEIGHT*XSECT/SPH(IGR)
                ENDIF
              ELSE
                XS(J)=XS(J)+SPH(IGR)*WEIGHT*XSB(I)
              ENDIF
            ENDDO
          ENDDO
        ENDIF
      ELSE IF(IMAC.NE.0) THEN
        CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP,
     1  NISOP+IMAC,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS)
        DO IGR=1,NGRP
          DO IL=1,NL
            I=(IL-1)*NGRP+IGR
            J=NISOP*NGRP*NL+I
            SIGS(J)=SIGS(J)+SPH(IGR)*WEIGHT*SIGSB(I)
          ENDDO
        ENDDO
        DO IGR=1,NGRP
          DO JGR=1,NGRP
            DO IL=1,NL
              I=(IL-1)*NGRP*NGRP+(JGR-1)*NGRP+IGR
              J=NISOP*NGRP*NGRP*NL+I
              SS2D(J)=SS2D(J)+SPH(JGR)*WEIGHT*SS2DB(I)
            ENDDO
          ENDDO
        ENDDO
        DO IGR=1,NGRP
          DO IREA=1,NREA
            I=(IREA-1)*NGRP+IGR
            J=NISOP*NGRP*NREA+I
            IF(NOMREA(IREA).EQ.'SPECTRE') THEN
              XS(J)=XS(J)+WEIGHT*XSB(I)
            ELSE IF(NOMREA(IREA).EQ.'FUITES') THEN
              IF(B2SAP.NE.0.0) THEN
                XSECT=XSB(I)/B2SAP
                XS(J)=XS(J)+WEIGHT*XSECT/SPH(IGR)
              ENDIF
            ELSE
              XS(J)=XS(J)+SPH(IGR)*WEIGHT*XSB(I)
            ENDIF
          ENDDO
        ENDDO
      ELSE
        CALL XABORT('SCRLIB: NO MACROSCOPIC SET.')
      ENDIF
      DEALLOCATE(XSB,SS2DB,SIGSB,IDATA,RDATA,FLUXS)
*
      CALL LCMLEN(IPSAP,'cinetique',ILONG,ITYLCM)
      IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN
        CALL LCMSIX(IPSAP,'cinetique',1)
        CALL LCMGET(IPSAP,'NPR',NPR)
        IF(NPR.NE.NPRC) CALL XABORT('SCRLIB: NPR INCONSISTENCY(2).')
        CALL LCMGET(IPSAP,'LAMBRS',LAMB)
        CALL LCMGET(IPSAP,'CHIRS',CHIRSB)
        CALL LCMGET(IPSAP,'BETARS',BETARB)
        CALL LCMGET(IPSAP,'INVELS',INVELSB)
        CALL LCMSIX(IPSAP,' ',2)
      ENDIF
      IF(NPRC.GT.0) THEN
        DO IGR=1,NGRP
          INVELS(IGR)=INVELS(IGR)+SPH(IGR)*WEIGHT*INVELSB(IGR)
          DO IPRC=1,NPRC
            IOF=(IPRC-1)*NGRP+IGR
            CHIRS(IOF)=CHIRS(IOF)+WEIGHT*CHIRSB(IOF)
          ENDDO
        ENDDO
        DO IPRC=1,NPRC
          BETAR(IPRC)=BETAR(IPRC)+WEIGHT*BETARB(IPRC)
        ENDDO
      ENDIF
*----
*  IDENTIFY SPECIAL FLUX EDITS
*----
      DO IREA=1,NREA
        IF(.NOT.LXS(IREA)) CYCLE
        IF(NOMREA(IREA).EQ.'TOTALE') CYCLE
        IF(NOMREA(IREA).EQ.'TOTALE P1') CYCLE
        IF(NOMREA(IREA).EQ.'EXCESS') CYCLE
        IF(NOMREA(IREA).EQ.'FISSION') CYCLE
        IF(NOMREA(IREA).EQ.'SPECTRE') CYCLE
        IF(NOMREA(IREA).EQ.'NU*FISSION') CYCLE
        IF(NOMREA(IREA).EQ.'ENERGIE') CYCLE
        IF(NOMREA(IREA).EQ.'SELF') CYCLE
        IF(NOMREA(IREA).EQ.'TRANSP-CORR') CYCLE
        IF(NOMREA(IREA).EQ.'FUITES') CYCLE
        IF(NOMREA(IREA).EQ.'DIFFUSION') CYCLE
        IF(NOMREA(IREA).EQ.'TRANSFERT') CYCLE
        DO 40 IED2=1,NED2
        IF(NOMREA(IREA)(:8).EQ.HVECT2(IED2)) GO TO 50
   40   CONTINUE
        NED2=NED2+1
        HVECT2(NED2)=NOMREA(IREA)(:8)
   50   CONTINUE
      ENDDO
*
      CALL LCMSIX(IPSAP,' ',2) ! step down from mili
      CALL LCMSIX(IPSAP,' ',2) ! step down from calc
   60 CONTINUE ! end of loop over elementary calculations.
*----
*  SAVE CROSS SECTIONS IN MICROLIB FOR MIXTURE IBM
*----
      HRESID=' '
      IF(NISOP.NE.0) THEN
        DO ISO=1,NISOP
          JSIGS=(ISO-1)*NGRP*NL
          JSS2D=(ISO-1)*NGRP*NGRP*NL
          JXS=(ISO-1)*NGRP*NREA
          WRITE(TEXT12,'(2A4,I4.4)') (INOMIS(2*(ISO-1)+I0),I0=1,2),IBM
          CALL LCMSIX(IPLIB,TEXT12,1)
          CALL SCRISO(IPLIB,IMPX,NREA,NGRP,NL,NPRC,NOMREA,NWT0,
     1    SIGS(JSIGS+1),SS2D(JSS2D+1),XS(JXS+1),LXS,LAMB,CHIRS,BETAR,
     2    INVELS,LSTRD,ITRANC,IFISS)
          CALL LCMSIX(IPLIB,' ',2)
        ENDDO
        IF(IRES.NE.0) THEN
          HRESID=NOMMAC(IRES)
          JSIGS=NISOP*NGRP*NL
          JSS2D=NISOP*NGRP*NGRP*NL
          JXS=NISOP*NGRP*NREA
          WRITE(TEXT12,'(8H*MAC*RES,I4.4)') IBM
          CALL LCMSIX(IPLIB,TEXT12,1)
          CALL SCRISO(IPLIB,IMPX,NREA,NGRP,NL,NPRC,NOMREA,NWT0,
     1    SIGS(JSIGS+1),SS2D(JSS2D+1),XS(JXS+1),LXS,LAMB,CHIRS,BETAR,
     2    INVELS,LSTRD,ITRANC,IFISS)
          CALL LCMSIX(IPLIB,' ',2)
        ENDIF
      ELSE IF(IMAC.NE.0) THEN
        HRESID=NOMMAC(IMAC)
        JSIGS=NISOP*NGRP*NL
        JSS2D=NISOP*NGRP*NGRP*NL
        JXS=NISOP*NGRP*NREA
        WRITE(TEXT12,'(8H*MAC*RES,I4.4)') IBM
        CALL LCMSIX(IPLIB,TEXT12,1)
        CALL SCRISO(IPLIB,IMPX,NREA,NGRP,NL,NPRC,NOMREA,NWT0,
     1  SIGS(JSIGS+1),SS2D(JSS2D+1),XS(JXS+1),LXS,LAMB,CHIRS,BETAR,
     2  INVELS,LSTRD,ITRANC,IFISS)
        CALL LCMSIX(IPLIB,' ',2)
      ENDIF
*----
*  SET NUMBER DENSITIES AND VOLUMES IN OUTPUT MICROLIB
*----
      IF(LRES) THEN
*       -- Number densities are left unchanged except if they are
*       -- listed in HISO array.
        DO 70 KSO=1,NISO(IBM) ! user-selected isotope
          DO JSO=1,NBISO2 ! microlib isotope
            IF(IMIX2(JSO).NE.IBM) CYCLE
            IF((HISO(1,IBM,KSO).EQ.HUSE2(1,JSO)).AND.
     1         (HISO(2,IBM,KSO).EQ.HUSE2(2,JSO))) THEN
              IF(CONC(IBM,KSO).EQ.-99.99) THEN
*               -- Only number densities of isotopes set with "MICR" and
*               -- "*" keywords are interpolated
                DENS2(JSO)=0.0
                DO ISO=1,NBISO1 ! Saphyb isotope
                  IF((INOMIS(2*(ISO-1)+1).EQ.HUSE2(1,JSO)).AND.
     1              (INOMIS(2*(ISO-1)+2).EQ.HUSE2(2,JSO))) THEN
                    DENS2(JSO)=DENS2(JSO)+DENS3(ISO)
                  ENDIF
                ENDDO
              ELSE IF(CONC(IBM,KSO).NE.-99.99) THEN
*               -- Number densities of isotopes set with "MICR" and
*               -- fixed value are forced to this value
                DENS2(JSO)=CONC(IBM,KSO)
              ENDIF
              GO TO 70
            ENDIF
          ENDDO
          WRITE(TEXT12,'(2A4,I4.4)') HISO(1,IBM,KSO),HISO(2,IBM,KSO),IBM
          CALL XABORT('SCRLIB: UNABLE TO FIND ISOTOPE '//TEXT12)
   70   CONTINUE
      ELSE
*       -- Number densities are interpolated or not according to
*       -- ALL/ONLY option
        DO JSO=1,NBISO2 ! microlib isotope
          IF(IBM.EQ.IMIX2(JSO)) THEN
            DO ISO=1,NBISO1 ! Saphyb isotope
              IF((INOMIS(2*(ISO-1)+1).EQ.HUSE2(1,JSO)).AND.
     1          (INOMIS(2*(ISO-1)+2).EQ.HUSE2(2,JSO))) THEN
                DENS2(JSO)=0.0
                VOL2(JSO)=0.0
                CYCLE
              ENDIF
            ENDDO
          ENDIF
        ENDDO
        DO 90 ISO=1,NBISO1 ! Saphyb isotope
        WRITE(TEXT12,'(2A4,I4.4)') (INOMIS(2*(ISO-1)+I0),I0=1,2),IBM
        IF(.NOT.LISO(IBM)) THEN
*         --ONLY option
          DO KSO=1,NISO(IBM) ! user-selected isotope
            WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2)
            IF(TEXT12(:8).EQ.HHISO) GO TO 80
          ENDDO
          GO TO 90
        ENDIF
   80   DO JSO=1,NBISO2 ! microlib isotope
          IF(IMIX2(JSO).NE.IBM) CYCLE
          IF((INOMIS(2*(ISO-1)+1).EQ.HUSE2(1,JSO)).AND.
     1      (INOMIS(2*(ISO-1)+2).EQ.HUSE2(2,JSO))) THEN
            DENS2(JSO)=DENS2(JSO)+DENS3(ISO)
            VOL2(JSO)=VOL2(JSO)+XVOLM(IBMOLD)
            GO TO 90
          ENDIF
        ENDDO
        NBISO2=NBISO2+1
        IF(NBISO2.GT.MAXISO) THEN
          WRITE(IOUT,'(/16H SCRLIB: NBISO2=,I6,8H MAXISO=,I6)') NBISO2,
     1    MAXISO
          CALL XABORT('SCRLIB: MAXISO OVERFLOW(2).')
        ENDIF
        READ(TEXT12,'(3A4)') (HUSE2(I0,NBISO2),I0=1,3)
        HNAM2(1,NBISO2)=HUSE2(1,NBISO2)
        HNAM2(2,NBISO2)=HUSE2(2,NBISO2)
        IF(TEXT12(:8).EQ.'*MAC*RES') THEN
          READ(HRESID,'(2A4)') (HNAM2(I0,NBISO2),I0=1,2)
        ENDIF
        TEXT4=' '
        READ(TEXT4,'(3A4)') IIII
        HNAM2(3,NBISO2)=IIII
        IMIX2(NBISO2)=IBM
        DENS2(NBISO2)=DENS3(ISO)
        VOL2(NBISO2)=XVOLM(IBMOLD)
        ITOD2(NBISO2)=0
   90   CONTINUE
      ENDIF
  100 CONTINUE ! end of loop over microlib mixtures.
*----
*  RELEASE MEMORY
*----
      DEALLOCATE(INVELSB,BETARB,CHIRSB,INVELS,BETAR,CHIRS,LAMB)
      IF(NISOTS.GT.0) DEALLOCATE(ISOTS)
      DEALLOCATE(LXS,XS,SS2D,SIGS,NWT0)
      DEALLOCATE(LENGDP,LENGDX,ISADRX,XVOLM)
      IF(NADRX.GT.0) DEALLOCATE(IADRX)
      DEALLOCATE(FACT,DENS1,INOMIS,IRESM,ITOTM)
*----
*  COMPUTE DEPLETION CHAIN DATA
*----
      CALL XDDSET(YLDS,MY1*MY2,0.0)
      CALL XDDSET(DECAYC,MD1*MD2,0.0)
      VTOT=0.0D0
      DO 110 IBM=1,NMIX
      IF(MIXC(IBM).NE.0) VTOT=VTOT+VOLMI2(NMIX)
  110 CONTINUE
      DO 120 IBM=1,NMIX
      IBMOLD=MIXC(IBM)
      DO 120 ICAL=1,NCAL
      WEIGHT=TERP(ICAL,IBM)
      IF(WEIGHT.EQ.0.0) GO TO 120
      WRITE(TEXT12,'(4Hcalc,I8)') ICAL
      CALL LCMSIX(IPSAP,TEXT12,1) ! step up to calc
      CALL LCMSIX(IPSAP,'info',1)
      CALL LCMGET(IPSAP,'NISF',NISF)
      IF(NISF+NMAC.GT.MY1) CALL XABORT('SCRLIB: MY1 OVERFLOW')
      CALL LCMGET(IPSAP,'NISP',NISP)
      IF(NISP.GT.MY2) CALL XABORT('SCRLIB: MY2 OVERFLOW')
      CALL LCMGET(IPSAP,'NISOTS',NISOTS2)
      IF(NISOTS2.GT.NISOTS) CALL XABORT('SCRLIB: NISOTS OVERFLOW')
      CALL LCMSIX(IPSAP,' ',2)
      WRITE(TEXT12,'(4Hmili,I8)') IBMOLD
      CALL LCMSIX(IPSAP,TEXT12,1) ! step up to mili
      IF(MY1*MY2.GT.0) THEN
        CALL LCMLEN(IPSAP,'YLDS',ILONG,ITYLCM)
        IF(ILONG.NE.(NISF+NMAC)*NISP) CALL XABORT('SCRLIB: BAD YLDS.')
        ALLOCATE(YLDS2(NISF+NMAC,NISP))
        CALL LCMGET(IPSAP,'YLDS',YLDS2)
        DO IY1=1,NISF+NMAC
          DO IY2=1,NISP
            YLDS(IY1,IY2)=YLDS(IY1,IY2)+WEIGHT*YLDS2(IY1,IY2)*
     >      VOLMI2(IBM)/VTOT
          ENDDO
        ENDDO
        DEALLOCATE(YLDS2)
      ENDIF
      IF(MD1*MD2.GT.0) THEN
        CALL LCMLEN(IPSAP,'DECAYC',ILONG,ITYLCM)
        IF(ILONG.NE.NLAM*NISOTS2) CALL XABORT('SCRLIB: BAD DECAYC.')
        ALLOCATE(DECAY2(NLAM,NISOTS2))
        CALL LCMGET(IPSAP,'DECAYC',DECAY2)
        DO ID1=1,NLAM
          DO ID2=1,NISOTS2
            DECAYC(ID1,ID2)=DECAYC(ID1,ID2)+WEIGHT*DECAY2(ID1,ID2)*
     >      VOLMI2(IBM)/VTOT
          ENDDO
        ENDDO
        DEALLOCATE(DECAY2)
      ENDIF
      CALL LCMSIX(IPSAP,' ',2)
      CALL LCMSIX(IPSAP,' ',2)
  120 CONTINUE
*----
*  MICROLIB FINALIZATION
*----
      IF(.NOT.LRES) THEN
        CALL XDISET(ISTATE,NSTATE,0)
        ISTATE(1)=NMIX
        ISTATE(2)=NBISO2
        ISTATE(3)=NGRP
        ISTATE(4)=NL
        ISTATE(5)=ITRANC
        ISTATE(7)=1
        IF(ITER.EQ.3) ISTATE(12)=NMIX
        ISTATE(13)=NED2
        ISTATE(14)=NMIX
        ISTATE(18)=1
        ISTATE(19)=NPRC
        ISTATE(20)=0
        ISTATE(22)=MAXISO/NMIX
        ISTATE(24)=IDF
        IF(NBISO2.EQ.0) CALL XABORT('SCRLIB: NBISO2=0.')
        CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE)
        CALL LCMPUT(IPLIB,'MIXTURESVOL',NMIX,2,VOLMI2)
        CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO2,3,HUSE2)
        CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO2,3,HNAM2)
        CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2)
        CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO2,1,IMIX2)
        CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2)
        IF(NED2.GT.0) CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2)
        CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO2,1,ITOD2)
      ELSE IF(LRES.AND.(NISOP.GT.0)) THEN
        CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2)
        CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2)
      ENDIF
      IF(IMPX.GT.5) CALL LCMLIB(IPLIB)
      IACCS=1
*----
*  COMPUTE THE MACROSCOPIC X-SECTIONS
*----
      IF((ITER.NE.0).AND.(ITER.NE.3)) GO TO 280
      CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
      MAXMIX=ISTATE(1)
      IF(MAXMIX.NE.NMIX) CALL XABORT('SPHLIB: INVALID NMIX.')
      NBISO=ISTATE(2)
      ALLOCATE(MASK(MAXMIX),MASKL(NGRP))
      ALLOCATE(ISONA(3*NBISO),ISOMI(NBISO),DENIS(NBISO))
      CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA)
      CALL LCMGET(IPLIB,'ISOTOPESMIX',ISOMI)
      CALL LCMGET(IPLIB,'ISOTOPESDENS',DENIS)
      CALL XDLSET(MASK,MAXMIX,.TRUE.)
      CALL XDLSET(MASKL,NGRP,.TRUE.)
      ITSTMP=0
      TMPDAY(1)=0.0
      TMPDAY(2)=0.0
      TMPDAY(3)=0.0
      CALL LIBMIX(IPLIB,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,MASK,MASKL,
     1 ITSTMP,TMPDAY)
      DEALLOCATE(MASKL,MASK)
      DEALLOCATE(DENIS,ISOMI,ISONA)
*----
*  PROCESS ADF INFORMATION
*----
      IF(NSURFD.GT.0) THEN
        ALLOCATE(HADF(NSURFD),ADF2(NGRP,NSURFD))
        CALL XDRSET(ADF2,NGRP*NSURFD,0.0)
        DO 150 ICAL=1,NCAL
        WEIGHT=TERP(ICAL,1)
        IF(WEIGHT.EQ.0.0) GO TO 150
        WRITE(TEXT12,'(4Hcalc,I8)') ICAL
        CALL LCMSIX(IPSAP,TEXT12,1) ! step up to calc
        CALL LCMSIX(IPSAP,'outflx',1)
        CALL LCMGET(IPSAP,'SURFLX',SURFLX)
        CALL LCMSIX(IPSAP,' ',2)
        CALL LCMSIX(IPSAP,' ',2)
        DO I=1,NSURFD
          WRITE(HADF(I),'(3HFD_,I5.5)') I
          DO IGR=1,NGRP
            ADF2(IGR,I)=ADF2(IGR,I)+WEIGHT*SURFLX(I,IGR)/SURF(I)
          ENDDO
        ENDDO
  150   CONTINUE
        CALL LCMSIX(IPLIB,'MACROLIB',1)
        CALL LCMSIX(IPLIB,'ADF',1)
        CALL LCMPUT(IPLIB,'NTYPE',1,1,NSURFD)
        CALL LCMPTC(IPLIB,'HADF',8,NSURFD,HADF)
        DO I=1,NSURFD
          CALL LCMPUT(IPLIB,HADF(I),NGRP,2,ADF2(1,I))
        ENDDO
        CALL LCMSIX(IPLIB,' ',2)
        CALL LCMSIX(IPLIB,' ',2)
        DEALLOCATE(ADF2,HADF)
      ENDIF
      DEALLOCATE(SURFLX,SURF)
*----
*  INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS)
*----
      IF(B2.NE.0.0) THEN
        CALL LCMSIX(IPLIB,'MACROLIB',1)
        JPLIB=LCMGID(IPLIB,'GROUP')
        ALLOCATE(GAR1(NMIX),GAR2(NMIX))
        DO 270 IGR=1,NGRP
          KPLIB=LCMGIL(JPLIB,IGR)
          CALL LCMGET(KPLIB,'NTOT0',GAR1)
          CALL LCMGET(KPLIB,'DIFF',GAR2)
          DO 260 IBM=1,NMIX
            IF(MIXC(IBM).NE.0) GAR1(IBM)=GAR1(IBM)+B2*GAR2(IBM)
  260     CONTINUE
          CALL LCMPUT(KPLIB,'NTOT0',NMIX,2,GAR1)
  270   CONTINUE
        DEALLOCATE(GAR2,GAR1)
        CALL LCMSIX(IPLIB,' ',2)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
  280 DEALLOCATE(SPH,FLUX,VOLMI2,VOL2,DENS3,DENS2)
      DEALLOCATE(HNAM2,HUSE2,ITOD2,IMIX2)
      RETURN
      END
