path: root/Donjon/src/SCRLIB.f

*DECK SCRLIB
      SUBROUTINE SCRLIB(MAXNIS,MAXISO,IPLIB,IPMEM,IACCS,NMIX,NGRP,IMPX,
     1 HEQUI,HMASL,NCAL,ITER,MY1,MY2,MD1,MD2,TERP,NISO,LISO,HISO,CONC,
     2 ITODO,MIXC,LRES,LPURE,ILUPS,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.
* IPMEM   pointer to the memory-resident 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   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.
* 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 particularized isotopes including macro.
* 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.
* ITODO   non-depletion mask (=1 to force a user-selected isotope to be
*         non-depleting)
* 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
* LPURE   =.true. if the interpolation is a pure linear interpolation 
*         with TERP factors.
* ILUPS   up-scattering removing flag (=1 to remove up-scattering from
*         output cross-sections).
* B2      buckling
* VTOT    volume of updated core.
* YLDS    fission yields.
* DECAYC  radioactive decay constants.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLIB,IPMEM
      INTEGER MAXNIS,MAXISO,IACCS,NMIX,NGRP,IMPX,NCAL,ITER,MY1,MY2,MD1,
     1 MD2,NISO(NMIX),HISO(2,NMIX,MAXNIS),ITODO(NMIX,MAXNIS),MIXC(NMIX),
     2 ILUPS
      REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2
      DOUBLE PRECISION VTOT,YLDS(MY1,MY2),DECAYC(MD1,MD2)
      LOGICAL LISO(NMIX),LRES,LPURE
      CHARACTER HEQUI*4,HMASL*4
*----
*  LOCAL VARIABLES
*----
      INTEGER, PARAMETER::IOUT=6
      INTEGER, PARAMETER::MAXLOC=10
      INTEGER, PARAMETER::MAXDIV=3
      INTEGER, PARAMETER::MAXMAC=2
      INTEGER, PARAMETER::MAXREA=50
      INTEGER, PARAMETER::NSTATE=40
      TYPE(C_PTR) JPLIB,KPLIB,JPMEM,KPMEM,LPMEM,MPMEM
      REAL B2SAP, FACT0, WEIGHT
      INTEGER I, I0, IAD, IBM, IBMOLD, ICAL, ID1, IED2, IFISS, IGR,
     & ILENG, ILOC, ILONG, IMAC, IOF, IPRC, IREA, IREAF, IRES, IS2,
     & ISO, ISOKEP, ITRANC, ITSTMP, ITYLCM, IY1, IY2, JSIGS, JSO, 
     & JSS2D, JXS, KSO, KSO1, LMY1, LSO, MAXMIX, NADRX, NBISO, NBISO1,
     & NBISO2, NBISO2I, NBS1, NCALS, NDATAP, NDATAX, NED2, NISF, NISOP,
     & NISOT2, NISOTS, NISP, NL, NLAM, NLOC, NMAC, NMIL, NPARL, NPR,
     & NPRC, NREA, NSURFD, NVDIV
      CHARACTER TEXT12*12,HSMG*131,HVECT2(MAXREA)*8,NOMREA(MAXREA)*12,
     1 LOCTYP(MAXLOC)*4,LOCKEY(MAXLOC)*4,IDVAL(MAXDIV)*4,HHISO*8,
     2 NOMMAC(MAXMAC)*8,HRESID*8,HNISO*12
      INTEGER ISTATE(NSTATE),DIMSAP(50),INAME(2),IHRES(2)
      REAL VALDIV(MAXDIV),TMPDAY(3)
      LOGICAL LUSER,LSPH,LMASL,LSTRD
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX2,ITOTM,IRESM,IADRX,
     1 ISOTS,LOCAD,ISADRX,LENGDX,LENGDP,IDATA,ISONA,ISOMI,ITOD2,ISTY1,
     2 ISTY2,IPIFI,IMICR,ITOD1,JJSO,IPYMIX
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INOMIS,HUSE2,HNAM2,IPYNAM
      REAL, ALLOCATABLE, DIMENSION(:) :: DENS2,DENS3,VOL2,VOLMI2,SPH,
     1 ENER,XVOLM,CONCE,TAUXFI,NWT0,SIGS,SS2D,XS,RVALO,FLUXS,RDATA,
     2 SIGSB,SS2DB,XSB,DENIS,GAR1,GAR2,LAMB,CHIRS,BETAR,INVELS,CHIRSB,
     3 BETARB,INVELSB,SURF,FMASL
      REAL, ALLOCATABLE, DIMENSION(:,:) :: DENS1,FACT,YLDS2,DECAY2,
     1 SURFLX
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: DENS0,FLUX,ADF2
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: YLDSM
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LXS,MASK,MASKL
      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF
*----
*  RECOVER THE NUMBER OF DISCONTINUITY FACTORS
*----
      NSURFD=0
      CALL LCMSIX(IPMEM,'geom',1)
      CALL LCMLEN(IPMEM,'outgeom',ILONG,ITYLCM)
      IF(ILONG.NE.0) THEN
        CALL LCMSIX(IPMEM,'outgeom',1)
        CALL LCMLEN(IPMEM,'SURF',NSURFD,ITYLCM)
        IF(IMPX.GT.1) THEN
          WRITE(IOUT,'(42H SCRLIB: number of discontinuity factors =,
     1    I4/)') NSURFD
        ENDIF
        CALL LCMSIX(IPMEM,' ',2)
      ENDIF
      CALL LCMSIX(IPMEM,' ',2)
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(IMIX2(MAXISO),ITOD2(MAXISO),ISTY1(MAXISO),ISTY2(MAXISO),
     1 HUSE2(3,MAXISO),HNAM2(3,MAXISO))
      ALLOCATE(DENS2(MAXISO),DENS3(MAXISO),VOL2(MAXISO),VOLMI2(NMIX),
     1 FLUX(NMIX,NGRP,2),SPH(NGRP),FMASL(NMIX))
       ALLOCATE(HADF(NSURFD),ADF2(NMIX,NGRP,NSURFD))
*----
*  MICROLIB INITIALIZATION
*----
      VOLMI2(:NMIX)=0.0
      DENS2(:MAXISO)=0.0
      VOL2(:MAXISO)=0.0
      IMIX2(:MAXISO)=0
      ITOD2(:MAXISO)=0
      ISTY2(: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,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(1).')
         CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
           CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMI2)
         ELSE
           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)
         CALL LCMGET(IPLIB,'ISOTOPESTYPE',ISTY2)
         IF(NED2.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2)
         IF(NSURFD.GT.0) THEN
           CALL LCMSIX(IPLIB,'MACROLIB',1)
           CALL LCMLEN(IPLIB,'ADF',ILONG,ITYLCM)
           IF(ILONG.EQ.0) THEN
             CALL LCMLIB(IPLIB)
             CALL XABORT('SCRLIB: UNABLE TO FIND DIRECTORY ADF.')
           ENDIF
           CALL LCMSIX(IPLIB,'ADF',1)
           CALL LCMGTC(IPLIB,'HADF',8,NSURFD,HADF)
           DO I=1,NSURFD
             CALL LCMGET(IPLIB,HADF(I),ADF2(1,1,I))
           ENDDO
           CALL LCMSIX(IPLIB,' ',2)
           CALL LCMSIX(IPLIB,' ',2)
         ENDIF
      ENDIF
