*DECK LIBXS4
      SUBROUTINE LIBXS4 (IPLIB,NAMFIL,NGRO,NBISO,NL,IPROC,ISONAM,
     1 ISONRF,ISHINA,MASKI,TN,SN,SB,IMPX,NGF,NGFR,NDEL)
*
*-----------------------------------------------------------------------
*
*Purpose:
* transcription of the useful interpolated microscopic cross section
* data from APOLIB-XSM to LCM data structures
*
*Copyright:
* Copyright (C) 2014 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-XSM 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
* ISHINA  self shielding names
* MASKI   isotopic mask. Isotope with index I is processed if
*         MASKI(I)=.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
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLIB
      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
*----
      TYPE(C_PTR) IPAP
      LOGICAL LSACO
      PARAMETER (IOUT=6,MAXHOM=9,LSACO=.FALSE.)
*     NOTE: LSACO MUST BE SET TO .TRUE. WITH THE SANCHEZ-COSTE METHOD.
      EXTERNAL LIBA21
      CHARACTER TEXT20*20,TEXT80*80,HNAMIS*12,HNISOR*12,HNISSS*12,
     1 HSMG*131,TEXT2*2,TEXT12*12
      LOGICAL LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,L104,LABS,LDIF,
     1 LFIS,LPWD,LPED
      INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG
      DOUBLE PRECISION UU,XDRCST
      INTEGER ITHOMO(MAXHOM),ITEXT(20)
      REAL TKT(5)
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,NOM,NOMS,ISECTT,
     1 IFDG,IIAD,IDEPL
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR
      REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX,
     1 DELTF,SIGTF,SIGAF,SIGFF,ENER,AMASS,TEMP,TEMPS,SEQHO,PWD,PED,DKA,
     2 DKD,DKF,DK104
      REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,CHID
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE
      REAL, POINTER, DIMENSION(:) :: RTSEGM
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(IPR(2,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 THE APOLIB-XSM FILE.
*----
      CALL LCMOP(IPAP,NAMFIL,2,2,0)
*----
*  RECOVER INFORMATION FROM PHEAD DIRECTORY
*----
      CALL LCMSIX(IPAP,'PHEAD',1)
      CALL LCMGTC(IPAP,'COMH',80,1,TEXT80)
      IF(IMPX.GT.0) WRITE (IOUT,810) TEXT80
      CALL LCMLEN(IPAP,'NOM',NV,ITYLCM)
      NISOT=NV/5
      ALLOCATE(NOM(5*NISOT))
      CALL LCMGET(IPAP,'NOM',NOM)
      IF(IMPX.GE.10) THEN
        DO ISO=1,NISOT
          WRITE(TEXT20,'(5A4)') (NOM((ISO-1)*5+II),II=1,5)
          WRITE(IOUT,'(8H -----> ,A20)') TEXT20
        ENDDO
      ENDIF
      CALL LCMLEN(IPAP,'NOMS',NV,ITYLCM)
      NISOTS=NV/5
      ALLOCATE(NOMS(5*NISOTS))
      CALL LCMGET(IPAP,'NOMS',NOMS)
      IF(IMPX.GE.10) THEN
        DO ISO=1,NISOTS
          WRITE(TEXT20,'(5A4)') (NOMS((ISO-1)*5+II),II=1,5)
          WRITE(IOUT,'(8H -----> ,A20)') TEXT20
        ENDDO
      ENDIF
      CALL LCMSIX(IPAP,' ',2)
*----
*  RECOVER INFORMATION FROM PMAIL DIRECTORY
*----
      CALL LCMSIX(IPAP,'PMAIL',1)
      CALL LCMLEN(IPAP,'E',NV,ITYLCM)
      NGRO=NV-1
      CALL LCMGET(IPAP,'E',ENERG)
      CALL LCMGET(IPAP,'DEL',DELTA)
      DO IG=1,NV
        ENERG(IG)=ENERG(IG)*1.0E6
      ENDDO
      CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENERG)
      CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA)
      CALL LCMSIX(IPAP,' ',2)
*----
*  RECOVER INFORMATION FROM PCONST DIRECTORY
*----
      CALL LCMSIX(IPAP,'PCONST',1)
      CALL LCMLEN(IPAP,'AMASS',NAMASS,ITYLCM)
      IF(NAMASS.NE.NISOT) CALL XABORT('LIBXS4: INVALID AWR INFO.')
      ALLOCATE(AMASS(NAMASS))
      CALL LCMGET(IPAP,'AMASS',AMASS)
      DO IA=1,NAMASS
        AMASS(IA)=AMASS(IA)/ANEUT
      ENDDO
      CALL LCMSIX(IPAP,' ',2)
