Initial commit from Polytechnique Montreal

1 files changed, 580 insertions, 0 deletions

diff --git a/Dragon/src/LIBEAR.f b/Dragon/src/LIBEAR.f
new file mode 100644
index 0000000..8b7746c
--- /dev/null
+++ b/Dragon/src/LIBEAR.f
@@ -0,0 +1,580 @@
+*DECK LIBEAR
+      SUBROUTINE LIBEAR(CFILNA,MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Read depletion data on an APOLIB-2 formatted library.
+*
+*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
+* CFILNA  APOLIB-2 file name.
+* MAXR    number of reaction types.
+* NEL     number of isotopes on library.
+* NMDEPL  names of reactions:
+*           NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT';
+*           NMDEPL(3)='NG'   ; NMDEPL(4)='N2N';
+*           etc.
+*
+*Parameters: output
+* ITNAM   reactive isotope names in chain.
+* ITZEA   6-digit nuclide identifier:
+*         atomic number z*10000 (digits) + mass number a*10 +
+*         energy state (0 = ground state, 1 = first state, etc.).
+* KPAX    complete reaction type matrix.
+* BPAX    complete branching ratio matrix.
+*
+*-----------------------------------------------------------------------
+*
+*----
+*  INPUT FORMAT
+*----
+*    LIB: APLIB2 FIL: CFILNA CHAIN
+*    [[ hnamson
+*    [ FROM  [[ { DECAY | reaction } yield hnampar ]] ]
+*    ]]
+*    ENDCHAIN
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      CHARACTER CFILNA*(*),NMDEPL(MAXR)*8
+      INTEGER MAXR,NEL,ITNAM(3,NEL),ITZEA(NEL),KPAX(NEL+MAXR,NEL)
+      REAL BPAX(NEL+MAXR,NEL)
+*
+      EXTERNAL LIBA21
+      INTEGER ISFICH(3),NITCA(5)
+      PARAMETER (IOUT=6)
+      CHARACTER TEXT20*20,NOMOBJ*20,TEXT8*8,TEXT12*12,TYPOBJ*8,TYPSEG*8,
+     > HNISOR*20,HITNAM*20,HSMG*131,TEXT16*16
+      LOGICAL LPHEAD,LPCONS,LPNUMF,LTEST,LPFIX
+      DOUBLE PRECISION DBLINP
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,NOMOB,KDS,LGS,ITCARO,
+     1 NOM,IA,IZ,NFG,IZSECT,ISECTT,IKEEP
+      REAL, ALLOCATABLE, DIMENSION(:) :: GAMMA
+      TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR
+      INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM
+      REAL, POINTER, DIMENSION(:) :: RTSEGM
+*
+      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   /
+*----
+*  OPEN AND PROBE THE APOLIB-2 FILE.
+*----
+      CALL AEXTPA(CFILNA,ISFICH)
+      IADRES=ISFICH(1)
+      NBOBJ=ISFICH(2)
+      LBLOC=ISFICH(3)
+      IUNIT=KDROPN(CFILNA,2,4,LBLOC)
+      IF(IUNIT.LE.0) THEN
+         TEXT12=CFILNA
+         CALL XABORT('LIBEAR: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
+     1   'E OPENED')
+      ENDIF
+*----
+*  INDEX THE APOLIB-2 FILE.
+*----
+      ALLOCATE(VINTE(2*NBOBJ))
+      CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ)
+      IDKNO=1-TKCARO(14)
+      IDKTY=1-TKCARO(21)
+      IDKDS=1-TKCARO(10)
+      IDKTS=1-TKCARO(23)
+      IDKNS=TKCARO(2)+1
+      IDKLS=TKCARO(8)
+*
+      NSEGM=0
+      NMGY=0
+      NISOT=0
+      ALLOCATE(NOMOB(5*(NBOBJ-3)),KDS(NBOBJ-3),LGS(NBOBJ-3))
+      LPHEAD=.FALSE.
+      LPCONS=.FALSE.
+      LPNUMF=.FALSE.
+      DO 80 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)
+      IF(TYPOBJ.EQ.'APOLIB') THEN
+         DO 70 IS=1,NS
+         IDK=JDKTS+8*(IS-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         LTESTS=ITCARO(IDKLS+IS)
+         IF(LTESTS.LE.0) GO TO 70
+         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(LTESTS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1)
+         IF(TYPSEG.EQ.'PHEAD') THEN
+            LPHEAD=.TRUE.
+            CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,
+     1      ICHDKL,IDK,NV)
+            IF(NV.EQ.0) THEN
+               TEXT12=CFILNA
+               CALL XABORT('LIBEAR: NO ISOTOPES PRESENT ON APOLIB-2 '//
+     1         'FILE NAMED: '//TEXT12)
+            ENDIF
+            NISOT=NV/20
+            IF(NISOT.NE.NEL) CALL XABORT('LIBEAR: INVALID NEL.')
+            ALLOCATE(NOM(5*NISOT))
+            DO 20 ISO=1,NISOT
+            ISO2=(ISO-1)*5+1
+            CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),HNISOR)
+            CALL LCMCAR(HNISOR,.TRUE.,NOM(ISO2))
+            READ(HNISOR,'(3A4)') (ITNAM(II,ISO),II=1,3)
+   20       CONTINUE
+         ELSE IF(TYPSEG.EQ.'PCONST') THEN
+            LPCONS=.TRUE.
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            ALLOCATE(IA(NV))
+            DO 30 I=1,NV
+            IA(I)=ITSEGM(IDK+I-1)
+   30       CONTINUE
+            CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            ALLOCATE(IZ(NV))
+            DO 40 I=1,NV
+            IZ(I)=ITSEGM(IDK+I-1)
+   40       CONTINUE
+            CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            ALLOCATE(NFG(NV))
+            DO 50 I=1,NV
+            NFG(I)=ITSEGM(IDK+I-1)
+   50       CONTINUE
+         ELSE IF(TYPSEG.EQ.'PNUMF') THEN
+            LPNUMF=.TRUE.
+            CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NBFISS)
+            NBFISS=NBFISS/7
+            CALL AEXGNV(4,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NBPF)
+            NBPF=NBPF/7
+            CALL AEXGNV(7,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+            ALLOCATE(GAMMA(NV))
+            DO 60 I=1,NV
+            GAMMA(I)=RTSEGM(IDK+I-1)
+   60       CONTINUE
+            NMGY=NV/(NBFISS*NBPF)
+         ENDIF
+         CALL LCMDRD(TSEGM_PTR)
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+   70    CONTINUE
+      ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN
+         NSEGM=NSEGM+1
+         ISO2=(NSEGM-1)*5+1
+         CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2))
+         KDS(NSEGM)=IDKOBJ
+         LGS(NSEGM)=LGSEG
+      ELSE
+         CALL XABORT('LIBEAR: WEIRD SEGMENT TYPE: '//TYPOBJ//' (1).')
+      ENDIF
+      DEALLOCATE(ITCARO)
+   80 CONTINUE
+      IF(.NOT.LPHEAD) CALL XABORT('LIBEAR: PHEAD SEGMENT NOT FOUND.')
+      IF(.NOT.LPCONS) CALL XABORT('LIBEAR: PCONST SEGMENT NOT FOUND.')
+      IF(.NOT.LPNUMF) CALL XABORT('LIBEAR: PNUMF SEGMENT NOT FOUND.')
+      DEALLOCATE(VINTE)
+*----
+*  SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES.
+*----
+      KISEG2=0
+      DO 260 ISO=1,NISOT
+      ISO2=(ISO-1)*5+1
+      CALL LCMCAR(TEXT16,.FALSE.,NOM(ISO2))
+      TEXT20='ISOTOP'//TEXT16(:14)
+      CALL LCMCAR(TEXT20,.TRUE.,NITCA(1))
+      DO 90 ISEG=1,NSEGM
+      ISEG2=(ISEG-1)*5+1
+      IF(NITCA(1).EQ.NOMOB(ISEG2)) THEN
+         IF(NITCA(2).EQ.NOMOB(ISEG2+1)) THEN
+            IF(NITCA(3).EQ.NOMOB(ISEG2+2)) THEN
+               IF(NITCA(4).EQ.NOMOB(ISEG2+3)) THEN
+                  IF(NITCA(5).EQ.NOMOB(ISEG2+4)) THEN
+                     KISEG2=ISEG
+                     GO TO 100
+                  ENDIF
+               ENDIF
+            ENDIF
+         ENDIF
+      ENDIF
+   90 CONTINUE
+      WRITE (HSMG,500) HNISOR,CFILNA
+      CALL XABORT(HSMG)
+  100 KISEG3=0
+      TEXT20='PHYSIQ'//TEXT16(:14)
+      CALL LCMCAR(TEXT20,.TRUE.,NITCA(1))
+      DO 110 ISEG=1,NSEGM
+      ISEG2=(ISEG-1)*5+1
+      IF(NITCA(1).EQ.NOMOB(ISEG2)) THEN
+         IF(NITCA(2).EQ.NOMOB(ISEG2+1)) THEN
+            IF(NITCA(3).EQ.NOMOB(ISEG2+2)) THEN
+               IF(NITCA(4).EQ.NOMOB(ISEG2+3)) THEN
+                  IF(NITCA(5).EQ.NOMOB(ISEG2+4)) THEN
+                     KISEG3=ISEG
+                     GO TO 120
+                  ENDIF
+               ENDIF
+            ENDIF
+         ENDIF
+      ENDIF
+  110 CONTINUE
+*----
+*  ACTIVATION OF CORRESPONDING 'ISOTOP'//NAME SEGMENT.
+*----
+  120 IDKOBJ=KDS(KISEG2)
+      LGSEG=LGS(KISEG2)
+      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)
+      NSETOT=0
+      NPHY=0
+*----
+*  RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION.
+*----
+      LPFIX=.FALSE.
+      DO 160 IS=1,NS
+      IDK=JDKTS+8*(IS-1)
+      CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+      LTESTS=ITCARO(IDKLS+IS)
+      IF(LTESTS.LE.0) GO TO 160
+      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(LTESTS+1)
+      CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /))
+      CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /))
+      CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1)
+      IF(TYPSEG.EQ.'PFIX') THEN
+         LPFIX=.TRUE.
+*        NG ENERGY.
+         CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV.NE.0) THEN
+            IF(RTSEGM(IDK).NE.0.0) THEN
+               KPAX(NEL+3,ISO)=1
+               BPAX(NEL+3,ISO)=RTSEGM(IDK)
+            ENDIF
+         ENDIF
+*        AVAILABLE CROSS SECTION TYPES.
+         CALL AEXGNV(12,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSECTT)
+         ALLOCATE(IZSECT(NSECTT))
+         NSETOT=0
+         NPHY=MAX(0,NSECTT-5)
+         DO 130 I=1,NSECTT
+         IZSECT(I)=ITSEGM(IDK+I-1)
+         IF((IZSECT(I).NE.0).AND.(I.LE.5)) NSETOT=NSETOT+1
+  130    CONTINUE
+*        FISSION ENERGIES.
+         CALL AEXGNV(20,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NMGEF)
+         IF(NMGEF.NE.0) THEN
+            IF(RTSEGM(IDK+NMGEF-1).NE.0.0) THEN
+               KPAX(NEL+2,ISO)=1
+               BPAX(NEL+2,ISO)=RTSEGM(IDK+NMGEF-1)
+            ENDIF
+         ENDIF
+*        RADIOACTIVE DECAY CONSTANTS.
+         CALL AEXGNV(22,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NCHANN)
+         SUM=0.0
+         DO 140 I=1,NCHANN
+         SUM=SUM+RTSEGM(IDK+I-1)
+  140    CONTINUE
+         IF(SUM.NE.0.0) BPAX(NEL+1,ISO)=SUM*1.0E8
+*        X-S NAMES.
+         CALL AEXGNV(26,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV/8.NE.NSECTT) CALL XABORT('LIBEAR: INVALID TYPSECT.')
+         ALLOCATE(ISECTT(2*NSECTT))
+         III=0
+         DO 150 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
+  150    CONTINUE
+      ENDIF
+      CALL LCMDRD(TSEGM_PTR)
+      CALL LCMDRD(ICHDIM_PTR)
+      CALL LCMDRD(ICHTYP_PTR)
+      CALL LCMDRD(ICHDKL_PTR)
+  160 CONTINUE
+      IF(.NOT.LPFIX) CALL XABORT('LIBEAR: NO PFIX SEGMENT.')
+*----
+*  TEST THE INFINITE DILUTION CROSS SECTIONS.
+*----
+      ITSEC=0
+      DO 210 IS=1,NS
+      LTESTS=ITCARO(IDKLS+IS)
+      IF(LTESTS.LE.0) GO TO 210
+      IDK=JDKTS+8*(IS-1)
+      CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+      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(LTESTS+1)
+      CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /))
+      CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /))
+      CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1)
+      IF(TYPSEG.EQ.'PSECT') THEN
+*        RECOVER A VECTOR CROSS SECTION.
+         ITSEC=ITSEC+1
+         IF(ITSEC.GT.NSETOT) GO TO 200
+         CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,
+     1   ICHDKL,IDK,NV)
+         I3=(ITSEC-1)*2+1
+         CALL LCMCAR(TEXT8,.FALSE.,ISECTT(I3))
+         IF(TEXT8.EQ.'SIGA') THEN
+            LTEST=.FALSE.
+            DO 170 IG=1,NV
+            LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0)
+  170       CONTINUE
+            IF(LTEST) KPAX(NEL+3,ISO)=1
+         ELSE IF(TEXT8.EQ.'NEXCESS') THEN
+            LTEST=.FALSE.
+            DO 180 IG=1,NV
+            LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0)
+  180       CONTINUE
+            IF(LTEST) KPAX(NEL+4,ISO)=1
+         ELSE IF(TEXT8.EQ.'SIGF') THEN
+            LTEST=.FALSE.
+            DO 190 IG=1,NV
+            LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0)
+  190       CONTINUE
+            IF(LTEST) KPAX(NEL+2,ISO)=1
+         ENDIF
+      ENDIF
+  200 CALL LCMDRD(TSEGM_PTR)
+      CALL LCMDRD(ICHDIM_PTR)
+      CALL LCMDRD(ICHTYP_PTR)
+      CALL LCMDRD(ICHDKL_PTR)
+  210 CONTINUE
+*----
+*  TEST THE PRODUCTION REACTIONS.
+*----
+      IF(NPHY.GE.1) THEN
+         IF(KISEG3.EQ.0) CALL XABORT('LIBEAR: INVALID PRODUCTION X-S ('
+     1   //'1).')
+         IDKOBJ=KDS(KISEG3)
+         LGSEG=LGS(KISEG3)
+         CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+         LDKDS=ITCARO(IDKDS)
+         LDKTS=ITCARO(IDKTS)
+         NS=ITCARO(IDKNS)
+         IF(NS.NE.NPHY) CALL XABORT('LIBEAR: INVALID PRODUCTION X-S(2)'
+     1   //'.')
+         DO 240 IPHY=1,NPHY
+         IDK=LDKTS+8*(IPHY-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         IF(TYPSEG.NE.'PSECT') CALL XABORT('LIBEAR: INVALID PRODUCTION'
+     1   //' X-S(3).')
+         LNGS=ITCARO(IDKLS+IPHY)
+         IF(LNGS.LE.0) CALL XABORT('LIBEAR: INVALID PRODUCTION X-S(4).')
+         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))
+         IF(TEXT8.EQ.'CREA-P') THEN
+            LTEST=.FALSE.
+            DO 220 IG=1,NV
+            LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0)
+  220       CONTINUE
+            IF(LTEST) KPAX(NEL+8,ISO)=1
+         ELSE IF(TEXT8.EQ.'CREA-H2') THEN
+            LTEST=.FALSE.
+            DO 225 IG=1,NV
+            LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0)
+  225       CONTINUE
+            IF(LTEST) KPAX(NEL+11,ISO)=1
+         ELSE IF(TEXT8.EQ.'CREA-H3') THEN
+            LTEST=.FALSE.
+            DO 230 IG=1,NV
+            LTEST=LTEST.OR.(RTSEGM(IDK+IG-1).NE.0.0)
+  230       CONTINUE
+            IF(LTEST) KPAX(NEL+12,ISO)=1
+         ENDIF
+         CALL LCMDRD(TSEGM_PTR)
+  240    CONTINUE
+      ENDIF
+      DEALLOCATE(ITCARO)
+*----
+*  SET OTHER INFORMATION.
+*----
+      ITZEA(ISO)=IZ(ISO)*10000+IA(ISO)*10
+      IPF=NFG(ISO)
+      IF(IPF.LT.0) THEN
+         KPAX(NEL+2,ISO)=-1
+         DO 250 JSO=1,NISOT
+         IFI=NFG(JSO)
+         IF(IFI.GT.0) THEN
+            IOFSET=((-IPF-1)*NBFISS+(IFI-1))*NMGY+NMGY
+            BPAX(ISO,JSO)=GAMMA(IOFSET)
+            IF(BPAX(ISO,JSO).NE.0.0) KPAX(ISO,JSO)=2
+         ENDIF
+  250    CONTINUE
+      ENDIF
+      DEALLOCATE(ISECTT,IZSECT)
+  260 CONTINUE
+*
+      DEALLOCATE(LGS,KDS,NOMOB,GAMMA,NFG,IZ,IA,NOM)
+      IERR=KDRCLS(IUNIT,1)
+      IF(IERR.LT.0) THEN
+         TEXT12=CFILNA
+         CALL XABORT('LIBEAR: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
+     1   'E CLOSED')
+      ENDIF
+*----
+*  RECOVER INFORMATION FROM INPUT DATA STREAM.
+*----
+      ALLOCATE(IKEEP(NEL))
+      IKEEP(:NEL)=0
+      TEXT12=' '
+      CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
+      IF(INDIC.NE.3.OR.TEXT12.NE.'CHAIN')
+     >  CALL XABORT('LIBEAR: KEYWORD CHAIN MISSING')
+      CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
+      DO 340 IEL=1,NEL
+      IF(TEXT12.EQ.'ENDCHAIN') GO TO 350
+      IF(INDIC.NE.3) CALL XABORT('LIBEAR: ISOTOPE NAME hnamson MISSING')
+      I1=INDEX(TEXT12,'_')
+      HNISOR=' '
+      IF(I1.EQ.0) THEN
+         HNISOR(:12)=TEXT12
+      ELSE
+         HNISOR(:I1-1)=TEXT12(:I1-1)
+      ENDIF
+      IDEPL=0
+      DO 270 JEL=1,NEL
+      WRITE(TEXT12,'(3A4)') (ITNAM(II,JEL),II=1,3)
+      I1=INDEX(TEXT12,'_')
+      HITNAM=' '
+      IF(I1.EQ.0) THEN
+         HITNAM(:12)=TEXT12
+       ELSE
+         HITNAM(:I1-1)=TEXT12(:I1-1)
+      ENDIF
+      IF(HNISOR.EQ.HITNAM) THEN
+         IDEPL=JEL
+         GO TO 280
+      ENDIF
+  270 CONTINUE
+      WRITE(HSMG,'(25HLIBEAR: MISSING ISOTOPE '',A12,5H''(1).)')
+     > HNISOR
+      CALL XABORT(HSMG)
+  280 IKEEP(IDEPL)=1
+      IF(BPAX(NEL+1,IDEPL).NE.0.0) KPAX(NEL+1,IDEPL)=1
+      CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
+      IF(INDIC.NE.3) CALL XABORT('LIBEAR: REACTION TYPE EXPECTED')
+      IF(TEXT12.EQ.'FROM') THEN
+         CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
+  290    IF(INDIC.NE.3) CALL XABORT('LIBEAR: REACTION TYPE EXPECTED')
+         DO 330 IREAC=1,MAXR
+         RRAT=1.0
+         IF(TEXT12.EQ.NMDEPL(IREAC)) THEN
+            DO 320 JEL=1,NEL
+            CALL REDGET(INDIC,ISOT,RRAT,TEXT12,DBLINP)
+            IF(INDIC.NE.2) GO TO 290
+            CALL REDGET(INDIC,ISOT,FLOTT,TEXT12,DBLINP)
+            IF(INDIC.NE.3) CALL XABORT('LIBEAR: ISOTOPE NAME HNAMPAR '
+     >      //'MISSING')
+            I1=INDEX(TEXT12,'_')
+            TEXT20=' '
+            IF(I1.EQ.0) THEN
+               TEXT20(:12)=TEXT12
+            ELSE
+               TEXT20(:I1-1)=TEXT12(:I1-1)
+            ENDIF
+            JDEPL=0
+            DO 300 JREL=1,NEL
+            WRITE(TEXT12,'(3A4)') (ITNAM(II,JREL),II=1,3)
+            I1=INDEX(TEXT12,'_')
+            HITNAM=' '
+            IF(I1.EQ.0) THEN
+               HITNAM(:12)=TEXT12
+            ELSE
+               HITNAM(:I1-1)=TEXT12(:I1-1)
+            ENDIF
+            IF(TEXT20.EQ.HITNAM) THEN
+               JDEPL=JREL
+               GO TO 310
+            ENDIF
+  300       CONTINUE
+            WRITE(HSMG,'(25HLIBEAR: MISSING ISOTOPE '',A12,5H''(2).)')
+     >      TEXT20
+            CALL XABORT(HSMG)
+  310       KPAX(IDEPL,JDEPL)=IREAC
+            BPAX(IDEPL,JDEPL)=RRAT
+  320       CONTINUE
+            CALL XABORT('LIBEAR: TO MANY PARENT ISOTOPES')
+         ENDIF
+  330    CONTINUE
+      ENDIF
+  340 CONTINUE
+      IF(INDIC.NE.3.OR.TEXT12.NE.'ENDCHAIN')
+     >  CALL XABORT('LIBEAR: KEYWORD ENDCHAIN MISSING')
+  350 DO 380 JEL=1,NEL
+      IF(IKEEP(JEL).EQ.0) THEN
+         DO 360 IREAC=1,NEL+MAXR
+         KPAX(IREAC,JEL)=0
+  360    CONTINUE
+         DO 370 IEL=1,NEL
+         KPAX(JEL,IEL)=0
+  370    CONTINUE
+      ENDIF
+  380 CONTINUE
+      DEALLOCATE(IKEEP)
+      RETURN
+*
+  500 FORMAT(26HLIBEAR: MATERIAL/ISOTOPE ',A20,20H' IS MISSING ON APOL,
+     > 15HIB-2 FILE NAME ,A12,1H.)
+      END