*----
*  RECOVER SAPHYB CHARACTERISTICS
*----
      CALL LCMLEN(IPMEM,'DIMSAP',ILENG,ITYLCM)
      IF(ILENG.EQ.0) CALL XABORT('SCRLIB: INVALID SAPHYB.')
      CALL LCMGET(IPMEM,'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) ! maximum number of isotopes in output tables
      IF(IMPX.GT.1) THEN
        WRITE(IOUT,'(30H SCRLIB: number of reactions =,I3)') NREA
        WRITE(IOUT,'(46H SCRLIB: number of radioactive decay reactions,
     1  2H =,I3)') NLAM
        WRITE(IOUT,'(46H SCRLIB: number of neutron-induced reactions =,
     1  I3)') NREA
        WRITE(IOUT,'(44H SCRLIB: number of particularized isotopes =,
     1  I4)') NISOP
        WRITE(IOUT,'(37H SCRLIB: number of macroscopic sets =,I2)') NMAC
        WRITE(IOUT,'(29H SCRLIB: number of mixtures =,I5)') NMIL
        WRITE(IOUT,'(36H SCRLIB: number of local variables =,I4)') NPARL
        WRITE(IOUT,'(33H SCRLIB: number of address sets =,I4)') NADRX
        WRITE(IOUT,'(33H SCRLIB: number of calculations =,I7)') NCALS
        WRITE(IOUT,'(34H SCRLIB: number of energy groups =,I4)') NGRP
        WRITE(IOUT,'(37H SCRLIB: number of precursor groups =,I4)') NPRC
        WRITE(IOUT,'(46H SCRLIB: maximum number of isotopes in output ,
     1  8Htables =,I4)') NISOTS
      ENDIF
      IF(NREA.GT.MAXREA) CALL XABORT('SCRLIB: MAXREA OVERFLOW(2)')
      IF(NMAC.GT.MAXMAC) CALL XABORT('SCRLIB: MAXMAC OVERFLOW')
*----
*  RECOVER INFORMATION FROM constphysiq DIRECTORY.
*----
      ALLOCATE(ENER(NGRP+1))
      CALL LCMSIX(IPMEM,'constphysiq',1)
      CALL LCMGET(IPMEM,'ENRGS',ENER)
      CALL LCMSIX(IPMEM,' ',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(IPMEM,'contenu',1)
      IREAF=0
      IF(NREA.GT.0) THEN
        CALL LCMGTC(IPMEM,'NOMREA',12,NREA,NOMREA)
        IF(IMPX.GT.1) THEN
          WRITE(IOUT,'(29H SCRLIB: Available reactions:/(1X,10A13))')
     1    (NOMREA(I),I=1,NREA)
        ENDIF
        DO IREA=1,NREA
          IF(NOMREA(IREA).EQ.'NU*FISSION') THEN
            IREAF=IREA
            EXIT
          ENDIF
        ENDDO
      ENDIF
      CALL LCMGET(IPMEM,'TOTMAC',ITOTM)
      CALL LCMGET(IPMEM,'RESMAC',IRESM)
      ALLOCATE(INOMIS(2,NISOP+NMAC),JJSO(NISOP+NMAC))
      NBISO1=NISOP
      IF(NISOP.GT.0) CALL LCMGET(IPMEM,'NOMISO',INOMIS)
      IF(NMAC.GT.0) THEN
        CALL LCMLEN(IPMEM,'NOMMAC',ILONG,ITYLCM)
        IF(ILONG.GT.2*MAXMAC) CALL XABORT('SCRLIB: MAXMAC OVERFLOW')
        CALL LCMGTC(IPMEM,'NOMMAC',8,NMAC,NOMMAC)
        HHISO='*MAC*RES'
        NBISO1=NBISO1+1
        READ(HHISO,'(2A4)') (INOMIS(I0,NBISO1),I0=1,2)
      ENDIF
      CALL LCMSIX(IPMEM,' ',2)
      IF(NBISO1.EQ.0) CALL XABORT('SCRLIB: NO CROSS SECTIONS FOUND.')
      IF(NBISO1.GT.MAXISO) CALL XABORT('SCRLIB: MAXISO OVERFLOW(2).')
*----
*  RECOVER INFORMATION FROM adresses DIRECTORY.
*----
      NL=0
      IF(NADRX.GT.0) THEN
        ALLOCATE(IADRX((NREA+2)*(NISOP+NMAC)*NADRX))
        CALL LCMSIX(IPMEM,'adresses',1)
        CALL LCMGET(IPMEM,'ADRX',IADRX)
        CALL LCMSIX(IPMEM,' ',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(IOUT,'(36H SCRLIB: number of Legendre orders =,I4)') NL
      ENDIF
*----
*  RECOVER INFORMATION FROM geom DIRECTORY.
*----
      CALL LCMSIX(IPMEM,'geom',1)
      ALLOCATE(XVOLM(NMIL))
      CALL LCMGET(IPMEM,'XVOLMT',XVOLM)
      ALLOCATE(SURFLX(NSURFD,NGRP),SURF(NSURFD))
      IF(NSURFD.GT.0) THEN
        CALL LCMSIX(IPMEM,'outgeom',1)
        CALL LCMGET(IPMEM,'SURF',SURF)
        CALL LCMSIX(IPMEM,' ',2)
      ENDIF
      CALL LCMSIX(IPMEM,' ',2)
*----
*  LOOP OVER SAPHYB MIXTURES TO COMPUTE DENS0(NMIL,NCAL,NBISO1)
*----
      JPMEM=LCMGID(IPMEM,'calc')
      ALLOCATE(DENS0(NMIL,NCAL,NBISO1))
      IF(NISOTS.GT.0) ALLOCATE(ISOTS(NISOTS*2))
      DENS0(:NMIL,:NCAL,:NBISO1)=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    KPMEM=LCMGIL(JPMEM,ICAL)
        CALL LCMSIX(KPMEM,'info',1)
        CALL LCMGET(KPMEM,'NISOTS',NISOT2)
        IF(NISOT2.GT.NISOTS) CALL XABORT('SCRLIB: NISOTS OVERFLOW.')
        IF(NISOT2.GT.0) CALL LCMGET(KPMEM,'ISOTS',ISOTS)
        CALL LCMSIX(KPMEM,' ',2)
        LPMEM=LCMGID(KPMEM,'mili')
        MPMEM=LCMGIL(LPMEM,IBMOLD)
        IF(NISOT2.GT.0) THEN
          CALL LCMGET(MPMEM,'CONCES',CONCE)
          DO ISO=1,NISOP
            INAME(1)=INOMIS(1,ISO)
            INAME(2)=INOMIS(2,ISO)
            DO IS2=1,NISOT2
              ISOKEP=IS2
              IF(INAME(1).NE.ISOTS(2*(IS2-1)+1)) CYCLE
              IF(INAME(2).NE.ISOTS(2*(IS2-1)+2)) CYCLE
              GO TO 20
            ENDDO
            CYCLE
   20       DENS0(IBMOLD,ICAL,ISO)=CONCE(ISOKEP)
          ENDDO
        ENDIF
      ENDDO
   30 CONTINUE
      DEALLOCATE(CONCE)
*----
*  LOOP OVER MICROLIB MIXTURES
*----
      YLDS(:MY1,:MY2)=0.0D0
      DECAYC(:MD1,:MD2)=0.0D0
      VTOT=0.0D0
      DO 40 IBM=1,NMIX
      IBMOLD=MIXC(IBM)
      IF(IBMOLD.NE.0) VTOT=VTOT+XVOLM(IBMOLD)
   40 CONTINUE
      ALLOCATE(YLDSM(MY1,MY2))
      ALLOCATE(ISADRX(NMIL),LENGDX(NMIL),LENGDP(NMIL),ITOD1(NBISO1))
      ALLOCATE(TAUXFI(NISOP+NMAC),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))
      LAMB(:NPRC)=0.0
      CHIRS(:NGRP*NPRC)=0.0
      BETAR(:NPRC)=0.0
      INVELS(:NGRP)=0.0
      FMASL(:NMIX)=0.0
      ALLOCATE(CHIRSB(NGRP*NPRC),BETARB(NPRC),INVELSB(NGRP))
      ALLOCATE(DENS1(NBISO1,NCAL),FACT(NBISO1,NCAL))
      JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',(NISOP+NMAC)*NMIX)
*
      DO 180 IBM=1,NMIX
      IBMOLD=MIXC(IBM)
      IF(IBMOLD.EQ.0) GO TO 180
      IF(NISO(IBM).GT.MAXNIS) CALL XABORT('SCRLIB: MAXNIS OVERFLOW.')
      VOLMI2(IBM)=XVOLM(IBMOLD)
      IMAC=ITOTM(IBMOLD)
      IRES=IRESM(IBMOLD)
*----
*  RECOVER ITOD1(NBISO1) INDICES.
*----
      ITOD1(:NBISO1)=0
      DO 50 ISO=1,NBISO1 ! Saphyb isotope
        INAME(1)=INOMIS(1,ISO)
        INAME(2)=INOMIS(2,ISO)
        DO KSO=1,NISO(IBM) ! user-selected isotope
          IF((INAME(1).EQ.HISO(1,IBM,KSO)).AND.
     1       (INAME(2).EQ.HISO(2,IBM,KSO))) THEN
            ITOD1(ISO)=ITODO(IBM,KSO)
            GO TO 50
          ENDIF
        ENDDO
   50 CONTINUE
*----
*  COMPUTE THE NUMBER DENSITIES OF EACH ELEMENTARY CALCULATION.
*----
      DENS1(:NBISO1,:NCAL)=0.0
      DENS3(:NBISO1)=0.0
      DO ICAL=1,NCAL
        WEIGHT=TERP(ICAL,IBM)
        IF(WEIGHT.EQ.0.0) CYCLE
        DO ISO=1,NISOP
          LUSER=.FALSE.
          INAME(1)=INOMIS(1,ISO)
          INAME(2)=INOMIS(2,ISO)
          KSO1=0
          DO KSO=1,NISO(IBM) ! user-selected isotope
            IF((INAME(1).EQ.HISO(1,IBM,KSO)).AND.
     1         (INAME(2).EQ.HISO(2,IBM,KSO))) THEN
              KSO1=KSO
              LUSER=(CONC(IBM,KSO1).NE.-99.99)
              GO TO 60
            ENDIF
          ENDDO
   60     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
      FACT(:NBISO1,:NCAL)=1.0
      IF(.NOT.LPURE) THEN
        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
      ENDIF
*----
*  INITIALIZE WORKING ARRAYS.
*----
      TAUXFI(:NBISO1)=0.0
      NWT0(:NGRP)=0.0
      SIGS(:NGRP*NL*NBISO1)=0.0
      SS2D(:NGRP*NGRP*NL*NBISO1)=0.0
      XS(:NGRP*NREA*NBISO1)=0.0
      LXS(:NREA)=.FALSE.
      YLDSM(:MY1,:MY2)=0.0D0
*----
*  MAIN LOOP OVER ELEMENTARY CALCULATIONS
*----
      TEXT12='*MAC*RES'
      READ(TEXT12,'(2A4)') IHRES(1),IHRES(2)
      LSTRD=.FALSE.
      B2SAP=B2
      DO 80 ICAL=1,NCAL
      WEIGHT=TERP(ICAL,IBM)
      IF(WEIGHT.EQ.0.0) GO TO 80
*----
*  RECOVER INFORMATION FROM caldir DIRECTORY.
*----
      KPMEM=LCMGIL(JPMEM,ICAL)
      IF(NPRC.GT.0) THEN
        CHIRSB(:NGRP*NPRC)=0.0
        BETARB(:NPRC)=0.0
        INVELSB(:NGRP)=0.0
      ENDIF
      CALL LCMSIX(KPMEM,'info',1)
      LSPH=.FALSE.
      LMASL=.FALSE.
      IF(NPARL.GT.0) THEN
        CALL LCMGET(KPMEM,'NLOC',NLOC)
        IF(NLOC.GT.MAXLOC) CALL XABORT('SCRLIB: MAXLOC OVERFLOW')
        CALL LCMGTC(KPMEM,'LOCTYP',4,NLOC,LOCTYP)
        CALL LCMGTC(KPMEM,'LOCKEY',4,NLOC,LOCKEY)
        ALLOCATE(LOCAD(NLOC+1))
        CALL LCMGET(KPMEM,'LOCADR',LOCAD)
        DO ILOC=1,NLOC
          LSPH=LSPH.OR.((LOCTYP(ILOC).EQ.'EQUI').AND.
     1                  (LOCKEY(ILOC).EQ.HEQUI))
          LMASL=LMASL.OR.((LOCTYP(ILOC).EQ.'MASL').AND.
     1                    (LOCKEY(ILOC).EQ.HMASL))
        ENDDO
      ENDIF
      IF((HEQUI.NE.' ').AND.(.NOT.LSPH)) THEN
        WRITE(HSMG,'(46HSCRLIB: UNABLE TO FIND A LOCAL PARAMETER SET O,
     1  25HF TYPE EQUI WITH KEYWORD ,A4,1H.)') HEQUI
        CALL XABORT(HSMG)
      ELSE IF((HMASL.NE.' ').AND.(.NOT.LMASL)) THEN
        WRITE(HSMG,'(46HSCRLIB: UNABLE TO FIND A LOCAL PARAMETER SET O,
     1  25HF TYPE MASL WITH KEYWORD ,A4,1H.)') HMASL
        CALL XABORT(HSMG)
      ENDIF
      CALL LCMGET(KPMEM,'ISADRX',ISADRX)
      CALL LCMGET(KPMEM,'LENGDX',LENGDX)
      CALL LCMGET(KPMEM,'LENGDP',LENGDP)
      CALL LCMGET(KPMEM,'NISF',NISF)
      IF(NISF+NMAC.NE.MY1) CALL XABORT('SCRLIB: MY1 ERROR')
      CALL LCMGET(KPMEM,'NISP',NISP)
      IF(NISP.NE.MY2) CALL XABORT('SCRLIB: MY2 ERROR')
      CALL LCMGET(KPMEM,'NISOTS',NISOT2)
      IF(NISOT2.GT.NISOTS) CALL XABORT('SCRLIB: NISOTS OVERFLOW.')
      IF(NISOT2.GT.0) CALL LCMGET(KPMEM,'ISOTS',ISOTS)
      CALL LCMSIX(KPMEM,' ',2)
      CALL LCMSIX(KPMEM,'divers',1)
      CALL LCMLEN(KPMEM,'NVDIV',ILENG,ITYLCM)
      IF(ILENG.EQ.0) THEN
        NVDIV=0
      ELSE
        CALL LCMGET(KPMEM,'NVDIV',NVDIV)
      ENDIF
      IF(NVDIV.GT.0) THEN
        IF(NVDIV.GT.MAXDIV) CALL XABORT('SCRLIB: MAXDIV OVERFLOW.')
        CALL LCMGTC(KPMEM,'IDVAL',4,NVDIV,IDVAL)
        CALL LCMGET(KPMEM,'VALDIV',VALDIV)
        DO I=1,NVDIV
          IF(IMPX.GT.3) THEN
            WRITE(IOUT,'(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
*
      CALL LCMLEN(KPMEM,'NPR',ILONG,ITYLCM)
      IF((NPRC.GT.0).AND.(ILONG.EQ.1)) THEN
        CALL LCMGET(KPMEM,'NPR',NPR)
        IF(NPR.NE.NPRC) CALL XABORT('SCRLIB: NPR INCONSISTENCY(1).')
        CALL LCMGET(KPMEM,'LAMBRS',LAMB)
        CALL LCMGET(KPMEM,'CHIRS',CHIRSB)
        CALL LCMGET(KPMEM,'BETARS',BETARB)
        CALL LCMGET(KPMEM,'INVELS',INVELSB)
      ENDIF
      CALL LCMSIX(KPMEM,' ',2)
*----
*  SELECT SAPHYB MIXTURE IBMOLD.
*----
      IF(NADRX.EQ.0) CALL XABORT('SCRLIB: NO ADDRESS SETS AVAILABLE.')
      LPMEM=LCMGID(KPMEM,'mili')
      MPMEM=LCMGIL(LPMEM,IBMOLD)
      SPH(:NGRP)=1.0
      IF(LSPH) THEN
        ALLOCATE(RVALO(LOCAD(NLOC+1)-1))
        CALL LCMGET(MPMEM,'RVALOC',RVALO)
        DO ILOC=1,NLOC
          IF((LOCTYP(ILOC).EQ.'EQUI').AND.(LOCKEY(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(LMASL) THEN
        ALLOCATE(RVALO(LOCAD(NLOC+1)-1))
        CALL LCMGET(MPMEM,'RVALOC',RVALO)
        DO ILOC=1,NLOC
          IF((LOCTYP(ILOC).EQ.'MASL').AND.(LOCKEY(ILOC).EQ.HMASL))
     1    THEN
            IF(LOCAD(ILOC+1)-LOCAD(ILOC).NE.1) THEN
              CALL XABORT('SCRLIB: INVALID NUMBER OF COMPONENTS FOR '
     1        //'MASL')
            ENDIF
            FMASL(IBM)=FMASL(IBM)+WEIGHT*RVALO(LOCAD(ILOC))
          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(MPMEM,'FLUXS',FLUXS)
      CALL LCMGET(MPMEM,'RDATAX',RDATA)
      CALL LCMGET(MPMEM,'IDATAP',IDATA)
      DO I=1,NGRP
        FLUXS(I)=FLUXS(I)/XVOLM(IBMOLD)
        NWT0(I)=NWT0(I)+WEIGHT*FLUXS(I)/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)
          JXS=(ISO-1)*NGRP*NREA
          JSIGS=(ISO-1)*NGRP*NL
          JSS2D=(ISO-1)*NGRP*NGRP*NL
          CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP,
     1    ISO,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS)
          CALL SCRSXS(NGRP,NL,NREA,IREAF,NOMREA,LXS,B2SAP,FACT0,
     1    WEIGHT,SPH,FLUXS,XSB,SIGSB,SS2DB,LPURE,XS(JXS+1),
     2    SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(ISO))
        ENDDO
        IF(IRES.NE.0) THEN
          FACT0=1.0
          JXS=NISOP*NGRP*NREA
          JSIGS=NISOP*NGRP*NL
          JSS2D=NISOP*NGRP*NGRP*NL
          CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP,
     1    NISOP+IRES,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS)
          CALL SCRSXS(NGRP,NL,NREA,IREAF,NOMREA,LXS,B2SAP,FACT0,
     1    WEIGHT,SPH,FLUXS,XSB,SIGSB,SS2DB,LPURE,XS(JXS+1),
     2    SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(NISOP+1))
        ENDIF
      ELSE IF(IMAC.NE.0) THEN
        FACT0=1.0
        JXS=NISOP*NGRP*NREA
        JSIGS=NISOP*NGRP*NL
        JSS2D=NISOP*NGRP*NGRP*NL
        CALL SPHSXS(NREA,NISOP+NMAC,NADRX,NGRP,NL,NDATAX,NDATAP,
     1  NISOP+IMAC,IAD,IADRX,RDATA,IDATA,NOMREA,SIGSB,SS2DB,XSB,LXS)
        CALL SCRSXS(NGRP,NL,NREA,IREAF,NOMREA,LXS,B2SAP,FACT0,WEIGHT,
     1  SPH,FLUXS,XSB,SIGSB,SS2DB,LPURE,XS(JXS+1),SIGS(JSIGS+1),
     2  SS2D(JSS2D+1),TAUXFI(NISOP+1))
      ELSE
        CALL XABORT('SCRLIB: NO MACROSCOPIC SET.')
      ENDIF
      DEALLOCATE(XSB,SS2DB,SIGSB,IDATA,RDATA,FLUXS)
*
      CALL LCMLEN(MPMEM,'cinetique',ILONG,ITYLCM)
      IF((NPRC.GT.0).AND.(ILONG.NE.0)) THEN
        CALL LCMSIX(MPMEM,'cinetique',1)
        CALL LCMGET(MPMEM,'NPR',NPR)
        IF(NPR.NE.NPRC) CALL XABORT('SCRLIB: NPR INCONSISTENCY(2).')
        CALL LCMGET(MPMEM,'LAMBRS',LAMB)
        CALL LCMGET(MPMEM,'CHIRS',CHIRSB)
        CALL LCMGET(MPMEM,'BETARS',BETARB)
        CALL LCMGET(MPMEM,'INVELS',INVELSB)
        CALL LCMSIX(MPMEM,' ',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
*----
*  COMPUTE DEPLETION CHAIN DATA
*----
      IF(MY1*MY2.GT.0) THEN
        CALL LCMLEN(MPMEM,'YLDS',ILONG,ITYLCM)
        IF(ILONG.NE.MY1*MY2) CALL XABORT('SCRLIB: BAD YLDS.')
        ALLOCATE(YLDS2(MY1,MY2))
        CALL LCMGET(MPMEM,'YLDS',YLDS2)
        DO IY1=1,MY1
          DO IY2=1,MY2
            YLDSM(IY1,IY2)=YLDSM(IY1,IY2)+WEIGHT*YLDS2(IY1,IY2)
            YLDS(IY1,IY2)=YLDS(IY1,IY2)+WEIGHT*YLDS2(IY1,IY2)*
     >      VOLMI2(IBM)/VTOT
          ENDDO
        ENDDO
        DEALLOCATE(YLDS2)
      ENDIF
      IF((MD1*MD2.GT.0).AND.(NISOT2.GT.0)) THEN
        CALL LCMLEN(MPMEM,'DECAYC',ILONG,ITYLCM)
        IF(ILONG.NE.NLAM*NISOT2) CALL XABORT('SCRLIB: BAD DECAYC.')
        ALLOCATE(DECAY2(NLAM,NISOT2))
        CALL LCMGET(MPMEM,'DECAYC',DECAY2)
        DO ISO=1,NISOP
          INAME(1)=INOMIS(1,ISO)
          INAME(2)=INOMIS(2,ISO)
          DO IS2=1,NISOT2
            ISOKEP=IS2
            IF(INAME(1).NE.ISOTS(2*(IS2-1)+1)) CYCLE
            IF(INAME(2).NE.ISOTS(2*(IS2-1)+2)) CYCLE
            GO TO 70
          ENDDO
          CYCLE
   70     DO ID1=1,NLAM
            DECAYC(ID1,ISO)=DECAYC(ID1,ISO)+WEIGHT*DECAY2(ID1,ISOKEP)*
     >      VOLMI2(IBM)/VTOT
          ENDDO
        ENDDO
        DEALLOCATE(DECAY2)
      ENDIF
   80 CONTINUE ! end of loop over elementary calculations.
*----
*  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.'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 90 IED2=1,NED2
        IF(HVECT2(IED2).EQ.NOMREA(IREA)(:8)) GO TO 100
        IF(HVECT2(IED2).EQ.'NFTOT') GO TO 100
   90   CONTINUE
        NED2=NED2+1
        IF(NED2.GT.MAXREA) CALL XABORT('SCRLIB: MAXREA OVERFLOW(3).')
        IF(NOMREA(IREA).EQ.'FISSION') THEN
          HVECT2(NED2)='NFTOT'
        ELSE
          HVECT2(NED2)=NOMREA(IREA)(:8)
        ENDIF
  100   CONTINUE
      ENDDO
*----
*  SET FLAG LSTRD
*----
      LSTRD=.TRUE.
      DO IREA=1,NREA
        IF(NOMREA(IREA).EQ.'FUITES') THEN
          IF(LXS(IREA).AND.(B2SAP.NE.0.0)) LSTRD=.FALSE.
          EXIT
        ENDIF
      ENDDO
*----
*  SAVE CROSS SECTIONS IN MICROLIB FOR MIXTURE IBM
*----
      ISTY1(:NBISO1)=0
      JJSO(:NBISO1)=0
      NBISO2I=NBISO2
      IF(NISOP.NE.0) THEN
        HRESID=' '
        DO ISO=1,NISOP
          JXS=(ISO-1)*NGRP*NREA
          JSIGS=(ISO-1)*NGRP*NL
          JSS2D=(ISO-1)*NGRP*NGRP*NL
          INAME(1)=INOMIS(1,ISO)
          INAME(2)=INOMIS(2,ISO)
          CALL SCRFND(MAXISO,NBISO2I,NBISO2,INAME,IBM,HRESID,HUSE2,
     1    HNAM2,IMIX2,JJSO(ISO))
          KPLIB=LCMDIL(JPLIB,JJSO(ISO)) ! step up isot JJSO(ISO)
          CALL SCRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(JXS+1),
     1    SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(ISO),LXS,LAMB,CHIRS,BETAR,
     2    INVELS,INAME,LSTRD,LPURE,ILUPS,ITRANC,IFISS)
          IF(MY1*MY2.GT.0) CALL SCRNDF(IMPX,NISOP+NMAC,ISO,IBM,INOMIS,
     1    IPMEM,KPLIB,NCAL,TERP(1,IBM),MY1,MY2,YLDSM,ISTY1(ISO))
        ENDDO
        IF(IRES.NE.0) THEN
          HRESID=NOMMAC(IRES)
          JXS=NISOP*NGRP*NREA
          JSIGS=NISOP*NGRP*NL
          JSS2D=NISOP*NGRP*NGRP*NL
          CALL SCRFND(MAXISO,NBISO2I,NBISO2,IHRES,IBM,HRESID,HUSE2,
     1    HNAM2,IMIX2,JJSO(NISOP+1))
          KPLIB=LCMDIL(JPLIB,JJSO(NISOP+1)) ! step up isot JJSO(NISOP+1)
          CALL SCRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(JXS+1),
     1    SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(NISOP+1),LXS,LAMB,CHIRS,
     2    BETAR,INVELS,IHRES,LSTRD,LPURE,ILUPS,ITRANC,IFISS)
          IF(MY1*MY2.GT.0) CALL SCRNDF(IMPX,NISOP+NMAC,NISOP+IRES,
     1    IBM,INOMIS,IPMEM,KPLIB,NCAL,TERP(1,IBM),MY1,MY2,YLDSM,
     2    ISTY1(NISOP+IRES))
        ENDIF
      ELSE IF(IMAC.NE.0) THEN
        HRESID=NOMMAC(IMAC)
        JXS=NISOP*NGRP*NREA
        JSIGS=NISOP*NGRP*NL
        JSS2D=NISOP*NGRP*NGRP*NL
        CALL SCRFND(MAXISO,NBISO2I,NBISO2,IHRES,IBM,HRESID,HUSE2,HNAM2,
     1  IMIX2,JJSO(1))
        KPLIB=LCMDIL(JPLIB,JJSO(1)) ! step up isot JJSO(1)
        CALL SCRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(JXS+1),
     1  SIGS(JSIGS+1),SS2D(JSS2D+1),TAUXFI(NISOP+1),LXS,LAMB,CHIRS,
     2  BETAR,INVELS,IHRES,LSTRD,LPURE,ILUPS,ITRANC,IFISS)
      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 110 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
              ITOD2(JSO)=ITODO(IBM,KSO)
              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(JJSO(ISO).EQ.JSO) DENS2(JSO)=DENS2(JSO)+DENS3(ISO)
                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 110
            ENDIF
          ENDDO
          WRITE(HSMG,'(31HSCRLIB: UNABLE TO FIND ISOTOPE ,2A4,6H IN MI,
     1    5HXTURE,I8,1H.)') HISO(1,IBM,KSO),HISO(2,IBM,KSO),IBM
          CALL XABORT(HSMG)
  110   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(1,ISO).EQ.HUSE2(1,JSO)).AND.
     1          (INOMIS(2,ISO).EQ.HUSE2(2,JSO))) THEN
                DENS2(JSO)=0.0
                VOL2(JSO)=0.0
                CYCLE
              ENDIF
            ENDDO
          ENDIF
        ENDDO
        DO 130 ISO=1,NBISO1 ! Saphyb isotope
        INAME(1)=INOMIS(1,ISO)
        INAME(2)=INOMIS(2,ISO)
        IF(.NOT.LISO(IBM)) THEN