*----
*  SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES.
*----
      IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS
      CALL XDISET(IPR,2*NBISO,0)
      CALL KDRCPU(TK1)
      DO 50 IMX=1,NBISO
      IF(MASKI(IMX)) THEN
         WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3)
         WRITE(HNISSS,'(3A4)') (ISHINA(I0,IMX),I0=1,3)
         KISO=0
         DO 10 ISO=1,NISOT
         WRITE(TEXT12,'(3A4)') (NOM((ISO-1)*5+I0),I0=1,3)
         IF(ISONRF(1,IMX).EQ.NOM((ISO-1)*5+1)) THEN
            IF(ISONRF(2,IMX).EQ.NOM((ISO-1)*5+2)) THEN
               IF(ISONRF(3,IMX).EQ.NOM((ISO-1)*5+3)) THEN
                  KISO=ISO
                  GO TO 20
               ENDIF
            ENDIF
         ENDIF
   10    CONTINUE
         WRITE(TEXT12,'(3A4)') (NOM((ISO-1)*5+I0),I0=1,3)
         WRITE (HSMG,780) HNISOR,NAMFIL
         CALL XABORT(HSMG)
   20    IPR(1,IMX)=KISO
*
         IF((NISOTS.GT.0).AND.(HNISSS.NE.' ')) THEN
           KISO=0
           DO 30 ISO=1,NISOTS
           IF(ISHINA(1,IMX).EQ.NOMS((ISO-1)*5+1)) THEN
              IF(ISHINA(2,IMX).EQ.NOMS((ISO-1)*5+2)) THEN
                 IF(ISHINA(3,IMX).EQ.NOMS((ISO-1)*5+3)) THEN
                    KISO=ISO
                    GO TO 40
                 ENDIF
              ENDIF
           ENDIF
   30      CONTINUE
           WRITE (HSMG,790) HNISSS,NAMFIL
           CALL XABORT(HSMG)
   40      IPR(2,IMX)=KISO
         ENDIF
      ENDIF
   50 CONTINUE
      DEALLOCATE(NOM)
      IF(NISOTS.GT.0) DEALLOCATE(NOMS)
      CALL KDRCPU(TK2)
      TKT(1)=TK2-TK1
*----
*  READ THROUGH APOLIB-XSM 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.
*----
      CALL LCMSIX(IPAP,'QFIX',1)
      KISEG=IPR(1,IMX)
      IF(KISEG.GT.0) THEN
        CALL KDRCPU(TK1)
        IF(IMPX.GT.1) WRITE(IOUT,'(/29H LIBXS4: PROCESSING ISOTOPE '',
     1  3A4,2H''.)') (ISONRF(I0,IMX),I0=1,3)
        WRITE(TEXT12,'(4HISOT,I8.8)') KISEG
        CALL LCMSIX(IPAP,TEXT12,1)
        WRITE(TEXT80,'(19HAPOLIB-XSM ISOTOPE:,3A4)') (ISONRF(I0,IMX),
     1  I0=1,3)
        READ(TEXT80,'(20A4)') (ITEXT(I),I=1,20)
        IF(IMPX.GT.2) WRITE(IOUT,870) TEXT80
