Initial commit from Polytechnique Montreal

1 files changed, 1346 insertions, 0 deletions

diff --git a/Dragon/src/LIBA20.f b/Dragon/src/LIBA20.f
new file mode 100644
index 0000000..73b65fc
--- /dev/null
+++ b/Dragon/src/LIBA20.f
@@ -0,0 +1,1346 @@
+*DECK LIBA20
+      SUBROUTINE LIBA20 (IPLIB,NAMFIL,NGRO,NBISO,NL,IPROC,ISONAM,
+     1 ISONRF,IPISO,ISHINA,MASKI,TN,SN,SB,IMPX,NGF,NGFR,NDEL)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transcription of the useful interpolated microscopic cross section
+* data from APOLIB-2 to LCM data structures.
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): A. Hebert
+*
+*Parameters: input
+* IPLIB   pointer to the lattice microscopic cross section library
+*         (L_LIBRARY signature).
+* NAMFIL  name of the APOLIB-2 file.
+* NGRO    number of energy groups.
+* NBISO   number of isotopes present in the calculation domain.
+* NL      number of Legendre orders required in the calculation
+*         NL=1 or higher.
+* IPROC   type of library processing.
+* ISONAM  alias name of isotopes.
+* ISONRF  library reference name of isotopes.
+* IPISO   pointer array towards microlib isotopes.
+* ISHINA  self shielding names.
+* MASKI   isotopic mask. Isotope with index I is processed if
+*         MASKI(I) is .true.
+* TN      temperature of each isotope.
+* SN      dilution cross section in each energy group of each.
+*         isotope. a value of 1.0E10 is used for infinite dilution.
+* SB      dilution cross section as used by Livolant and Jeanpierre
+*         normalization.
+* IMPX    print flag.
+*
+*Parameters: output
+* NGF     number of fast groups without self-shielding.
+* NGFR    number of fast and resonance groups.
+* NDEL    number of precursor groups for delayed neutrons.
+*
+*Reference:
+*   A. Hebert, P. Bellier, M. Coste, R. Sanchez, Z. Stankovski et
+*   I. Zmijarevic, "APOLLO2: Notice informatique Version 2.4",
+*   Commissariat a l'Energie Atomique, 
+*   Rapport SERMA/LENR/RT/98-2477/A, 1998.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIB,IPISO(NBISO)
+      INTEGER NGRO,NBISO,NL,IPROC,ISONAM(3,NBISO),ISONRF(3,NBISO),
+     1 ISHINA(3,NBISO),IMPX,NGF,NGFR,NDEL
+      REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO)
+      CHARACTER NAMFIL*(*)
+      LOGICAL MASKI(NBISO)
+*----
+*  LOCAL VARIABLES
+*----
+      LOGICAL LSACO
+      PARAMETER (NXSMAX=10,IOUT=6,MAXHOM=9,LSACO=.FALSE.)
+*     NOTE: LSACO MUST BE SET TO .TRUE. WITH THE SANCHEZ-COSTE METHOD.
+      TYPE(C_PTR) KPLIB
+      EXTERNAL LIBA21
+      CHARACTER TEXT8*8,TEXT20*20,TEXT80*80,NOMOBJ*20,TYPOBJ*8,
+     1 TYPSEG*8,HNAMIS*12,HNISOR*12,HNISSS*12,HSMG*131,TEXT2*2,
+     2 TEXT12*12
+      LOGICAL LPFIX,LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,LPTHOM,L104,LABS,
+     1 LDIF,LFIS,LPWD,LPED
+      INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG
+      DOUBLE PRECISION UU,XDRCST
+      INTEGER ITHOMO(MAXHOM),ITEXT(20),ISFICH(3),IPAR(3)
+      REAL TKT(5)
+*
+      INTEGER TKCARO(31)
+      SAVE TKCARO
+      DATA TKCARO /
+     &   0,   1,   2,   3,  4,   5,  6,  30,   7,  -8,
+     &   9, -10,  11, -12, 13, -14, 15,  16, -17,  18,
+     & -19,  20, -21,  22, 23, -24, 25, -26,  27, -28,
+     &  29   /
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,KDS,LGS,NOM,NOMS,
+     1 NOMOB,VINTE,ITCARO,ITC104,ITS104,ITITLE,IZSECT,ISECTT,IFDG,IIAD,
+     2 IDEPL
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR
+      REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX,
+     1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE
+      TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR
+      INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM
+      REAL, POINTER, DIMENSION(:) :: RTSEGM
+      LOGICAL, POINTER, DIMENSION(:) :: LTSEGM
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(IPR(7+2*(NL-1),NBISO),ITYPRO(NL),NFS(NGRO))
+      ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL),
+     1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO))
+*
+      ANEUT=REAL(XDRCST('Neutron mass','amu'))
+      NGF=NGRO+1
+      NGFR=0
+      NDEL=0
+      IF(IMPX.GT.0) WRITE (IOUT,800) NAMFIL
+*----
+*  OPEN AND PROBE THE APOLIB-2 FILE.
+*----
+      TKT(:5)=0.0
+      CALL KDRCPU(TK1)
+      CALL AEXTPA(NAMFIL,ISFICH)
+      IADRES=ISFICH(1)
+      NBOBJ=ISFICH(2)
+      LBLOC=ISFICH(3)
+      IUNIT=KDROPN(NAMFIL,2,4,LBLOC)
+      IF(IUNIT.LE.0) THEN
+         TEXT12=NAMFIL
+         CALL XABORT('LIBA20: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
+     1   'E OPENED')
+      ENDIF
+*----
+*  INDEX THE APOLIB-2 FILE.
+*----
+      IDKNO=1-TKCARO(14)
+      IDKTY=1-TKCARO(21)
+      IDKDS=1-TKCARO(10)
+      IDKTS=1-TKCARO(23)
+      IDKDA=1-TKCARO(26)
+      IDKNS=TKCARO(2)+1
+      IDKLS=TKCARO(8)
+      ALLOCATE(KDS(NBOBJ-3),LGS(NBOBJ-3),NOMOB(7*(NBOBJ-3)))
+      KDS(:NBOBJ-3)=0
+      LGS(:NBOBJ-3)=0
+      NOMOB(:7*(NBOBJ-3))=0
+      CALL LCMSIX(IPLIB,'INDEX',1)
+      TEXT12=NAMFIL
+      CALL LCMLEN(IPLIB,TEXT12,ILENG,ITYLCM)
+      CALL LCMSIX(IPLIB,TEXT12,1)
+      IF(ILENG.NE.0) THEN
+*        RECOVER AN EXISTING INDEX.
+         CALL LCMGET(IPLIB,'IPAR',IPAR)
+         CALL LCMGET(IPLIB,'KDS',KDS)
+         CALL LCMGET(IPLIB,'LGS',LGS)
+         CALL LCMGET(IPLIB,'NOMOB',NOMOB)
+      ELSE
+*        CREATE A NEW INDEX.
+         ALLOCATE(VINTE(2*NBOBJ))
+         CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ)
+         NSEGM=0
+         DO 10 IOBJ=3,NBOBJ
+         IDKOBJ=VINTE(2*IOBJ-1)
+         LGSEG=VINTE(2*IOBJ)+1
+         ALLOCATE(ITCARO(LGSEG))
+         CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+         IDK=ITCARO(IDKNO)
+         CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
+         IDK=ITCARO(IDKTY)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
+         JDKDS=ITCARO(IDKDS)
+         JDKTS=ITCARO(IDKTS)
+         NS=ITCARO(IDKNS)
+         IDK=ITCARO(IDKDA)
+         CALL AEXCPC(IDK,8,ITCARO(1),TEXT8)
+         IF(TYPOBJ.EQ.'APOLIB') THEN
+            IPAR(2)=IDKOBJ
+            IPAR(3)=LGSEG
+         ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN
+            NSEGM=NSEGM+1
+            ISO2=(NSEGM-1)*7+1
+            CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2))
+            CALL LCMCAR(TEXT8,.TRUE.,NOMOB(ISO2+5))
+            KDS(NSEGM)=IDKOBJ
+            LGS(NSEGM)=LGSEG
+         ELSE
+            CALL XABORT('LIBA20: WEIRD SEGMENT TYPE: '//TYPOBJ//'.')
+         ENDIF
+         DEALLOCATE(ITCARO)
+   10    CONTINUE
+         DEALLOCATE(VINTE)
+         IPAR(1)=NSEGM
+*
+*        SAVE THE INDEX.
+         CALL LCMPUT(IPLIB,'IPAR',3,1,IPAR)
+         CALL LCMPUT(IPLIB,'NOMOB',7*(NBOBJ-3),1,NOMOB)
+         CALL LCMPUT(IPLIB,'KDS',NBOBJ-3,1,KDS)
+         CALL LCMPUT(IPLIB,'LGS',NBOBJ-3,1,LGS)
+      ENDIF
+      CALL LCMSIX(IPLIB,' ',2)
+      CALL LCMSIX(IPLIB,' ',2)
+*----
+*  RECOVER GENERIC INFORMATION FROM THE APOLIB SEGMENT.
+*----
+      NSEGM=IPAR(1)
+      IDKOBJ=IPAR(2)
+      LGSEG=IPAR(3)
+      NISOT=0
+      NISOTS=0
+      NAMASS=0
+      IDKCOM=0
+      ISCOM=0
+      ALLOCATE(ITCARO(LGSEG))
+      CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+      IDK=ITCARO(IDKNO)
+      CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
+      IDK=ITCARO(IDKTY)
+      CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
+      JDKDS=ITCARO(IDKDS)
+      JDKTS=ITCARO(IDKTS)
+      NS=ITCARO(IDKNS)
+      IDK=ITCARO(IDKDA)
+      CALL AEXCPC(IDK,8,ITCARO(1),TEXT8)
+      IF(TYPOBJ.NE.'APOLIB') CALL XABORT('LIBA20: UNABLE TO FIND TH'//
+     1 'E APOLIB SEGMENT.')
+      DO 80 IS=1,NS
+      IDK=JDKTS+8*(IS-1)
+      CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+      LNGS=ITCARO(IDKLS+IS)
+      IF(LNGS.LE.0) GO TO 80
+      JDKS=ITCARO(JDKDS+IS)
+      CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR)
+      CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+      CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+      CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+      TSEGM_PTR=LCMARA(LNGS+1)
+      CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+      CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+      CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+      IF(TYPSEG.EQ.'PHEAD') THEN
+         CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         CALL AEXCPC(0,NV,ITSEGM(IDK),TEXT80)
+         IF((IMPX.GT.0).AND.(NV.GT.0)) WRITE (IOUT,810) TEXT80
+         CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV.EQ.0) THEN
+            TEXT12=NAMFIL
+            CALL XABORT('LIBA20: NO ISOTOPES PRESENT ON APOLIB-2 FIL'//
+     1      'E NAMED: '//TEXT12)
+         ENDIF
+         NISOT=NV/20
+         ALLOCATE(NOM(5*NISOT))
+         IF(IMPX.GE.10) THEN
+            WRITE(IOUT,'(/41H LIBA20: STANDARD ISOTOPE NAMES PRESENT I,
+     1      10HN LIBRARY:)')
+         ENDIF
+         DO 20 ISO=1,NISOT
+         ISO2=(ISO-1)*5+1
+         CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),TEXT20)
+         IF(IMPX.GE.10) WRITE(IOUT,'(8H -----> ,A20)') TEXT20
+         CALL LCMCAR(TEXT20,.TRUE.,NOM(ISO2))
+   20    CONTINUE
+         CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         NISOTS=NV/20
+         IF(NISOTS.GT.0) THEN
+            ALLOCATE(NOMS(5*NISOTS))
+            IF(IMPX.GE.10) THEN
+               WRITE(IOUT,'(/38H LIBA20: SELF-SHIELDED ISOTOPE NAMES P,
+     1         18HRESENT IN LIBRARY:)')
+            ENDIF
+            DO 30 ISO=1,NISOTS
+            ISO2=(ISO-1)*5+1
+            CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),TEXT20)
+            IF(IMPX.GE.10) WRITE(IOUT,'(8H -----> ,A20)') TEXT20
+            CALL LCMCAR(TEXT20,.TRUE.,NOMS(ISO2))
+   30       CONTINUE
+         ENDIF
+      ELSE IF(TYPSEG.EQ.'PMAIL') THEN
+         CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV-1.NE.NGRO) CALL XABORT('LIBA20: BAD GROUP STRUCTURE.')
+         DO 40 IG=1,NV
+         ENERG(IG)=RTSEGM(IDK+IG-1)*1.0E6
+   40    CONTINUE
+         CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV.EQ.NGRO) THEN
+            DO 50 IG=1,NGRO
+            DELTA(IG)=RTSEGM(IDK+IG-1)
+   50       CONTINUE
+         ELSE
+            DO 60 IG=1,NGRO
+            DELTA(IG)=LOG(ENERG(IG)/ENERG(IG+1))
+   60       CONTINUE
+         ENDIF
+         CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERG)
+         CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA)
+      ELSE IF(TYPSEG.EQ.'PCONST') THEN
+         CALL AEXGNV(13,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NAMASS)
+         ALLOCATE(AMASS(NAMASS))
+         DO 70 IA=1,NAMASS
+         AMASS(IA)=RTSEGM(IDK+IA-1)/ANEUT
+   70    CONTINUE
+      ELSE IF(TYPSEG.EQ.'PCOM') THEN
+*        ISOTOPE-DEPENDENT COMMENTS ARE AVAILABLE.
+         IDKCOM=IDKOBJ
+         LGCOM=LGSEG
+         ISCOM=IS
+      ENDIF
+      CALL LCMDRD(TSEGM_PTR)
+      CALL LCMDRD(ICHDIM_PTR)
+      CALL LCMDRD(ICHTYP_PTR)
+      CALL LCMDRD(ICHDKL_PTR)
+   80 CONTINUE
+      DEALLOCATE(ITCARO)
+      IF(NAMASS.NE.NISOT) CALL XABORT('LIBA20: INVALID AWR INFO.')
+*----
+*  SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES.
+*----
+      IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS,NSEGM
+      CALL LIBA27(NAMFIL,NBISO,NISOT,NSEGM,NL,ISONRF,ISHINA,MASKI,
+     1 NOM,NOMOB,IPR)
+      DEALLOCATE(NOM)
+      IF(NISOTS.GT.0) DEALLOCATE(NOMS)
+      CALL KDRCPU(TK2)
+      TKT(1)=TK2-TK1
+*----
+*  READ THROUGH APOLIB-2 FILE AND ACCUMULATE CROSS SECTIONS FOR THIS
+*  RANGE OF MATS, LEGENDRE ORDERS, AND GROUPS.
+*----
+      CALL LCMGET(IPLIB,'ENERGY',ENERG)
+      DO 560 IMX=1,NBISO
+*----
+*  PROCESS INFINITE DILUTION INFORMATION.
+*----
+      KISEG=IPR(2,IMX)
+      IF(KISEG.GT.0) THEN
+         IF(IMPX.GT.1) WRITE(IOUT,'(/29H LIBA20: PROCESSING ISOTOPE '',
+     1   3A4,2H''.)') (ISONRF(I0,IMX),I0=1,3)
+*
+*        RECOVER THE ISOTOPE TITLE.
+         CALL KDRCPU(TK1)
+         IF(IDKCOM.EQ.0) THEN
+*           MAKE A NEW TITLE.
+            ISO2=(KISEG-1)*7+1
+            CALL LCMCAR(NOMOBJ,.FALSE.,NOMOB(ISO2))
+            CALL LCMCAR(TEXT8,.FALSE.,NOMOB(ISO2+5))
+            TEXT80='APOLIB-2 ISOTOPE:'//NOMOBJ(7:)//TEXT8
+         ELSE
+*           RECOVER THE TITLE FROM THE PCOM SEGMENT.
+            IF(IPR(1,IMX).LE.0) CALL XABORT('LIBA20: BAD TITLE.')
+            ALLOCATE(ITITLE(LGCOM))
+            CALL AEXDIR(IUNIT,LBLOC,ITITLE,IDKCOM,LGCOM)
+            JDKDS=ITITLE(IDKDS)
+            JDKTS=ITITLE(IDKTS)
+            NS=ITITLE(IDKNS)
+            IDK=JDKTS+8*(ISCOM-1)
+            CALL AEXCPC(IDK,8,ITITLE(1),TYPSEG)
+            IF(TYPSEG.NE.'PCOM') CALL XABORT('LIBA20: SEGMENT ERROR.')
+            LNGS=ITITLE(IDKLS+ISCOM)
+            IF(LNGS.LE.0) CALL XABORT('LIBA20: LENGTH ERROR.')
+            JDKS=ITITLE(JDKDS+ISCOM)
+            CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1      ICHDKL_PTR)
+            CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+            TSEGM_PTR=LCMARA(LNGS+1)
+            CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+            CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            ISO2=(IPR(1,IMX)-1)*20+1
+            CALL AEXCPC(0,NV,ITSEGM(IDK+ISO2-1),TEXT80)
+            CALL LCMDRD(TSEGM_PTR)
+            CALL LCMDRD(ICHDIM_PTR)
+            CALL LCMDRD(ICHTYP_PTR)
+            CALL LCMDRD(ICHDKL_PTR)
+            DEALLOCATE(ITITLE)
+         ENDIF
+         READ(TEXT80,'(20A4)') (ITEXT(I),I=1,20)
+         IF(IMPX.GT.2) WRITE(IOUT,870) TEXT80
+*
+         IDKOBJ=KDS(KISEG)
+         LGSEG=LGS(KISEG)
+         ALLOCATE(ITCARO(LGSEG))
+         CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+         IDK=ITCARO(IDKNO)
+         CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
+         IDK=ITCARO(IDKTY)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
+         JDKDS=ITCARO(IDKDS)
+         JDKTS=ITCARO(IDKTS)
+         NS=ITCARO(IDKNS)
+*----
+*  RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION.
+*----
+         LPFIX=.FALSE.
+         LTRAN=.FALSE.
+         DO 160 IS=1,NS
+         IDK=JDKTS+8*(IS-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         LNGS=ITCARO(IDKLS+IS)
+         IF(LNGS.LE.0) GO TO 160
+         JDKS=ITCARO(JDKDS+IS)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LNGS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,LTSEGM,(/ LNGS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+         IF(TYPSEG.EQ.'PFIX') THEN
+            LPFIX=.TRUE.
+            CALL AEXGNV(2,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            ZFISS=ITSEGM(IDK)
+            CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            LGPROB=LTSEGM(IDK)
+            CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            LGTDIF=LTSEGM(IDK)
+            CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            LGTTRA=LTSEGM(IDK)
+            CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            FGTD=ITSEGM(IDK)
+            CALL AEXGNV(8,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            ID2=ITSEGM(IDK)
+            CALL AEXGNV(12,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT)
+            ALLOCATE(IZSECT(NSECTT))
+            NSETOT=0
+            NPHY=MAX(0,NSECTT-5)
+            DO 90 I=1,NSECTT
+            IZSECT(I)=ITSEGM(IDK+I-1)
+            IF((IZSECT(I).NE.0).AND.(I.LE.5)) NSETOT=NSETOT+1
+   90       CONTINUE
+            IF(IMPX.GT.2) WRITE(IOUT,875) (IZSECT(I),I=1,NSECTT)
+            CALL AEXGNV(14,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NANISD)
+            CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NANIST)
+            CALL AEXGNV(18,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT)
+            ALLOCATE(LGTRE(NSECTT))
+            DO 100 I=1,NSECTT
+            LGTRE(I)=LTSEGM(IDK+I-1)
+  100       CONTINUE
+            CALL AEXGNV(24,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTEMP)
+            ALLOCATE(TEMP(NTEMP))
+            DO 110 I=1,NTEMP
+            TEMP(I)=RTSEGM(IDK+I-1)
+  110       CONTINUE
+            IF(IMPX.GT.2) WRITE(IOUT,880) (TEMP(I),I=1,NTEMP)
+            CALL AEXGNV(26,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            IF(NV/8.NE.NSECTT) CALL XABORT('LIBA20: INVALID TYPSECT.')
+            ALLOCATE(ISECTT(2*NSECTT))
+            III=0
+            DO 120 I=1,NSECTT
+            I2=(I-1)*2+1
+            IF(IZSECT(I).NE.0) THEN
+               III=III+1
+               I3=(III-1)*2+1
+               CALL AEXCPC(0,8,ITSEGM(IDK+I2-1),TEXT8)
+               CALL LCMCAR(TEXT8,.TRUE.,ISECTT(I3))
+            ENDIF
+  120       CONTINUE
+            IF(IMPX.GT.2) WRITE(IOUT,890) ZFISS,LGPROB,LGTDIF,LGTTRA,
+     1      FGTD,ID2,NSECTT,NSETOT,NPHY,NANISD,NANIST,(LGTRE(I),I=1,
+     2      NSECTT)
+            IF(NANIST.GT.NANISD) CALL XABORT('LIBA20: NANIST.GT.NANISD')
+         ELSE IF(TYPSEG.EQ.'PPPSN') THEN
+            LTRAN=.TRUE.
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            FAGG=ITSEGM(IDK)
+            CALL AEXGNV(2,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            LAGG=ITSEGM(IDK)
+            CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            FDGG=ITSEGM(IDK)
+            CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            WGAL=ITSEGM(IDK)
+            CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            FAG=ITSEGM(IDK)
+            CALL AEXGNV(6,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            LAG=ITSEGM(IDK)
+            CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            IF(NV.NE.NGRO) CALL XABORT('LIBA20: INVALID LIBRARY(1).')
+            ALLOCATE(IFDG(NV))
+            DO 130 I=1,NV
+            IFDG(I)=ITSEGM(IDK+I-1)
+  130       CONTINUE
+            CALL AEXGNV(9,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            IF(NV.NE.NGRO+1) CALL XABORT('LIBA20: INVALID LIBRARY(2).')
+            ALLOCATE(IIAD(NV))
+            DO 140 I=1,NV
+            IIAD(I)=ITSEGM(IDK+I-1)
+  140       CONTINUE
+            CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NGTD)
+            ALLOCATE(IDEPL(NGTD))
+            DO 150 I=1,NGTD
+            IDEPL(I)=ITSEGM(IDK+I-1)
+  150       CONTINUE
+            IF(IMPX.GT.2) WRITE(IOUT,900) FAGG,LAGG,FDGG,WGAL,FAG,LAG,
+     1      NGTD
+         ENDIF
+         CALL LCMDRD(TSEGM_PTR)
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+  160    CONTINUE
+         IF(.NOT.LPFIX) CALL XABORT('LIBA20: NO PFIX SEGMENT.')
+*----
+*  RECOVER THE INFINITE DILUTION CROSS SECTIONS.
+*----
+         ITSEC=0
+         NDIFG=0
+         NPSN=0
+         DO 220 IS=1,NS
+         IDK=JDKTS+8*(IS-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         LNGS=ITCARO(IDKLS+IS)
+         IF(LNGS.LE.0) GO TO 220
+         JDKS=ITCARO(JDKDS+IS)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LNGS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+         IF(TYPSEG.EQ.'PSECT') THEN
+*           RECOVER A VECTOR CROSS SECTION.
+            ITSEC=ITSEC+1
+            IF(ITSEC.GT.NXSMAX) THEN
+               CALL XABORT('LIBA20: SECT OVERFLOW.')
+            ELSE IF(ITSEC.LE.NSETOT) THEN
+               I3=(ITSEC-1)*2+1
+               CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3))
+            ELSE IF(ITSEC.EQ.NSETOT+1) THEN
+               TEXT8='SIGS00'
+            ELSE IF(ITSEC.GT.NSETOT+1) THEN
+               CALL XABORT('LIBA20: UNKNOWN CROSS SECTION TYPE(1).')
+            ENDIF
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            DO 190 JMX=IMX,NBISO
+            IF(IPR(2,JMX).EQ.KISEG) THEN
+               KPLIB=IPISO(JMX) ! set JMX-th isotope
+               CALL LCMLEN(KPLIB,'ALIAS',ILENG,ITYLCM)
+               IF(ILENG.EQ.0) THEN
+                  WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
+                  CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS)
+                  IF(IPR(1,JMX).LE.0) CALL XABORT('LIBA20: BAD AWR.')
+                  CALL LCMPUT(KPLIB,'AWR',1,2,AMASS(IPR(1,JMX)))
+                  CALL LCMPUT(KPLIB,'README',20,3,ITEXT)
+               ENDIF
+               IF(ITSEC.EQ.1) THEN
+                  SIGS(:NGRO,1)=0.0
+                  CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS)
+                  CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SIGS)
+               ENDIF
+               CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK),
+     1         SECT)
+               IF(TEXT8.EQ.'SIGA') THEN
+                  CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,SECT)
+               ELSE IF(TEXT8.EQ.'NEXCESS') THEN
+                  LN2N=.FALSE.
+                  DO 170 IG=1,NGRO
+                  LN2N=LN2N.OR.(SECT(IG).NE.0.0)
+  170             CONTINUE
+                  IF(LN2N) THEN
+                     CALL LCMPUT(KPLIB,'N2N',NGRO,2,SECT)
+                     CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SECT)
+                  ENDIF
+               ELSE IF(TEXT8.EQ.'SIGF') THEN
+                  CALL LCMPUT(KPLIB,'NFTOT',NGRO,2,SECT)
+               ELSE IF(TEXT8.EQ.'NUSIGF') THEN
+                  CALL LCMPUT(KPLIB,'NUSIGF',NGRO,2,SECT)
+               ELSE IF(TEXT8.EQ.'CHI') THEN
+                  CALL LCMPUT(KPLIB,'CHI',NGRO,2,SECT)
+               ELSE IF(TEXT8.EQ.'SIGS00') THEN
+                  CALL LCMGET(KPLIB,'NTOT0',XSTOT)
+                  CALL LCMGET(KPLIB,'SIGS00',SIGS)
+                  NDIFG=NV
+                  DO 180 IG=1,NGRO
+                  XSTOT(IG)=XSTOT(IG)+SECT(IG)
+                  SIGS(IG,1)=SIGS(IG,1)+SECT(IG)
+  180             CONTINUE
+                  CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,XSTOT)
+                  CALL LCMPUT(KPLIB,'SIGS00',NGRO,2,SIGS)
+               ELSE
+                  CALL XABORT('LIBA20: UNKNOWN X-S TYPE:'//TEXT8)
+               ENDIF
+            ENDIF
+  190       CONTINUE
+         ELSE IF(TYPSEG.EQ.'PPSN') THEN
+*           RECOVER A MATRIX CROSS SECTION.
+            IF(.NOT.LTRAN) CALL XABORT('LIBA20: PPPSN MISSING.')
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            NPSN=NV
+            DO 210 JMX=IMX,NBISO
+            IF(IPR(2,JMX).EQ.KISEG) THEN
+               KPLIB=IPISO(JMX) ! set JMX-th isotope
+               SCAT(:NGRO,:NGRO,1)=0.0
+               CALL LIBA23(NGRO,1,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2,
+     1         FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM(IDK),
+     2         SCAT)
+               CALL LCMGET(KPLIB,'SIGS00',SIGS)
+               IF(LGPROB) THEN
+                  DO 205 IG=1,NGRO
+                  DO 200 JG=1,NGRO
+                  SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1)
+  200             CONTINUE
+  205             CONTINUE
+               ENDIF
+               CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO)
+            ENDIF
+  210       CONTINUE
+         ENDIF
+         CALL LCMDRD(TSEGM_PTR)
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+  220    CONTINUE
+         DEALLOCATE(ITCARO)
+         DO 240 JMX=IMX,NBISO
+         IF(IPR(2,JMX).EQ.KISEG) THEN
+            IF(.NOT.LTRAN) THEN
+               KPLIB=IPISO(JMX) ! set JMX-th isotope
+               CALL LCMGET(KPLIB,'SIGS00',SIGS)
+               SCAT(:NGRO,:NGRO,1)=0.0
+               DO 230 IG=1,NGRO
+               SCAT(IG,IG,1)=SIGS(IG,1)
+  230          CONTINUE
+               CALL XDRLGS(KPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO)
+            ENDIF
+            IPR(2,JMX)=0
+         ENDIF
+  240    CONTINUE
+         CALL KDRCPU(TK2)
+         TKT(2)=TKT(2)+(TK2-TK1)
+*----
+*  RECOVER SCATTERING X-S FOR HIGHER LEGENDRE ORDERS.
+*----
+         CALL KDRCPU(TK1)
+         DO 270 IL=2,MIN(NANISD,NL)
+         WRITE(TEXT2,'(I2.2)') IL-1
+         KISEG=IPR(7+(IL-1),IMX)
+         IF(KISEG.EQ.0) THEN
+            WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
+            WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3)
+            WRITE(HSMG,830) IL-1,HNAMIS,HNISOR,NAMFIL
+            CALL XABORT(HSMG)
+         ENDIF
+         IDKOBJ=KDS(KISEG)
+         LGSEG=LGS(KISEG)
+         ALLOCATE(ITCARO(LGSEG))
+         CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+         LDKDS=ITCARO(IDKDS)
+         LDKTS=ITCARO(IDKTS)
+         IF(ITCARO(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID DIFF(1).')
+         CALL AEXCPC(LDKTS,8,ITCARO(1),TYPSEG)
+         IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBA20: INVALID DIFF(2).')
+         LNGS=ITCARO(IDKLS+1)
+         IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID DIFF(3).')
+         LDKS=ITCARO(LDKDS+1)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LNGS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1)
+         CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV.NE.NDIFG) CALL XABORT('LIBA20: INVALID DIFF(4).')
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+         DEALLOCATE(ITCARO)
+         DO 260 JMX=IMX,NBISO
+         IF(IPR(7+(IL-1),JMX).EQ.KISEG) THEN
+            KPLIB=IPISO(JMX) ! set JMX-th isotope
+            CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK),
+     1      SECT)
+            CALL LCMPUT(KPLIB,'SIGS'//TEXT2,NGRO,2,SECT)
+            IF(IL.GT.NANIST) THEN
+               SCAT(:NGRO,:NGRO,1)=0.0
+               DO 250 IG=1,NGRO
+               SIGS(IG,1)=SECT(IG)
+               SCAT(IG,IG,1)=SECT(IG)
+  250          CONTINUE
+               CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,
+     1         ITYPRO)
+            ENDIF
+            IPR(7+(IL-1),JMX)=0
+         ENDIF
+  260    CONTINUE
+         CALL LCMDRD(TSEGM_PTR)
+  270    CONTINUE
+*----
+*  RECOVER TRANSFER MATRICES FOR HIGHER LEGENDRE ORDERS.
+*----
+         DO 300 IL=2,MIN(NANIST,NL)
+         WRITE(TEXT2,'(I2.2)') IL-1
+         KISEG=IPR(7+(NL-1)+(IL-1),IMX)
+         IF(KISEG.EQ.0) THEN
+            WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
+            WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3)
+            WRITE(HSMG,830) IL-1,HNAMIS,HNISOR,NAMFIL
+            CALL XABORT(HSMG)
+         ENDIF
+         IDKOBJ=KDS(KISEG)
+         LGSEG=LGS(KISEG)
+         ALLOCATE(ITCARO(LGSEG))
+         CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+         LDKDS=ITCARO(IDKDS)
+         LDKTS=ITCARO(IDKTS)
+         IF(ITCARO(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID TRAN(1).')
+         CALL AEXCPC(LDKTS,8,ITCARO(1),TYPSEG)
+         IF(TYPSEG.NE.'PPSN') CALL XABORT('LIBA20: INVALID TRAN(2).')
+         LNGS=ITCARO(IDKLS+1)
+         IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID TRAN(3).')
+         LDKS=ITCARO(LDKDS+1)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LNGS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1)
+         CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV.NE.NPSN) CALL XABORT('LIBA20: INVALID TRAN(4).')
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+         DEALLOCATE(ITCARO)
+         DO 290 JMX=IMX,NBISO
+         IF(IPR(7+(NL-1)+(IL-1),JMX).EQ.KISEG) THEN
+            KPLIB=IPISO(JMX) ! set JMX-th isotope
+            CALL LIBA23(NGRO,IL,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2,
+     1      FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM(IDK),
+     2      SCAT)
+            CALL LCMGET(KPLIB,'SIGS'//TEXT2,SIGS)
+            IF(LGPROB) THEN
+               DO 285 IG=1,NGRO
+               DO 280 JG=1,NGRO
+               SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1)
+  280          CONTINUE
+  285          CONTINUE
+            ENDIF
+            CALL XDRLGS(KPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,ITYPRO)
+            IPR(7+(NL-1)+(IL-1),JMX)=0
+         ENDIF
+  290    CONTINUE
+         CALL LCMDRD(TSEGM_PTR)
+  300    CONTINUE
+         CALL KDRCPU(TK2)
+         TKT(3)=TKT(3)+(TK2-TK1)
+*----
+*  RECOVER A PRODUCTION X-S.
+*----
+         CALL KDRCPU(TK1)
+         IF(NPHY.GE.1) THEN
+            KISEG=IPR(3,IMX)
+            IF(KISEG.EQ.0) THEN
+               WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
+               WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3)
+               WRITE(HSMG,840) HNAMIS,HNISOR,NAMFIL
+               CALL XABORT(HSMG)
+            ENDIF
+            IDKOBJ=KDS(KISEG)
+            LGSEG=LGS(KISEG)
+            ALLOCATE(ITCARO(LGSEG))
+            CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+            LDKDS=ITCARO(IDKDS)
+            LDKTS=ITCARO(IDKTS)
+            NS=ITCARO(IDKNS)
+            IF(NS.NE.NPHY) CALL XABORT('LIBA20: INVALID PRODUCTION X-S('
+     1      //'1).')
+         ENDIF
+         DO 320 IPHY=1,NPHY
+         IDK=LDKTS+8*(IPHY-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBA20: INVALID PRODUCTION'
+     1   //' X-S(2).')
+         LNGS=ITCARO(IDKLS+IPHY)
+         IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID PRODUCTION X-S(3).')
+         LDKS=ITCARO(LDKDS+IPHY)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LNGS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,LDKS,LNGS+1)
+         CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+         I3=(NSETOT+IPHY-1)*2+1
+         CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3))
+         DO 310 JMX=IMX,NBISO
+         IF(IPR(3,JMX).EQ.KISEG) THEN
+            KPLIB=IPISO(JMX) ! set JMX-th isotope
+            CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM(IDK),
+     1      SECT)
+            IF(TEXT8.EQ.'CREA-P') THEN
+               TEXT8='NP'
+            ELSE IF (TEXT8.EQ.'CREA-H2') THEN
+               TEXT8='ND'
+            ELSE IF (TEXT8.EQ.'CREA-H3') THEN
+               TEXT8='NT'
+            ENDIF
+            CALL LCMPUT(KPLIB,TEXT8,NGRO,2,SECT)
+         ENDIF
+  310    CONTINUE
+         CALL LCMDRD(TSEGM_PTR)
+  320    CONTINUE
+         DO 330 JMX=IMX,NBISO
+         IF(IPR(3,JMX).EQ.KISEG) IPR(3,JMX)=0
+  330    CONTINUE
+         IF(NPHY.GE.1) DEALLOCATE(ITCARO)
+         DEALLOCATE(ISECTT)
+*----
+*  RECOVER DELAYED NEUTRON DATA.
+*----
+         KISEG=IPR(4,IMX)
+         IF(KISEG.GT.0) THEN
+            IDKOBJ=KDS(KISEG)
+            LGSEG=LGS(KISEG)
+            ALLOCATE(ITCARO(LGSEG))
+            CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+            IDK=ITCARO(IDKNO)
+            CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
+            IDK=ITCARO(IDKTY)
+            CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
+            JDKDS=ITCARO(IDKDS)
+            JDKTS=ITCARO(IDKTS)
+            NS=ITCARO(IDKNS)
+            ICHI=0
+            NDEL0=0
+            LPWD=.FALSE.
+            DO 350 IS=1,NS
+            IDK=JDKTS+8*(IS-1)
+            CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+            LNGS=ITCARO(IDKLS+IS)
+            IF(LNGS.LE.0) GO TO 350
+            JDKS=ITCARO(JDKDS+IS)
+            CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1      ICHDKL_PTR)
+            CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+            TSEGM_PTR=LCMARA(LNGS+1)
+            CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+            CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+            CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,ILENG)
+            CALL LCMDRD(ICHDIM_PTR)
+            CALL LCMDRD(ICHTYP_PTR)
+            CALL LCMDRD(ICHDKL_PTR)
+            IF(TYPSEG.EQ.'.R1 RCHI') THEN
+               ICHI=ICHI+1
+            ELSE IF(TYPSEG.EQ.'.R1 RRBE') THEN
+               NDEL0=ILENG
+               NDEL=MAX(NDEL,NDEL0)
+               ALLOCATE(PWD(NDEL))
+               DO IDEL=1,NDEL
+                  PWD(IDEL)=RTSEGM(IDK+IDEL-1)
+               ENDDO
+               LPWD=.TRUE.
+            ELSE IF(TYPSEG.EQ.'.R1 RBET') THEN
+               ALLOCATE(PED(NGRO))
+               DO IGR=1,NGRO
+                  PED(IGR)=RTSEGM(IDK+IGR-1)
+               ENDDO
+               LPED=.TRUE.
+            ENDIF
+            DO 340 JMX=IMX,NBISO
+            IF(IPR(4,JMX).EQ.KISEG) THEN
+               KPLIB=IPISO(JMX) ! set JMX-th isotope
+               IF(TYPSEG.EQ.'.R1 RLAM') THEN
+                  CALL LCMPUT(KPLIB,'LAMBDA-D',ILENG,2,RTSEGM(IDK))
+                  NDEL0=ILENG
+                  NDEL=MAX(NDEL,NDEL0)
+               ELSE IF(TYPSEG.EQ.'.R1 RCHI') THEN
+                  WRITE(TEXT2,'(I2.2)') ICHI
+                  CALL LCMPUT(KPLIB,'CHI'//TEXT2,ILENG,2,RTSEGM(IDK))
+               ENDIF
+            ENDIF
+  340       CONTINUE
+            CALL LCMDRD(TSEGM_PTR)
+  350       CONTINUE
+            DEALLOCATE(ITCARO)
+            IF(LPWD.AND.LPED) THEN
+               DO 390 JMX=IMX,NBISO
+               IF(IPR(4,JMX).EQ.KISEG) THEN
+                  KPLIB=IPISO(JMX) ! set JMX-th isotope
+                  DO 380 IDEL=1,NDEL0
+                  WRITE(TEXT2,'(I2.2)') IDEL
+                  CALL LCMGET(KPLIB,'NUSIGF',SECT)
+                  DO 370 IGR=1,NGRO
+                  SECT(IGR)=SECT(IGR)*PWD(IDEL)*PED(IGR)
+  370             CONTINUE
+                  CALL LCMPUT(KPLIB,'NUSIGF'//TEXT2,NGRO,2,SECT)
+  380             CONTINUE
+               ENDIF
+  390          CONTINUE
+            ENDIF
+            IF(LPWD) DEALLOCATE(PWD)
+            IF(LPED) DEALLOCATE(PED)
+            DO 400 JMX=IMX,NBISO
+            IF(IPR(4,JMX).EQ.KISEG) IPR(4,JMX)=0
+  400       CONTINUE
+         ENDIF
+*----
+*  RELEASE ALLOCATED MEMORY FOR THE CURRENT ISOTOPE.
+*----
+         IF(LTRAN) DEALLOCATE(IDEPL,IIAD,IFDG)
+         DEALLOCATE(TEMP,IZSECT,LGTRE)
+         CALL KDRCPU(TK2)
+         TKT(2)=TKT(2)+(TK2-TK1)
+         IF((IMPX.GT.9).AND.(IPR(5,IMX).EQ.0)) THEN
+            KPLIB=IPISO(IMX) ! set IMX-th isotope
+            CALL LCMLIB(KPLIB)
+         ENDIF
+      ENDIF
+*----
+*  PROCESS SELF-SHIELDING INFORMATION.
+*----
+      KISEG=IPR(5,IMX)
+      IF(KISEG.GT.0) THEN
+         CALL KDRCPU(TK1)
+         IDKOBJ=KDS(KISEG)
+         LGSEG=LGS(KISEG)
+         ALLOCATE(ITCARO(LGSEG))
+         CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+         IDK=ITCARO(IDKNO)
+         CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
+         IDK=ITCARO(IDKTY)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
+         JDKDS=ITCARO(IDKDS)
+         JDKTS=ITCARO(IDKTS)
+         NS=ITCARO(IDKNS)
+*----
+*  RECOVER THE SELF-SHIELDED CROSS SECTION NUMEROTATION.
+*----
+         LPTHOM=.FALSE.
+         LGHOMO=0
+         DO 440 IS=1,NS
+         IDK=JDKTS+8*(IS-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         LNGS=ITCARO(IDKLS+IS)
+         IF(LNGS.LE.0) GO TO 440
+         JDKS=ITCARO(JDKDS+IS)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LNGS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+         IF(TYPSEG.EQ.'PTHOM1') THEN
+            LPTHOM=.TRUE.
+            CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTHOMO)
+            IF(NTHOMO.GT.MAXHOM) CALL XABORT('LIBA20: ITHOMO OVERFLOW.')
+            DO 410 I=1,NTHOMO
+            ITHOMO(I)=ITSEGM(IDK+I-1)
+  410       CONTINUE
+            FGHOMO=ITHOMO(1)
+            LGHOMO=ITHOMO(2)
+            FGRESO=ITHOMO(3)
+            NGHOMO=LGHOMO-FGHOMO+1
+            NGF=MIN(NGF,FGHOMO)
+            NGFR=MAX(NGFR,LGHOMO)
+            L104=.FALSE.
+            IF(NTHOMO.GE.9) L104=ITHOMO(9).NE.0
+            CALL AEXGNV(13,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NBIN)
+            CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSEQHO)
+            ALLOCATE(SEQHO(NSEQHO))
+            DO 420 I=1,NSEQHO
+            SEQHO(I)=RTSEGM(IDK+I-1)
+  420       CONTINUE
+            CALL AEXGNV(22,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NTEMPS)
+            ALLOCATE(TEMPS(NTEMPS))
+            DO 430 I=1,NTEMPS
+            TEMPS(I)=RTSEGM(IDK+I-1)
+  430       CONTINUE
+            IF(IMPX.GT.1) THEN
+               WRITE(IOUT,910) (SEQHO(I),I=1,NSEQHO)
+               WRITE(IOUT,920) (TEMPS(I),I=1,NTEMPS)
+               WRITE(IOUT,930) FGHOMO,FGRESO,NGHOMO,NSEQHO,NTEMPS,L104,
+     1         NBIN
+            ENDIF
+         ENDIF
+         CALL LCMDRD(TSEGM_PTR)
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+  440    CONTINUE
+         IF(.NOT.LPTHOM) CALL XABORT('LIBA20: NO PTHOM1 SEGMENT.')
+         LENGTH=NGHOMO*NSEQHO*NTEMPS
+         IF(LENGTH.EQ.0) THEN
+            DEALLOCATE(SEQHO,ITCARO)
+            DO 450 JMX=IMX,NBISO
+            IF(IPR(5,JMX).EQ.KISEG) IPR(5,JMX)=0
+  450       CONTINUE
+            GO TO 550
+         ENDIF
+         ALLOCATE(TAUX(7*NGHOMO))
+         TAUX(:7*NGHOMO)=0.0
+*----
+*  RECOVER THE SELF-SHIELDED FLUX (REACTION 104).
+*----
+         IF(L104) THEN
+            KISEG=IPR(6,IMX)
+            IF(KISEG.EQ.0) THEN
+               WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
+               WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3)
+               WRITE(HSMG,850) HNAMIS,HNISSS,NAMFIL,1
+               CALL XABORT(HSMG)
+            ENDIF
+            IDKOBJ=KDS(KISEG)
+            LGSEG=LGS(KISEG)
+            ALLOCATE(ITC104(LGSEG))
+            CALL AEXDIR(IUNIT,LBLOC,ITC104,IDKOBJ,LGSEG)
+            LDKDS=ITC104(IDKDS)
+            LDKTS=ITC104(IDKTS)
+            IF(ITC104(IDKNS).NE.1) CALL XABORT('LIBA20: INVALID FL104('
+     1      //'1).')
+            CALL AEXCPC(LDKTS,8,ITC104(1),TYPSEG)
+            IF(TYPSEG.NE.'.R3 TXSS') CALL XABORT('LIBA20: INVALID FL10'
+     1      //'4(2).')
+            LNGS=ITC104(IDKLS+1)
+            IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID FL104(3).')
+            LDKS=ITC104(LDKDS+1)
+            CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1      ICHDKL_PTR)
+            CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+            ALLOCATE(ITS104(LNGS+1))
+            CALL AEXDIR(IUNIT,LBLOC,ITS104,LDKS,LNGS+1)
+            CALL AEXGNV(1,ITS104,ICHDIM,ICHTYP,ICHDKL,IDK104,NV)
+            IF(NV.NE.LENGTH) CALL XABORT('LIBA20: INVALID FL104(4).')
+            CALL LCMDRD(ICHDIM_PTR)
+            CALL LCMDRD(ICHTYP_PTR)
+            CALL LCMDRD(ICHDKL_PTR)
+            DEALLOCATE(ITC104)
+         ENDIF
+*----
+*  RECOVER THE SELF-SHIELDED EFFECTIVE RATES.
+*----
+         LPTHOM=.FALSE.
+         KISEG=IPR(5,IMX)
+         DO 470 IS=1,NS
+         IDK=JDKTS+8*(IS-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         LNGS=ITCARO(IDKLS+IS)
+         IF(LNGS.LE.0) GO TO 470
+         JDKS=ITCARO(JDKDS+IS)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LNGS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+         IF(TYPSEG.EQ.'PTHOM2') THEN
+            LPTHOM=.TRUE.
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKA,NV)
+            LABS=NV.EQ.LENGTH
+            CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKD,NV)
+            LDIF=NV.EQ.LENGTH
+            CALL AEXGNV(9,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKF,NV)
+            LFIS=NV.EQ.LENGTH
+            DO 460 JMX=IMX,NBISO
+            IF(IPR(5,JMX).EQ.KISEG) THEN
+               WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
+               KPLIB=IPISO(JMX) ! set JMX-th isotope
+               CALL LIBA24(HNAMIS,NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,
+     1         LFIS,L104,SEQHO,TEMPS,TN(JMX),SN(1,JMX),ITSEGM(IDKA),
+     2         ITSEGM(IDKD),ITSEGM(IDKF),ITS104(IDK104),IMPX,TAUX)
+*
+*              COMPUTE THE SELF-SHIELDED FLUX AND CROSS SECTIONS.
+               CALL LIBA25(KPLIB,LABS,LDIF,LFIS,L104,NGRO,FGHOMO,
+     1         NGHOMO,NSEQHO,NL,SEQHO,SN(1,JMX),SB(1,JMX),DELTA,
+     2         ISONAM(1,JMX),TAUX,IMPX)
+               IPR(5,JMX)=0
+               IPR(6,JMX)=0
+            ENDIF
+  460       CONTINUE
+         ENDIF
+         CALL LCMDRD(TSEGM_PTR)
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+  470    CONTINUE
+         IF(.NOT.LPTHOM) CALL XABORT('LIBA20: NO PTHOM2 SEGMENT.')
+         IF(L104) DEALLOCATE(ITS104)
+         DEALLOCATE(SEQHO,ITCARO)
+         CALL KDRCPU(TK2)
+         TKT(4)=TKT(4)+(TK2-TK1)
+*----
+*  RECOVER THE AUTOLIB (BIN CROSS SECTIONS) INFORMATION.
+*----
+         IF((NBIN.GT.0).AND.(IPROC.GE.3)) THEN
+            CALL KDRCPU(TK1)
+            KISEG=IPR(7,IMX)
+            IF(KISEG.EQ.0) THEN
+               WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
+               WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3)
+               WRITE(HSMG,850) HNAMIS,HNISSS,NAMFIL,2
+               CALL XABORT(HSMG)
+            ENDIF
+*----
+*  PROCESS THE RESOLVED ENERGY DOMAIN.
+*----
+            IDKOBJ=KDS(KISEG)
+            LGSEG=LGS(KISEG)
+            ALLOCATE(ITCARO(LGSEG))
+            CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+            JDKDS=ITCARO(IDKDS)
+            JDKTS=ITCARO(IDKTS)
+            NS=ITCARO(IDKNS)
+            FGRESO=MAX(FGRESO,FGHOMO)
+            IF(NS.EQ.(LGHOMO-FGRESO+1)*NTEMPS) THEN
+               NGBIN=LGHOMO-FGRESO+1
+            ELSE IF(NS.EQ.NGHOMO*NTEMPS) THEN
+               NGBIN=NGHOMO
+            ELSE
+               CALL XABORT('LIBA20: INVALID PTHOM5(1).')
+            ENDIF
+            LBIN=0
+            NFS(:NGRO)=0
+            DO 480 IG=1,NGBIN
+            IDK=JDKTS+8*(IG-1)
+            CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+            IF(TYPSEG.NE.'PTHOM5') CALL XABORT('LIBA20: INVALID PTH'
+     1      //'OM5(2).')
+            LNGS=ITCARO(IDKLS+IG)
+            IF(LNGS.LE.0) CALL XABORT('LIBA20: INVALID PTHOM5(3).')
+            JDKS=ITCARO(JDKDS+IG)
+            CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1      ICHDKL_PTR)
+            CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+            CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+            TSEGM_PTR=LCMARA(LNGS+1)
+            CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
+            CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDKD,NV)
+            LBIN=LBIN+NV
+            NFS(FGRESO+IG-1)=NV
+            CALL LCMDRD(TSEGM_PTR)
+            CALL LCMDRD(ICHDIM_PTR)
+            CALL LCMDRD(ICHTYP_PTR)
+            CALL LCMDRD(ICHDKL_PTR)
+  480       CONTINUE
+            IF(LSACO) THEN
+               NFSBIN=NFS(FGRESO)
+               LBIN=LBIN+(FGRESO-FGHOMO)*NFSBIN
+            ELSE
+               NFSBIN=0
+            ENDIF
+            DO 530 JMX=IMX,NBISO
+            IF(IPR(7,JMX).EQ.KISEG) THEN
+               ALLOCATE(DELTF(LBIN),SIGTF(LBIN),SIGAF(LBIN))
+               IOF=(FGRESO-FGHOMO)*NFSBIN
+               ALLOCATE(SQRTE(NTEMPS))
+               KPLIB=IPISO(JMX) ! set JMX-th isotope
+               DO 500 IG=1,NGBIN
+               IGG=FGRESO+IG-1
+               CALL LIBA26(LGSEG,IG,NGBIN,IUNIT,LBLOC,TKCARO,ITCARO,
+     1         NFS(IGG),TN(JMX),NTEMPS,TEMPS,DELTF(IOF+1),SIGTF(IOF+1),
+     2         SIGAF(IOF+1),DELINF,SGTINF,SGAINF)
+               IG2=IG+FGRESO-FGHOMO
+               F1=DELTA(IGG)/DELINF
+               F2=(TAUX(4*NGHOMO+IG2)+
+     1             TAUX(5*NGHOMO+IG2))/(SGTINF*DELTA(IGG))
+               F3=TAUX(4*NGHOMO+IG2)/(SGAINF*DELTA(IGG))
+               DO 490 I=1,NFS(IGG)
+               DELTF(IOF+I)=DELTF(IOF+I)*F1
+               SIGTF(IOF+I)=SIGTF(IOF+I)*F2
+               SIGAF(IOF+I)=SIGAF(IOF+I)*F3
+  490          CONTINUE
+               IOF=IOF+NFS(IGG)
+  500          CONTINUE
+               DEALLOCATE(SQRTE)
+*----
+*  PROCESS THE UNRESOLVED ENERGY DOMAIN. THE AUTOLIB OF THE FIRST
+*  RESOLVED ENERGY GROUP IS USED AND NORMALIZED TO THE CORRECT
+*  INFINITE DILUTION VALUES. USED WITH THE SANCHEZ-COSTE METHOD.
+*----
+               IF(LSACO) THEN
+                  E0=ENERG(FGHOMO)
+                  IG2=FGRESO-FGHOMO+1
+                  E1=DELTA(FGRESO)
+                  E2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2))
+                  E3=TAUX(4*NGHOMO+IG2)
+                  IBIN=0
+                  DO 515 IGG=FGHOMO,FGRESO-1
+                  NFS(IGG)=NFSBIN
+                  IG2=IGG-FGHOMO+1
+                  F1=DELTA(IGG)/E1
+                  F2=(TAUX(4*NGHOMO+IG2)+TAUX(5*NGHOMO+IG2))/E2
+                  F3=TAUX(4*NGHOMO+IG2)/E3
+                  JBIN=(FGRESO-FGHOMO)*NFSBIN
+                  DO 510 I=1,NFSBIN
+                  IBIN=IBIN+1
+                  JBIN=JBIN+1
+                  DELTF(IBIN)=DELTF(JBIN)*F1
+                  SIGTF(IBIN)=SIGTF(JBIN)*F2/F1
+                  SIGAF(IBIN)=SIGAF(JBIN)*F3/F1
+  510             CONTINUE
+  515             CONTINUE
+               ELSE
+                  E0=ENERG(FGRESO)
+               ENDIF
+*
+               ALLOCATE(ENER(LBIN+1))
+               ENER(1)=E0
+               UU=0.0D0
+               DO 520 I=1,LBIN
+               UU=UU+DELTF(I)
+               ENER(I+1)=REAL(E0*EXP(-UU))
+               SIGAF(I)=SIGTF(I)-SIGAF(I)
+  520          CONTINUE
+               DEALLOCATE(DELTF)
+               CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS)
+               CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,ENER)
+               CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,SIGTF)
+               CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,SIGAF)
+               DEALLOCATE(SIGAF,SIGTF,ENER)
+               IPR(7,JMX)=0
+            ENDIF
+  530       CONTINUE
+            DEALLOCATE(ITCARO)
+            CALL KDRCPU(TK2)
+            TKT(5)=TKT(5)+(TK2-TK1)
+         ELSE
+            KISEG=IPR(7,IMX)
+            DO 540 JMX=IMX,NBISO
+            IF(IPR(7,JMX).EQ.KISEG) IPR(7,JMX)=0
+  540       CONTINUE
+         ENDIF
+         DEALLOCATE(TEMPS,TAUX)
+*
+  550    IF(IMPX.GT.9) THEN
+            KPLIB=IPISO(IMX) ! set IMX-th isotope
+            CALL LCMLIB(KPLIB)
+         ENDIF
+      ENDIF
+  560 CONTINUE
+*
+      DEALLOCATE(LGS,KDS,NOMOB,AMASS)
+      IERR=KDRCLS(IUNIT,1)
+      IF(IERR.LT.0) THEN
+         TEXT12=NAMFIL
+         CALL XABORT('LIBA20: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
+     1   'E CLOSED')
+      ENDIF
+*----
+*  CHECK IF ALL REACTIONS HAVE BEEN PROCESSED.
+*----
+      DO 575 IMX=1,NBISO
+      DO 570 I=2,7+2*(NL-1)
+      IF(IPR(I,IMX).NE.0) THEN
+         WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3)
+         CALL XABORT(HSMG)
+      ENDIF
+  570 CONTINUE
+  575 CONTINUE
+      IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,5)
+*----
+*  ADD NG CROSS SECTIONS.
+*----
+      DO 610 IMX=1,NBISO
+      IF(MASKI(IMX)) THEN
+         KPLIB=IPISO(IMX) ! set IMX-th isotope
+         CALL LCMGET(KPLIB,'NTOT0',SECT)
+         CALL LCMLEN(KPLIB,'SIGS00',LENGT,ITYLCM)
+         IF(LENGT.EQ.NGRO) THEN
+            CALL LCMGET(KPLIB,'SIGS00',XSTOT)
+            DO 580 IU=1,NGRO
+            SECT(IU)=SECT(IU)-XSTOT(IU)
+  580       CONTINUE
+         ENDIF
+         CALL LCMLEN(KPLIB,'NFTOT',LENGT,ITYLCM)
+         IF(LENGT.EQ.NGRO) THEN
+            CALL LCMGET(KPLIB,'NFTOT',XSTOT)
+            DO 590 IU=1,NGRO
+            SECT(IU)=SECT(IU)-XSTOT(IU)
+  590       CONTINUE
+         ENDIF
+         CALL LCMLEN(KPLIB,'N2N',LENGT,ITYLCM)
+         IF(LENGT.EQ.NGRO) THEN
+            CALL LCMGET(KPLIB,'N2N',XSTOT)
+            DO 600 IU=1,NGRO
+            SECT(IU)=SECT(IU)+XSTOT(IU)
+  600       CONTINUE
+         ENDIF
+         CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT)
+      ENDIF
+  610 CONTINUE
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG)
+      DEALLOCATE(NFS,ITYPRO,IPR)
+      RETURN
+*
+  800 FORMAT(/43H LIBA20: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.)
+  810 FORMAT(/32H LIBA20: X-SECTION LIBRARY INFO:/9X,A80/)
+  820 FORMAT(/35H LIBA20: PROBING THE APOLIB-2 FILE./9X,11HNUMBER OF I,
+     1 29HSOTOPES AT INFINITE DILUTION=,I8/9X,21HNUMBER OF SELF-SHIELD,
+     2 12HED ISOTOPES=,I8/9X,27HNUMBER OF APOLIBE SEGMENTS=,I8)
+  830 FORMAT(9HLIBA20: P,I2,27H INFO OF MATERIAL/ISOTOPE ',A12,5H' = ',
+     1 A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.)
+  840 FORMAT(45HLIBA20: PRODUCTION INFO OF MATERIAL/ISOTOPE ',A12,
+     1 5H' = ',A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.)
+  850 FORMAT(49HLIBA20: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12,
+     1 5H' = ',A12,35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H(,I1,
+     2 2H).)
+  870 FORMAT(/9X,15HISOTOPE TITLE: ,A80)
+  875 FORMAT(/9X,6HZSECT=,10I10/(15X,10I10))
+  880 FORMAT(/9X,13HTEMPERATURES=,1P,9E12.4/(22X,9E12.4))
+  890 FORMAT(/9X,6HZFISS=,I2,8H LGPROB=,L2,8H LGTDIF=,L2,8H LGTTRA=,L2,
+     1 6H FGTD=,I5,5H ID2=,I5,8H NSECTT=,I3,8H NSETOT=,I3,6H NPHY=,I3/
+     2 9X,7HNANISD=,I3,8H NANIST=,I3,8H LGTREA=,10L2)
+  900 FORMAT(/9X,5HFAGG=,I5,6H LAGG=,I5,6H FDGG=,I5,6H WGAL=,I5,5H FAG=,
+     1 I5,5H LAG=,I5,6H NGTD=,I5)
+  910 FORMAT(/9X,10HDILUTIONS=,1P,9E12.4/(19X,9E12.4))
+  920 FORMAT(/9X,28HSELF-SHIELDING TEMPERATURES=,1P,7E12.4/(37X,7E12.4))
+  930 FORMAT(/9X,7HFGHOMO=,I4,8H FGRESO=,I4,8H NGHOMO=,I4,8H NSEQHO=,
+     1 I4,8H NTEMPS=,I4,6H L104=,L2,6H NBIN=,I5)
+  940 FORMAT(/26H LIBA20: CPU TIME USAGE --,F10.2,9H INDEXING/26X,
+     1 F10.2,24H INFINITE DILUTION P0 XS/26X,F10.2,11H PN XS DATA/
+     2 26X,F10.2,27H DILUTION-DEPENDENT XS DATA/26X,F10.2,5H AUTO,
+     3 12HLIB XS DATA.)
+  950 FORMAT(26HLIBA20: REMAINING REACTION,I3,14H FOR ISOTOPE ',3A4,
+     1 2H'.)
+      END