Initial commit from Polytechnique Montreal

1 files changed, 1052 insertions, 0 deletions

diff --git a/Donjon/src/SCRLIB.f b/Donjon/src/SCRLIB.f
new file mode 100644
index 0000000..5b98de3
--- /dev/null
+++ b/Donjon/src/SCRLIB.f
@@ -0,0 +1,1052 @@
+*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