*----
*  RECOVER INFORMATION FROM ISOTOP DIRECTORY
*----
        CALL LCMSIX(IPAP,'ISOTOP',1)
        CALL LCMGET(IPAP,'LGPROB',LGPROB)
        CALL LCMGET(IPAP,'ZFISS',ZFISS)
        CALL LCMGET(IPAP,'LGTTRA',LGTTRA)
        CALL LCMGET(IPAP,'FGTD',FGTD)
        CALL LCMLEN(IPAP,'ID2',NV,ITYLCM)
        IF(NV.EQ.1) THEN
          CALL LCMGET(IPAP,'ID2',ID2)
        ELSE
          ID2=0
        ENDIF
        CALL LCMLEN(IPAP,'TEMP',NTEMP,ITYLCM)
        ALLOCATE(TEMP(NTEMP))
        CALL LCMGET(IPAP,'TEMP',TEMP)
        CALL LCMLEN(IPAP,'NANISD',NV,ITYLCM)
        IF(NV.EQ.1) THEN
          CALL LCMGET(IPAP,'NANISD',NANISD)
          CALL LCMGET(IPAP,'NANIST',NANIST)
        ELSE
          NANISD=0
          NANIST=0
        ENDIF
        CALL LCMLEN(IPAP,'LGTREA',NSECTT,ITYLCM)
        ALLOCATE(LGTRE(NSECTT),ISECTT(2*NSECTT))
        CALL LCMGET(IPAP,'LGTREA',LGTRE)
        CALL LCMGET(IPAP,'TYSECT',ISECTT)
        IF(IMPX.GT.2) WRITE(IOUT,880) (TEMP(I),I=1,NTEMP)
        IF(IMPX.GT.2) WRITE(IOUT,890) ZFISS,LGPROB,LGTDIF,LGTTRA,
     1  FGTD,ID2,NSECTT,NANISD,NANIST,(LGTRE(I),I=1,NSECTT)
        IF(NANIST.GT.NANISD) CALL XABORT('LIBXS4: NANIST.GT.NANISD')
        CALL LCMLEN(IPAP,'PPPSN',NV,ITYLCM)
        LTRAN=(NV.NE.0)
        IF(LTRAN) THEN
          CALL LCMSIX(IPAP,'PPPSN',1)
          CALL LCMGET(IPAP,'FAGG',FAGG)
          CALL LCMGET(IPAP,'LAGG',LAGG)
          CALL LCMGET(IPAP,'FDGG',FDGG)
          CALL LCMGET(IPAP,'WGAL',WGAL)
          CALL LCMGET(IPAP,'FAG',FAG)
          CALL LCMGET(IPAP,'LAG',LAG)
          CALL LCMGET(IPAP,'NGTD',NGTD)
          CALL LCMLEN(IPAP,'FDG',NV,ITYLCM)
          ALLOCATE(IFDG(NV))
          CALL LCMGET(IPAP,'FDG',IFDG)
          CALL LCMLEN(IPAP,'IAD',NV,ITYLCM)
          ALLOCATE(IIAD(NV))
          CALL LCMGET(IPAP,'IAD',IIAD)
          CALL LCMLEN(IPAP,'DEPL',NGTD,ITYLCM)
          ALLOCATE(IDEPL(NGTD))
          CALL LCMGET(IPAP,'DEPL',IDEPL)
          IF(IMPX.GT.2) WRITE(IOUT,900) FAGG,LAGG,FDGG,WGAL,FAG,LAG,
     1    NGTD
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMSIX(IPAP,' ',2)
*----
*  RECOVER INFORMATION FROM PSECT DIRECTORY
*----
        CALL LCMSIX(IPAP,'PSECT',1)
        CALL LCMSIX(IPAP,'DIFP0',1)
        CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
        ALLOCATE(RTSEGM(NV))
        CALL LCMGET(IPAP,'SECT',RTSEGM)
        DO JMX=IMX,NBISO
          IF(IPR(1,JMX).EQ.KISEG) THEN
            WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
            CALL LCMLEN(IPLIB,HNAMIS,ILENG,ITYLCM)
            CALL LCMSIX(IPLIB,HNAMIS,1)
            IF(ILENG.EQ.0) THEN
              IF(IPR(1,JMX).LE.0) CALL XABORT('LIBA20: BAD AWR.')
              CALL LCMPUT(IPLIB,'AWR',1,2,AMASS(IPR(1,JMX)))
              CALL LCMPUT(IPLIB,'README',20,3,ITEXT)
            ENDIF
            CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
            CALL LCMPUT(IPLIB,'NTOT0',NGRO,2,SECT)
            CALL LCMPUT(IPLIB,'SIGS00',NGRO,2,SECT)
            CALL LCMSIX(IPLIB,' ',2)
          ENDIF
        ENDDO
        DEALLOCATE(RTSEGM)
        CALL LCMSIX(IPAP,' ',2)
        CALL LCMLEN(IPAP,'SIGA',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'SIGA',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          ALLOCATE(RTSEGM(NV))
          CALL LCMGET(IPAP,'SECT',RTSEGM)
          DO JMX=IMX,NBISO
            IF(IPR(1,JMX).EQ.KISEG) THEN
              WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
              CALL LCMLEN(IPLIB,HNAMIS,ILENG,ITYLCM)
              CALL LCMSIX(IPLIB,HNAMIS,1)
              CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
              CALL LCMGET(IPLIB,'NTOT0',XSTOT)
              DO IG=1,NGRO
                XSTOT(IG)=XSTOT(IG)+SECT(IG)
              ENDDO
              CALL LCMPUT(IPLIB,'NTOT0',NGRO,2,XSTOT)
              CALL LCMSIX(IPLIB,' ',2)
            ENDIF
          ENDDO
          DEALLOCATE(RTSEGM)
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'NEXCESS',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'NEXCESS',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMGET(IPLIB,'SIGS00',SIGS)
                LN2N=.FALSE.
                DO IG=1,NGRO
                  LN2N=LN2N.OR.(SECT(IG).NE.0.0)
                  SIGS(IG,1)=SIGS(IG,1)+SECT(IG)
                ENDDO
                IF(LN2N) THEN
                  CALL LCMPUT(IPLIB,'N2N',NGRO,2,SECT)
                  CALL LCMPUT(IPLIB,'SIGS00',NGRO,2,SIGS)
                ENDIF
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'SIGF',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'SIGF',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMPUT(IPLIB,'NFTOT',NGRO,2,SECT)
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'NUSIGF',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'NUSIGF',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMPUT(IPLIB,'NUSIGF',NGRO,2,SECT)
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'CHI',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'CHI',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMPUT(IPLIB,'CHI',NGRO,2,SECT)
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'CREA-A',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'CREA-A',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMPUT(IPLIB,'NA',NGRO,2,SECT)
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'CREA-P',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'CREA-P',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMPUT(IPLIB,'NP',NGRO,2,SECT)
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'CREA-H2',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'CREA-H2',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMPUT(IPLIB,'ND',NGRO,2,SECT)
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMLEN(IPAP,'CREA-H3',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'CREA-H3',1)
          CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            ALLOCATE(RTSEGM(NV))
            CALL LCMGET(IPAP,'SECT',RTSEGM)
            DO JMX=IMX,NBISO
              IF(IPR(1,JMX).EQ.KISEG) THEN
                WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
                CALL LCMSIX(IPLIB,HNAMIS,1)
                CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SECT)
                CALL LCMPUT(IPLIB,'NT',NGRO,2,SECT)
                CALL LCMSIX(IPLIB,' ',2)
              ENDIF
            ENDDO
            DEALLOCATE(RTSEGM)
          ENDIF
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMSIX(IPAP,' ',2)
*----
*  RECOVER SCATTERING INFORMATION FROM ISOTOP DIRECTORY
*----
        CALL LCMSIX(IPAP,'ISOTOP',1)
        IF(.NOT.LTRAN) THEN
          DO JMX=IMX,NBISO
            IF(IPR(1,JMX).EQ.KISEG) THEN
              WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
              CALL LCMSIX(IPLIB,HNAMIS,1)
              CALL LCMGET(IPLIB,'SIGS00',SIGS)
              CALL XDRSET(SCAT,NGRO*NGRO,0.0)
              DO IG=1,NGRO
                SCAT(IG,IG,1)=SIGS(IG,1)
              ENDDO
              CALL XDRLGS(IPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO)
              CALL LCMSIX(IPLIB,' ',2)
            ENDIF
          ENDDO
        ELSE
          CALL LCMLEN(IPAP,'PSN',NV,ITYLCM)
          IF(NV.EQ.0) CALL XABORT('LIBXS4: PPPSN MISSING.')
          ALLOCATE(RTSEGM(NV))
          CALL LCMGET(IPAP,'PSN',RTSEGM)
          DO JMX=IMX,NBISO
            IF(IPR(1,JMX).EQ.KISEG) THEN
              WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
              CALL LCMSIX(IPLIB,HNAMIS,1)
              CALL XDRSET(SCAT,NGRO*NGRO,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,SCAT)
              CALL LCMGET(IPLIB,'SIGS00',SIGS)
              IF(LGPROB) THEN
                 DO IG=1,NGRO
                   DO JG=1,NGRO
                     SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1)
                   ENDDO
                 ENDDO
              ENDIF
              CALL XDRLGS(IPLIB,1,IMPX,0,0,1,NGRO,SIGS,SCAT,ITYPRO)
              CALL LCMSIX(IPLIB,' ',2)
            ENDIF
          ENDDO
          DEALLOCATE(RTSEGM)
        ENDIF
        CALL LCMSIX(IPAP,' ',2)
        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
        WRITE(TEXT12,'(4HDIFF,I8.8)') IL-1
        CALL LCMLEN(IPAP,TEXT12,NV,ITYLCM)
        IF(NV.EQ.0) THEN
          CALL LCMLIB(IPAP)
          WRITE(HSMG,'(42HLIBXS4: MISSING SCATTERING MATRIX OF ORDER,
     1    I4,1H.)') IL-1
          CALL XABORT(HSMG)
        ENDIF
        CALL LCMSIX(IPAP,TEXT12,1)
        CALL LCMLEN(IPAP,'SECT',NV,ITYLCM)
        IF(NV.EQ.0) CALL XABORT('LIBXS4: ZERO SCATTERING RECORD.')
        ALLOCATE(RTSEGM(NV))
        CALL LCMGET(IPAP,'SECT',RTSEGM)
        DO 260 JMX=IMX,NBISO
        IF(IPR(1,JMX).EQ.KISEG) THEN
           WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
           CALL LCMSIX(IPLIB,HNAMIS,1)
           CALL LIBA22(NGRO,TN(JMX),NTEMP,NV,FGTD,TEMP,RTSEGM,SIGS)
           CALL LCMPUT(IPLIB,'SIGS'//TEXT2,NGRO,2,SIGS)
           IF(IL.GT.NANIST) THEN
              CALL XDRSET(SCAT,NGRO*NGRO,0.0)
              DO IG=1,NGRO
                SCAT(IG,IG,1)=SIGS(IG,1)
              ENDDO
              CALL XDRLGS(IPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,
     1        ITYPRO)
           ENDIF
           CALL LCMSIX(IPLIB,' ',2)
        ENDIF
  260   CONTINUE
        CALL LCMSIX(IPAP,' ',2)
        DEALLOCATE(RTSEGM)
  270   CONTINUE
*----
*  RECOVER TRANSFER MATRICES FOR HIGHER LEGENDRE ORDERS.
*----
        DO 300 IL=2,MIN(NANIST,NL)
        WRITE(TEXT2,'(I2.2)') IL-1
        WRITE(TEXT12,'(4HTRAN,I8.8)') IL-1
        CALL LCMLEN(IPAP,TEXT12,NV,ITYLCM)
        IF(NV.EQ.0) THEN
          CALL LCMLIB(IPAP)
          WRITE(HSMG,'(40HLIBXS4: MISSING TRANSFER MATRIX OF ORDER,I4,
     1    1H.)') IL-1
          CALL XABORT(HSMG)
        ENDIF
        CALL LCMSIX(IPAP,TEXT12,1)
        CALL LCMLEN(IPAP,'PSN',NV,ITYLCM)
        IF(NV.EQ.0) CALL XABORT('LIBXS4: ZERO TRANSFER RECORD.')
        ALLOCATE(RTSEGM(NV))
        CALL LCMGET(IPAP,'PSN',RTSEGM)
        DO 290 JMX=IMX,NBISO
        IF(IPR(1,JMX).EQ.KISEG) THEN
          WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
          CALL LCMSIX(IPLIB,HNAMIS,1)
          CALL LIBA23(NGRO,IL,TN(JMX),NTEMP,NGTD,NV,TEMP,FGTD,ID2,
     1    FAGG,LAGG,FDGG,WGAL,FAG,LAG,IFDG,IIAD,IDEPL,RTSEGM,SCAT)
          CALL LCMGET(IPLIB,'SIGS'//TEXT2,SIGS)
          IF(LGPROB) THEN
             DO IG=1,NGRO
               DO JG=1,NGRO
                 SCAT(JG,IG,1)=SCAT(JG,IG,1)*SIGS(IG,1)
               ENDDO
             ENDDO
          ENDIF
          CALL XDRLGS(IPLIB,1,IMPX,IL-1,IL-1,1,NGRO,SIGS,SCAT,ITYPRO)
          CALL LCMSIX(IPLIB,' ',2)
        ENDIF
  290   CONTINUE
        CALL LCMSIX(IPAP,' ',2)
        DEALLOCATE(RTSEGM)
  300   CONTINUE
        CALL KDRCPU(TK2)
        TKT(3)=TKT(3)+(TK2-TK1)
*----
*  RECOVER DELAYED NEUTRON DATA.
*----
        CALL KDRCPU(TK1)
        CALL LCMLEN(IPAP,'BETAEF',NV,ITYLCM)
        IF(NV.NE.0) THEN
          CALL LCMSIX(IPAP,'BETAEF',1)
          CALL LCMLEN(IPAP,'WD',NDEL0,ITYLCM)
          IF(NDEL0.GT.0) THEN
            LPWD=.TRUE.
            NDEL=MAX(NDEL,NDEL0)
            ALLOCATE(PWD(NDEL0))
            CALL LCMGET(IPAP,'WD',PWD)
          ENDIF
          CALL LCMLEN(IPAP,'PED',NV,ITYLCM)
          IF(NV.EQ.NGRO) THEN
            LPED=.TRUE.
            ALLOCATE(PED(NGRO))
            CALL LCMGET(IPAP,'PED',PED)
          ENDIF
          DO 340 JMX=IMX,NBISO
          IF(IPR(1,JMX).EQ.KISEG) THEN
             WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
             CALL LCMSIX(IPLIB,HNAMIS,1)
             CALL LCMLEN(IPAP,'LAMBDA',NV,ITYLCM)
             IF(NV.GT.0) THEN
               NDEL=MAX(NDEL,NV)
               ALLOCATE(RTSEGM(NV))
               CALL LCMGET(IPAP,'LAMBDA',RTSEGM)
               CALL LCMPUT(IPLIB,'LAMBDA-D',NV,2,RTSEGM)
               DEALLOCATE(RTSEGM)
             ENDIF
             CALL LCMLEN(IPAP,'CHID',NV,ITYLCM)
             IF((NV.GT.0).AND.(NV.EQ.NDEL0*NGRO)) THEN
               ALLOCATE(CHID(NGRO,NDEL0))
               CALL LCMGET(IPAP,'CHID',CHID)
               DO IDEL=1,NDEL0
                 WRITE(TEXT2,'(I2.2)') IDEL
                 CALL LCMPUT(IPLIB,'CHI'//TEXT2,NGRO,2,CHID(1,IDEL))
               ENDDO
               DEALLOCATE(CHID)
             ENDIF
             CALL LCMSIX(IPLIB,' ',2)
          ENDIF
  340     CONTINUE
          IF(LPWD.AND.LPED) THEN
             DO 390 JMX=IMX,NBISO
             IF(IPR(1,JMX).EQ.KISEG) THEN
               WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
               CALL LCMSIX(IPLIB,HNAMIS,1)
               DO 380 IDEL=1,NDEL0
               WRITE(TEXT2,'(I2.2)') IDEL
               CALL LCMGET(IPLIB,'NUSIGF',SECT)
               DO 370 IGR=1,NGRO
  370          SECT(IGR)=SECT(IGR)*PWD(IDEL)*PED(IGR)
               CALL LCMPUT(IPLIB,'NUSIGF'//TEXT2,NGRO,2,SECT)
  380          CONTINUE
               CALL LCMSIX(IPLIB,' ',2)
             ENDIF
  390        CONTINUE
          ENDIF
          IF(LPWD) DEALLOCATE(PWD)
          IF(LPED) DEALLOCATE(PED)
          CALL LCMSIX(IPAP,' ',2)
        ENDIF
        CALL LCMSIX(IPAP,' ',2)
        DO JMX=IMX,NBISO
          IF(IPR(1,JMX).EQ.KISEG) IPR(1,JMX)=0
        ENDDO
        IF(LTRAN) DEALLOCATE(IDEPL,IIAD,IFDG)
        DEALLOCATE(ISECTT,LGTRE,TEMP)
        CALL KDRCPU(TK2)
        TKT(2)=TKT(2)+(TK2-TK1)
        IF((IMPX.GT.9).AND.(IPR(1,IMX).EQ.0)) THEN
          WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
          CALL LCMSIX(IPLIB,HNAMIS,1)
          CALL LCMLIB(IPLIB)
          CALL LCMSIX(IPLIB,' ',2)
        ENDIF
      ENDIF
      CALL LCMSIX(IPAP,' ',2)
*----
*  PROCESS SELF-SHIELDING INFORMATION.
*----
      L104=.FALSE.
      CALL LCMSIX(IPAP,'QFIXS',1)
      KISEG=IPR(2,IMX)
      IF(KISEG.GT.0) THEN
        CALL KDRCPU(TK1)
        IF(IMPX.GT.1) WRITE(IOUT,'(/31H LIBXS4: PROCESSING SELF SHIELD,
     1  13HING ISOTOPE '',3A4,2H''.)') (ISHINA(I0,IMX),I0=1,3)
        WRITE(TEXT12,'(4HISOT,I8.8)') KISEG
        CALL LCMSIX(IPAP,TEXT12,1)
        CALL LCMSIX(IPAP,'SSDATA',1)
        CALL LCMLEN(IPAP,'ITHOMO',NTHOMO,ITYLCM)
        IF(NTHOMO.GT.MAXHOM) CALL XABORT('LIBXS4: ITHOMO OVERFLOW.')
        CALL LCMGET(IPAP,'ITHOMO',ITHOMO)
        FGHOMO=ITHOMO(1)
        LGHOMO=ITHOMO(2)
        FGRESO=ITHOMO(3)
        NGHOMO=LGHOMO-FGHOMO+1
        ALLOCATE(TAUX(7*NGHOMO))
        CALL LCMGET(IPAP,'OXM',IOXM)
        NGF=MIN(NGF,FGHOMO)
        NGFR=MAX(NGFR,LGHOMO)
        CALL LCMLEN(IPAP,'SEQHOM',NSEQHO,ITYLCM)
        ALLOCATE(SEQHO(NSEQHO))
        CALL LCMGET(IPAP,'SEQHOM',SEQHO)
        CALL LCMLEN(IPAP,'TEMPS',NTEMPS,ITYLCM)
        ALLOCATE(TEMPS(NTEMPS))
        CALL LCMGET(IPAP,'TEMPS',TEMPS)
        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
        ENDIF
        CALL LCMSIX(IPAP,'PTHOM2',1)
        LENGTH=NGHOMO*NTEMPS*NSEQHO
        ALLOCATE(DKA(LENGTH),DKD(LENGTH),DKF(LENGTH),DK104(LENGTH))
        CALL XDRSET(DKA,LENGTH,0.0)
        CALL XDRSET(DKD,LENGTH,0.0)
        CALL XDRSET(DKF,LENGTH,0.0)
        CALL XDRSET(DK104,LENGTH,0.0)
        CALL LCMLEN(IPAP,'ABSOH',NV,ITYLCM)
        LABS=NV.EQ.LENGTH
        CALL LCMLEN(IPAP,'DIFFH',NV,ITYLCM)
        LDIF=NV.EQ.LENGTH
        CALL LCMLEN(IPAP,'FISSH',NV,ITYLCM)
        LFIS=NV.EQ.LENGTH
        IF(LABS) CALL LCMGET(IPAP,'ABSOH',DKA)
        IF(LDIF) CALL LCMGET(IPAP,'DIFFH',DKD)
        IF(LFIS) THEN
          CALL LCMGET(IPAP,'FISSH',DKF)
          LFIS=.FALSE.
          DO I=1,LENGTH
            LFIS=LFIS.OR.(DKF(I).NE.0.0)
          ENDDO
        ENDIF
        DO 460 JMX=IMX,NBISO
        IF(IPR(2,JMX).EQ.KISEG) THEN
          WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
          CALL LCMSIX(IPLIB,HNAMIS,1)
          IF(IMPX.GT.3) WRITE(6,'(/17H LIBXS4: PROCESS ,A12,1H:)')
     1    HNAMIS
          CALL LIBA24(NGRO,FGHOMO,NGHOMO,NSEQHO,NTEMPS,LFIS,L104,
     1    SEQHO,TEMPS,TN(JMX),SN(1,JMX),DKA,DKD,DKF,DK104,IMPX,TAUX)
*
*         COMPUTE THE SELF-SHIELDED FLUX AND CROSS SECTIONS.
          CALL LIBA25(IPLIB,LABS,LDIF,LFIS,L104,NGRO,FGHOMO,NGHOMO,
     1    NSEQHO,NL,SEQHO,SN(1,JMX),SB(1,JMX),DELTA,ISONAM(1,JMX),
     2    TAUX,IMPX)
          CALL LCMSIX(IPLIB,' ',2)
        ENDIF
  460   CONTINUE
        CALL LCMSIX(IPAP,' ',2) ! PTHOM2
        CALL LCMSIX(IPAP,' ',2) ! SSDATA
        DEALLOCATE(DK104,DKF,DKD,DKA)
        CALL KDRCPU(TK2)
        TKT(4)=TKT(4)+(TK2-TK1)
*----
*  RECOVER THE AUTOLIB (BIN CROSS SECTIONS) INFORMATION.
*----
        CALL KDRCPU(TK1)
        CALL LCMLEN(IPAP,'SSSECT',NV,ITYLCM)
        IF((NV.NE.0).AND.(IPROC.GE.3)) THEN
          CALL KDRCPU(TK1)
          CALL LCMSIX(IPAP,'SSSECT',1)
          LBIN=0
          CALL XDISET(NFS,NGRO,0)
          NGBIN=MIN(NGHOMO,NGRO-FGRESO+1)
          DO IG=1,NGBIN
            WRITE(TEXT12,'(6HPTHOM5,I6.6)') IG
            CALL LCMSIX(IPAP,TEXT12,1)
            CALL LCMSIX(IPAP,'NTEMPS000001',1)
            CALL LCMLEN(IPAP,'DELTF',NFS(FGRESO+IG-1),ITYLCM)
            LBIN=LBIN+NFS(FGRESO+IG-1)
            CALL LCMSIX(IPAP,' ',2)
            CALL LCMSIX(IPAP,' ',2)
          ENDDO
          IF(LSACO) THEN
            NFSBIN=NFS(FGRESO)
            LBIN=LBIN+(FGRESO-FGHOMO)*NFSBIN
          ELSE
            NFSBIN=0
          ENDIF
          DO 530 JMX=IMX,NBISO
          IF(IPR(2,JMX).EQ.KISEG) THEN
            ALLOCATE(DELTF(LBIN),SIGTF(LBIN),SIGAF(LBIN),SIGFF(LBIN))
            IOF=(FGRESO-FGHOMO)*NFSBIN
            WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JMX),I0=1,3)
            CALL LCMSIX(IPLIB,HNAMIS,1)
            DO 500 IG=1,NGBIN
            IGG=FGRESO+IG-1
            WRITE(TEXT12,'(6HPTHOM5,I6.6)') IG
            CALL LCMSIX(IPAP,TEXT12,1)
            CALL LIBXS5(IG,NGBIN,IPAP,NFS(IGG),TN(JMX),NTEMPS,TEMPS,
     1      DELTF(IOF+1),SIGTF(IOF+1),SIGAF(IOF+1),SIGFF(IOF+1),DELINF,
     2      SGTINF,SGAINF,SGFINF)
            CALL LCMSIX(IPAP,' ',2)
            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))
            IF(SGFINF.NE.0.0) THEN
              F4=TAUX(6*NGHOMO+IG2)/(SGFINF*DELTA(IGG))
            ELSE
              F4=0.0
            ENDIF
            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
            IF(SGFINF.NE.0.0) SIGFF(IOF+I)=SIGFF(IOF+I)*F4
  490       CONTINUE
  500       IOF=IOF+NFS(IGG)