*         --ONLY option
          DO KSO=1,NISO(IBM) ! user-selected isotope
            IF((INAME(1).EQ.HISO(1,IBM,KSO)).AND.
     1         (INAME(2).EQ.HISO(2,IBM,KSO))) GO TO 120
          ENDDO
          GO TO 130
        ENDIF
  120   JSO=JJSO(ISO)
        IF(JSO.GT.0) THEN
          ITOD2(JSO)=ITOD1(ISO)
          ISTY2(JSO)=ISTY1(ISO)
          DENS2(JSO)=DENS2(JSO)+DENS3(ISO)
          VOL2(JSO)=VOL2(JSO)+XVOLM(IBMOLD)
        ENDIF
  130   CONTINUE
      ENDIF
*----
*  SET PIFI INFORMATION
*----
      ALLOCATE(IMICR(NBISO1))
      IMICR(:NBISO1)=0
      NBS1=0
      DO 140 JSO=1,NBISO2 ! microlib isotope
      IF(IMIX2(JSO).EQ.IBM) THEN
        NBS1=NBS1+1
        IF(NBS1.GT.NBISO1) CALL XABORT('SCRLIB: NBISO1 OVERFLOW.')
        IMICR(NBS1)=JSO
      ENDIF
  140 CONTINUE
      DO 170 ISO=1,NBS1 ! Saphyb isotope
      JSO=IMICR(ISO)
      KPLIB=LCMDIL(JPLIB,JSO) ! step up isot JSO
      CALL LCMLEN(KPLIB,'PYIELD',LMY1,ITYLCM)
      IF(LMY1.GT.0) THEN
        ALLOCATE(IPYNAM(2,LMY1),IPYMIX(LMY1),IPIFI(LMY1))
        IPIFI(:LMY1)=0
        CALL LCMGET(KPLIB,'PYNAM',IPYNAM)
        CALL LCMGET(KPLIB,'PYMIX',IPYMIX)
        DO 160 IY1=1,LMY1
        INAME(1)=IPYNAM(1,IY1)
        INAME(2)=IPYNAM(2,IY1)
        WRITE(HNISO,'(2A4)') (INAME(I0),I0=1,2)
        IF(HNISO.NE.' ') THEN
          DO 150 KSO=1,NBS1
          LSO=IMICR(KSO)
          IF((INAME(1).EQ.HUSE2(1,LSO)).AND.(INAME(2).EQ.HUSE2(2,LSO))
     1    .AND.(IPYMIX(IY1).EQ.IMIX2(LSO))) THEN
            IPIFI(IY1)=LSO
            GO TO 160
          ENDIF
  150     CONTINUE
          IF(IPIFI(IY1).EQ.0) THEN
            WRITE(HSMG,'(40HSCRLIB: FAILURE TO FIND FISSILE ISOTOPE ,
     1      A12,25H AMONG MICROLIB ISOTOPES.)') HNISO
            CALL XABORT(HSMG)
          ENDIF
        ENDIF
  160   CONTINUE
        CALL LCMPUT(KPLIB,'PIFI',LMY1,1,IPIFI)
        DEALLOCATE(IPIFI,IPYMIX,IPYNAM)
      ENDIF
  170 CONTINUE
      DEALLOCATE(IMICR)
  180 CONTINUE ! end of loop over microlib mixtures.
