path: root/Dragon/src/LIBA20.f

*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,LH
      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,IPR2
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR
      REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX,
     1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED,QQNG,
     2 QQF,HFACT
      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),IPR2(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)
      IPR2(:NBISO)=IPR(1,:NBISO)
      !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)

         CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM)
         IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR')
      ENDIF
  610 CONTINUE
*----
*  PROCESS H-FACTOR INFORMATION
*----
      ALLOCATE(QQNG(NISOT),QQF(NISOT))
      CALL LIBEAQ(NAMFIL,NISOT,IMPX,QQNG,QQF)
      DO 620 IMX=1,NBISO
      IF(MASKI(IMX)) THEN
        KPLIB=IPISO(IMX) ! set IMX-th isotope
        ISO=IPR2(IMX)
        ALLOCATE(HFACT(NGRO))
        HFACT(:NGRO)=0.0
*       NG ENERGY.
        VALUE=QQNG(ISO)
        IF(VALUE.NE.0.0) THEN
          CALL LCMGET(KPLIB,'NG',SECT)
          HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6
          LH=.TRUE.
        ENDIF
*       FISSION ENERGIES.
        VALUE=QQF(ISO)
        IF(VALUE.NE.0.0) THEN
          CALL LCMGET(KPLIB,'NFTOT',SECT)
          HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6
          LH=.TRUE.
        ENDIF
        IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT)
        DEALLOCATE(HFACT)
      ENDIF
  620 CONTINUE
      DEALLOCATE(QQF,QQNG)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG)
      DEALLOCATE(NFS,ITYPRO,IPR2,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