*----
*  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)
              E4=TAUX(6*NGHOMO+IG2)
              IBIN=0
              DO 510 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
              IF(E4.NE.0.0) F4=TAUX(6*NGHOMO+IG2)/E4
              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
              IF(E4.NE.0.0) SIGFF(IBIN)=SIGFF(JBIN)*F4/F1
  510         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))
  520       SIGAF(I)=SIGTF(I)-SIGAF(I)
            DEALLOCATE(DELTF)
            CALL LCMPUT(IPLIB,'BIN-NFS',NGRO,1,NFS)
            CALL LCMPUT(IPLIB,'BIN-ENERGY',LBIN+1,2,ENER)
            CALL LCMPUT(IPLIB,'BIN-NTOT0',LBIN,2,SIGTF)
            CALL LCMPUT(IPLIB,'BIN-SIGS00',LBIN,2,SIGAF)
            IF(SGFINF.NE.0.0) CALL LCMPUT(IPLIB,'BIN-SIGF',LBIN,2,SIGFF)
            DEALLOCATE(ENER,SIGFF,SIGAF,SIGTF)
            CALL LCMSIX(IPLIB,' ',2)
          ENDIF
  530     CONTINUE
          CALL KDRCPU(TK2)
          TKT(5)=TKT(5)+(TK2-TK1)
          CALL LCMSIX(IPAP,' ',2) ! SSSECT
        ENDIF
        DO JMX=IMX,NBISO
          IF(IPR(2,JMX).EQ.KISEG) IPR(2,JMX)=0
        ENDDO
        CALL LCMSIX(IPAP,' ',2) ! ISOT
        DEALLOCATE(TAUX,TEMPS,SEQHO)
      ENDIF
      CALL LCMSIX(IPAP,' ',2) ! QFIXS
  560 CONTINUE
      CALL LCMCL(IPAP,1)