*----
*  RELEASE MEMORY
*----
      DEALLOCATE(FACT,DENS1)
      DEALLOCATE(INVELSB,BETARB,CHIRSB)
      DEALLOCATE(INVELS,BETAR,CHIRS,LAMB)
      DEALLOCATE(LXS)
      DEALLOCATE(XS,SS2D,SIGS,NWT0,TAUXFI)
      DEALLOCATE(ITOD1,LENGDP,LENGDX,ISADRX)
      DEALLOCATE(YLDSM)
      IF(NISOTS.GT.0) DEALLOCATE(ISOTS)
      IF(NADRX.GT.0) DEALLOCATE(IADRX)
      DEALLOCATE(DENS0,XVOLM,JJSO,INOMIS,IRESM,ITOTM)
*----
*  MICROLIB FINALIZATION
*----
      IF(.NOT.LRES) THEN
        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)=MY1
        ISTATE(22)=MAXISO/NMIX
        IF(NSURFD.GT.0) ISTATE(24)=2 ! ADF information
        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)
        CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO2,1,ISTY2)
      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('SCRLIB: 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)
      MASK(:MAXMIX)=.TRUE.
      MASKL(:NGRP)=.TRUE.
      ITSTMP=0
      TMPDAY(1)=0.0
      TMPDAY(2)=0.0
      TMPDAY(3)=0.0
      CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM)
      IF(ILONG.NE.0) CALL LCMDEL(IPLIB,'MACROLIB')
      CALL LIBMIX(IPLIB,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,MASK,MASKL,
     1 ITSTMP,TMPDAY)
      DEALLOCATE(MASKL,MASK)
      DEALLOCATE(DENIS,ISOMI,ISONA)
      IF(NSURFD.GT.0) THEN
        CALL LCMSIX(IPLIB,'MACROLIB',1)
        CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
        ISTATE(12)=2
        CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE)
        CALL LCMSIX(IPLIB,' ',2)
      ENDIF
*----
*  SAVE MASL INFORMATION
*----
      IF(HMASL.NE.' ') THEN
        CALL LCMSIX(IPLIB,'MACROLIB',1)
        CALL LCMPUT(IPLIB,'MASL',NMIX,2,FMASL)
        CALL LCMSIX(IPLIB,' ',2)
      ENDIF
*----
*  INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS)
*----
      IF(B2.NE.0.0) THEN
        IF(IMPX.GT.0) WRITE(IOUT,'(/31H SCRLIB: INCLUDE LEAKAGE IN THE,
     1  14H MACROLIB (B2=,1P,E12.5,2H).)') B2
        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
*----
*  PROCESS ADF INFORMATION
*----
  280 IF(NSURFD.GT.0) THEN
        DO 285 IBM=1,NMIX ! mixtures in Macrolib
          IF(MIXC(IBM).NE.0) ADF2(IBM,:NGRP,:NSURFD)=0.0
  285   CONTINUE
        DO 300 ICAL=1,NCAL
        DO 290 IBM=1,NMIX ! mixtures in Macrolib
        IF(MIXC(IBM).EQ.0) GO TO 290
        WEIGHT=TERP(ICAL,IBM)
        IF(WEIGHT.EQ.0.0) GO TO 290
        KPMEM=LCMGIL(JPMEM,ICAL)
        CALL LCMSIX(KPMEM,'outflx',1)
        CALL LCMGET(KPMEM,'SURFLX',SURFLX)
        CALL LCMSIX(KPMEM,' ',2)
        CALL LCMSIX(KPMEM,' ',2)
        DO I=1,NSURFD
          WRITE(HADF(I),'(3HFD_,I5.5)') I
          DO IGR=1,NGRP
            ADF2(IBM,IGR,I)=ADF2(IBM,IGR,I)+WEIGHT*SURFLX(I,IGR)/SURF(I)
          ENDDO
        ENDDO
  290   CONTINUE
  300   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),NMIX*NGRP,2,ADF2(1,1,I))
        ENDDO
        CALL LCMSIX(IPLIB,' ',2)
        CALL LCMSIX(IPLIB,' ',2)
        DEALLOCATE(ADF2,HADF)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(SURFLX,SURF)
      DEALLOCATE(ADF2,HADF)
      DEALLOCATE(FMASL,SPH,FLUX,VOLMI2,VOL2,DENS3,DENS2)
      DEALLOCATE(HNAM2,HUSE2,ISTY2,ISTY1,ITOD2,IMIX2)
      RETURN
      END