*----
*  CHECK IF ALL REACTIONS HAVE BEEN PROCESSED.
*----
      DO 570 IMX=1,NBISO
      DO 570 I=1,2
      IF(IPR(I,IMX).NE.0) THEN
         WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3)
         CALL XABORT(HSMG)
      ENDIF
  570 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
         WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
         CALL LCMSIX(IPLIB,HNAMIS,1)
         CALL LCMGET(IPLIB,'NTOT0',SECT)
         CALL LCMLEN(IPLIB,'SIGS00',LENGT,ITYLCM)
         IF(LENGT.EQ.NGRO) THEN
            CALL LCMGET(IPLIB,'SIGS00',XSTOT)
            DO 580 IU=1,NGRO
  580       SECT(IU)=SECT(IU)-XSTOT(IU)
         ENDIF
         CALL LCMLEN(IPLIB,'NFTOT',LENGT,ITYLCM)
         IF(LENGT.EQ.NGRO) THEN
            CALL LCMGET(IPLIB,'NFTOT',XSTOT)
            DO 590 IU=1,NGRO
  590       SECT(IU)=SECT(IU)-XSTOT(IU)
         ENDIF
         CALL LCMLEN(IPLIB,'N2N',LENGT,ITYLCM)
         IF(LENGT.EQ.NGRO) THEN
            CALL LCMGET(IPLIB,'N2N',XSTOT)
            DO 600 IU=1,NGRO
  600       SECT(IU)=SECT(IU)+XSTOT(IU)
         ENDIF
         CALL LCMPUT(IPLIB,'NG',NGRO,2,SECT)
         CALL LCMSIX(IPLIB,' ',2)
      ENDIF
  610 CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(AMASS)
      DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG)
      DEALLOCATE(NFS,ITYPRO,IPR)
      RETURN
*
  780 FORMAT(26HLIBXS4: MATERIAL/ISOTOPE ',A12,20H' IS MISSING ON APOL,
     1 15HIB-2 FILE NAME ,A12,1H.)
  790 FORMAT(49HLIBXS4: SELF-SHIELDING DATA OF MATERIAL/ISOTOPE ',A12,
     1 35H' IS MISSING ON APOLIB-2 FILE NAME ,A12,1H.)
  800 FORMAT(/43H LIBXS4: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.)
  810 FORMAT(/32H LIBXS4: X-SECTION LIBRARY INFO:/9X,A80/)
  820 FORMAT(/35H LIBXS4: PROBING THE APOLIB-2 FILE./9X,11HNUMBER OF I,
     1 29HSOTOPES AT INFINITE DILUTION=,I8/9X,21HNUMBER OF SELF-SHIELD,
     2 12HED ISOTOPES=,I8)
  870 FORMAT(/9X,15HISOTOPE TITLE: ,A80)
  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/9X,7HNANISD=,I3,8H NANIST=,
     2 I3,8H LGTREA=,15L2/(38X,15L2))
  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)
  940 FORMAT(/26H LIBXS4: 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(26HLIBXS4: REMAINING REACTION,I3,14H FOR ISOTOPE ',3A4,
     1 2H'.)
      END
