*DECK LIBDEN
      SUBROUTINE LIBDEN (IPLIB,NGROUP,NBISO,NBMIX,NL,NDEL,NESP,IPISO,
     1 MIX,DEN,MASK,MASKL,NED,NAMEAD,ITRANC,MAXNFI,LSAME,ITSTMP,TMPDAY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* transformation of the isotope ordered microscopic cross sections to
* group ordered macroscopic cross sections (part 2).
*
*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).
* NGROUP  number of energy groups.
* NBISO   number of isotopes present in the calculation domain.
* NBMIX   number of mixtures present in the calculation domain.
* NL      number of Legendre orders required in the calculation
*         (NL=1 or higher).
* NDEL    number of delayed precursor groups.
* NESP    number of energy-dependent fission spectra.
* IPISO   pointer array towards microlib isotopes.
* MIX     mixture number of each isotope (can be zero).
* DEN     density of each isotope.
* MASK    mixture mask (=.true. if a mixture is to be made).
* MASKL   group mask (=.true. if an energy group is to be treated).
* NED     number of extra edit vectors.
* NAMEAD  names of these extra edits.
* ITRANC  type of transport corrections in the microlib
*         (=0: no transport correction).
* MAXNFI  maximum number of fissionable isotopes in a mixture.
* LSAME   fission spectrum flag (=.true. if all the isotopes have the
*         same fission spectrum and the same precursor group decay
*         constants).
* ITSTMP  type of cross section perturbation (=0: perturbation
*         forbidden; =1: perturbation not used even if present;
*         =2: perturbation used if present).
* TMPDAY  time stamp in day/burnup/irradiation.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      PARAMETER (NBLK=50)
      TYPE(C_PTR) IPLIB,IPISO(NBISO)
      INTEGER NGROUP,NBISO,NBMIX,NL,NDEL,NESP,MIX(NBISO),NED,ITRANC,
     1 MAXNFI,ITSTMP,NAMEAD(2,NED)
      REAL DEN(NBISO),TMPDAY(3)
      LOGICAL MASK(NBMIX),MASKL(NGROUP),LSAME
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40,IOUT=6,MAXESP=4)
      CHARACTER CM*4,CV*12,HSMG*131,TEXT12*12,HCM(0:10)*2,NORD(3)*4,
     1 TEXT2*2
      LOGICAL EXIST,MASKK,LOGL,LALL,LWP1,LSTRD,LH,LOVERV,LDIFF,LFISS,
     1 LWT0,LWT1
      INTEGER IDATA(NSTATE),IESP(MAXESP+1)
      REAL TMPPER(2,3)
      DOUBLE PRECISION SQFMAS,XDRCST,NMASS,EVJ,ZNU
      TYPE(C_PTR) JPLIB,KPLIB
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS,IJJ,NJJ,IWRK
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NJJM,IJJM,INDFIS
      REAL, ALLOCATABLE, DIMENSION(:) :: GA1,GA2,SCAT,VOLMIX,NWTMIX
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GA3,GAR,WRK1,WRK2
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAF,CHECK,ZNUS,ZCHI,FLUX
      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPGRP
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LMADE
*----
*  DATA STATEMENTS
*----
      DATA HCM/'00','01','02','03','04','05','06','07','08','09','10'/
      DATA NORD/'    ',' LIN',' QUA'/
*----
*  SCRATCH STORAGE ALLOCATION
*   IPGRP   LCM pointers of the macrolib groupwise directories.
*----
      ALLOCATE(NJJM(NBMIX,NBLK),IJJM(NBMIX,NBLK),IPOS(NBMIX),
     1 INDFIS(NBMIX,MAXNFI),IJJ(NGROUP),NJJ(NGROUP))
      ALLOCATE(GA1(NGROUP+1),GA2(NGROUP*NGROUP),GA3(NDEL,MAXNFI),
     1 GAR(NBMIX,NBLK+1),GAF(NBMIX,NGROUP,NBLK),SCAT(NGROUP*NBMIX),
     2 CHECK(NBMIX,NGROUP,NL),ZNUS(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL),
     3 ZCHI(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL))
      ALLOCATE(IPGRP(NGROUP))
      ALLOCATE(LMADE(NBISO))
*----
*  FOR AVERAGED NEUTRON VELOCITY
*  V=SQRT(2*ENER/M)=SQRT(2/M)*SQRT(ENER)
*  SQFMAS=SQRT(2/M) IN CM/S/SQRT(EV) FOR V IN CM/S AND E IN EV
*        =SQRT(2*1.602189E-19(J/EV)* 1.0E4(CM2/M2) /1.67495E-27 (KG))
*        =1383155.30602 CM/S/SQRT(EV)
*----
      EVJ=XDRCST('eV','J')
      NMASS=XDRCST('Neutron mass','kg')
      SQFMAS=SQRT(2.0D4*EVJ/NMASS)
*----
*  SET MULTIPLE FISSION SPECTRA INFORMATION.
*----
      IF(NESP.GT.1) THEN
        IF(NESP.GT.MAXESP) CALL XABORT('LIBDEN: MAXESP OVERFLOW.')
        CALL LCMGET(IPLIB,'CHI-LIMITS',IESP)
      ENDIF
*----
*  SET CROSS SECTION PERTURBATION INFORMATION.
*----
      NXSPER=1
      TIMFCT=0.0
      CALL LCMLEN(IPLIB,'TIMESPER',LENGTH,ITYLCM)
      IF((LENGTH.GE.2).AND.(LENGTH.LE.6)) THEN
        IF(ITSTMP.EQ.0) THEN
          CALL XABORT('LIBDEN: XS PERTURBATION FORBIDDEN.')
        ELSE IF(ITSTMP.EQ.2) THEN
          CALL LCMGET(IPLIB,'TIMESPER',TMPPER)
          TIMFCT=TMPDAY(1)-TMPPER(1,1)
          XTF=TIMFCT/TMPPER(2,1)
          IF(XTF.NE.0.0) NXSPER=2
          IF(XTF.LT.0.0) THEN
            WRITE(IOUT,6000) TMPPER(1,1),TMPDAY(1)
          ELSE IF(XTF.GT.1.0) THEN
            WRITE(IOUT,6001) TMPPER(1,1)+TMPPER(2,1),TMPDAY(1)
          ENDIF
        ENDIF
      ENDIF
*----
*  MASKK=.TRUE. IF MIXTURE MASKING IS TO BE USED (IT IS NOT USED IF
*  ALL MIXTURES ARE TO BE UPDATED).
*----
      LDIFF=.TRUE.
      CALL LCMLEN(IPLIB,'MACROLIB',LENGTH,ITYLCM)
      MASKK=(LENGTH.EQ.-1)
      IF(MASKK) THEN
         CALL LCMSIX(IPLIB,'MACROLIB',1)
         CALL LCMGTC(IPLIB,'SIGNATURE',12,1,TEXT12)
         IF(TEXT12.NE.'L_MACROLIB') THEN
            CALL XABORT('LIBDEN: INVALID SIGNATURE ON THE MACROLIB.')
         ENDIF
         CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA)
         NBM0=IDATA(2)
         NFISSI=IDATA(4)/NESP
         LDIFF=(IDATA(9).EQ.1)
         IF(IDATA(1).NE.NGROUP) THEN
            WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS NGROUP=,I4,
     1      25H NEW MACROLIB HAS NGROUP=,I4,1H.)') IDATA(1),NGROUP
            CALL XABORT(HSMG)
         ELSE IF((IDATA(6).NE.2).AND.(ITRANC.GT.0)) THEN
            WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS ITRANC=,I4,
     1      25H NEW MACROLIB HAS ITRANC=,I4,1H.)') IDATA(6),ITRANC
            CALL XABORT(HSMG)
         ELSE IF(NBM0.GT.NBMIX) THEN
            WRITE(HSMG,'(36HLIBDEN: EXISTING MACROLIB HAS NBMIX=,I4,
     1      24H NEW MACROLIB HAS NBMIX=,I4,1H.)') NBM0,NBMIX
            CALL XABORT(HSMG)
         ELSE IF(NFISSI.GT.NBISO) THEN
            WRITE(HSMG,'(37HLIBDEN: EXISTING MACROLIB HAS NFISSI=,I4,
     1      13H GREATER THAN,I5,1H.)') IDATA(4),NBISO
            CALL XABORT(HSMG)
         ENDIF
         IF(NFISSI.GT.0) THEN
            CALL LCMLEN(IPLIB,'FISSIONINDEX',LENGTH,ITYLCM)
            IF(LENGTH.EQ.0) THEN
*              THE NAMES ARE NOT DEFINED.
               DO 10 IFIS=1,NFISSI
               DO 10 IBM=1,NBMIX
   10          INDFIS(IBM,IFIS)=0
            ELSE IF(LENGTH.EQ.NFISSI*NBMIX) THEN
               CALL LCMGET(IPLIB,'FISSIONINDEX',INDFIS)
               DO 15 IFIS=1,NFISSI
               DO 15 IBM=1,NBMIX
               IF(INDFIS(IBM,IFIS).GT.NBISO) THEN
                  CALL XABORT('LIBDEN: INVALID RECORD FISSIONINDEX.')
               ENDIF
   15          CONTINUE
            ELSE IF(LENGTH.LT.NFISSI*NBMIX) THEN
*              REORDER THE 'FISSIONINDEX' MATRIX.
               ALLOCATE(IWRK(LENGTH))
               CALL LCMGET(IPLIB,'FISSIONINDEX',IWRK)
               DO 30 IFIS=1,NFISSI
               DO 20 IBM=1,NBM0
   20          INDFIS(IBM,IFIS)=IWRK((IFIS-1)*NBM0+IBM)
               DO 30 IBM=NBM0+1,NBMIX
   30          INDFIS(IBM,IFIS)=0
               DEALLOCATE(IWRK)
            ELSE
               CALL XABORT('LIBDEN: INVALID NUMBER OF MIXTURES.')
            ENDIF
         ENDIF
         CALL LCMSIX(IPLIB,' ',2)
         LALL=NBMIX.GT.NBM0
      ELSE
         NFISSI=0
         LALL=.FALSE.
      ENDIF
      NGROUPS=0
      DO 40 LLL=1,NGROUP
      IF(MASKL(LLL).OR.LALL) NGROUPS=NGROUPS+1
   40 CONTINUE
      IF(NGROUPS.EQ.0) RETURN
*----
*  SET THE LCM MACROLIB GROUPWISE AND MICROLIB ISOTOPEWISE DIRECTORIES
*----
      CALL LCMSIX(IPLIB,'MACROLIB',1)
      JPLIB=LCMLID(IPLIB,'GROUP',NGROUP)
      DO 45 LLL=1,NGROUP
      IPGRP(LLL)=LCMDIL(JPLIB,LLL)
   45 CONTINUE
      CALL LCMSIX(IPLIB,' ',2)
*----
*  PROCESS THE SCATTERING TABLES.
*----
      DO 50 I=1,NGROUP
      DO 50 IBM=1,NBMIX
      DO 50 J=1,NL
   50 CHECK(IBM,I,J)=0.0
      DO 240 M=1,NL
      IF(M.LE.11) THEN
         CM=HCM(M-1)//'  '
      ELSE
         WRITE(CM,'(I2.2,2X)') M-1
      ENDIF
      DO 240 IPASS=0,(NGROUP-1)/NBLK
      LLL0=IPASS*NBLK
      DO 70 IBLK=1,NBLK
      DO 60 IBM=1,NBMIX
   60 GAR(IBM,IBLK)=0.0
      DO 70 LLL=1,NGROUP
      DO 70 IBM=1,NBMIX
   70 GAF(IBM,LLL,IBLK)=0.0
      DO 80 ISOT=1,NBISO
   80 LMADE(ISOT)=DEN(ISOT).EQ.0.0
      DO 140 ISOT=1,NBISO
      IF(LMADE(ISOT)) GO TO 140
*
*     RECOVER THE MICROSCOPIC TRANSFER XS WITHOUT USING XDRLGS (IN
*     ORDER TO REDUCE CPU TIME)
      IF(.NOT.C_ASSOCIATED(IPISO(ISOT))) THEN
         WRITE(HSMG,'(37HLIBDEN: EMPTY DIRECTORY FOR ISOTOPE '',A12,
     1   2H''.)') TEXT12
         CALL XABORT(HSMG)
      ENDIF
      JPLIB=IPISO(ISOT)
*-
      FACT=1.0
      DO 130 IXSPER=1,NXSPER
      CALL LCMLEN(JPLIB,'SIGS'//CM//NORD(IXSPER),LENGTH,ITYLCM)
      IF(LENGTH.EQ.0) GO TO 130
      CALL LCMGET(JPLIB,'SIGS'//CM//NORD(IXSPER),GA1)
      CALL LCMGET(JPLIB,'NJJS'//CM//NORD(IXSPER),NJJ)
      CALL LCMGET(JPLIB,'IJJS'//CM//NORD(IXSPER),IJJ)
      CALL LCMGET(JPLIB,'SCAT'//CM//NORD(IXSPER),GA2)
      IOF0=0
      DO 90 LLL=1,LLL0
   90 IOF0=IOF0+NJJ(LLL)
         DO 110 IBM=1,NBMIX
         IF((MASK(IBM).OR.(.NOT.MASKK)).AND.(MIX(ISOT).EQ.IBM)) THEN
            IOF=IOF0
            DO 100 IBLK=1,NBLK
            LLL=LLL0+IBLK
            IF(LLL.GT.NGROUP) GO TO 110
            GAR(IBM,IBLK)=GAR(IBM,IBLK)+GA1(LLL)*DEN(ISOT)
            DO 100 IG1=IJJ(LLL),IJJ(LLL)-NJJ(LLL)+1,-1
            IOF=IOF+1
  100       GAF(IBM,IG1,IBLK)=GAF(IBM,IG1,IBLK)+GA2(IOF)*DEN(ISOT)*FACT
         ENDIF
  110    CONTINUE
         LMADE(ISOT)=.TRUE.
  130 FACT=FACT*TIMFCT
*-
  140 CONTINUE
      DO 230 IBLK=1,NBLK
      LLL=LLL0+IBLK
      IF(LLL.GT.NGROUP) GO TO 230
      KPLIB=IPGRP(LLL)
      IF(MASKL(LLL).OR.LALL) THEN
         IF(MASKK) THEN
           LENGTH=1
           IF(M.GT.1) CALL LCMLEN(KPLIB,'SIGS'//CM,LENGTH,ITYLCM)
           CALL XDRSET(GAR(1,NBLK+1),NBMIX,0.0)
           IF(LENGTH.GT.0) THEN
              CALL LCMGET(KPLIB,'SIGS'//CM,GAR(1,NBLK+1))
           ENDIF
           DO 150 IBM=1,NBMIX
           IF(.NOT.MASK(IBM)) GAR(IBM,IBLK)=GAR(IBM,NBLK+1)
  150      CONTINUE
         ENDIF
         CALL LCMPUT(KPLIB,'SIGS'//CM,NBMIX,2,GAR(1,IBLK))
      ENDIF
*
      LOGL=MASKL(LLL).OR.LALL
      DO 160 IBM=1,NBMIX
      DO 160 IG1=1,NGROUP
      LOGL=LOGL.OR.(MASKL(IG1).AND.(GAF(IBM,IG1,IBLK).NE.0.0))
  160 CONTINUE
      IF(LOGL) THEN
         IF(MASKK) THEN
           LENGTH=1
           IF(M.GT.1) CALL LCMLEN(KPLIB,'SCAT'//CM,LENGTH,ITYLCM)
           IF(LENGTH.GT.0) THEN
             DO 170 I=1,NBMIX
  170        IPOS(I)=-99
             CALL LCMGET(KPLIB,'SCAT'//CM,SCAT)
             CALL LCMGET(KPLIB,'NJJS'//CM,NJJM(1,IBLK))
             CALL LCMGET(KPLIB,'IJJS'//CM,IJJM(1,IBLK))
             CALL LCMGET(KPLIB,'IPOS'//CM,IPOS)
             DO 190 IBM=1,NBMIX
             IF(.NOT.MASK(IBM)) THEN
                IPOSDE=IPOS(IBM)
                IF(IPOSDE.EQ.-99) GO TO 190
                DO 180 IG1=IJJM(IBM,IBLK),IJJM(IBM,IBLK)-NJJM(IBM,IBLK)
     1          +1,-1
                GAF(IBM,IG1,IBLK)=SCAT(IPOSDE)
  180           IPOSDE=IPOSDE+1
             ENDIF
  190        CONTINUE
           ENDIF
         ENDIF
*
         IPOSDE=0
         DO 220 IBM=1,NBMIX
         IPOS(IBM)=IPOSDE+1
         IGMIN=LLL
         IGMAX=LLL
         DO 200 IG1=NGROUP,1,-1
         IF(GAF(IBM,IG1,IBLK).NE.0.0) THEN
            IGMIN=MIN(IGMIN,IG1)
            IGMAX=MAX(IGMAX,IG1)
         ENDIF
  200    CONTINUE
         IJJM(IBM,IBLK)=IGMAX
         NJJM(IBM,IBLK)=IGMAX-IGMIN+1
         DO 210 IG1=IGMAX,IGMIN,-1
         IPOSDE=IPOSDE+1
         SCAT(IPOSDE)=GAF(IBM,IG1,IBLK)
  210    CHECK(IBM,IG1,M)=CHECK(IBM,IG1,M)+SCAT(IPOSDE)
  220    GAR(IBM,1)=SCAT(IPOS(IBM)+IJJM(IBM,IBLK)-LLL)
         CALL LCMPUT(KPLIB,'SCAT'//CM,IPOSDE,2,SCAT)
         CALL LCMPUT(KPLIB,'NJJS'//CM,NBMIX,1,NJJM(1,IBLK))
         CALL LCMPUT(KPLIB,'IJJS'//CM,NBMIX,1,IJJM(1,IBLK))
         CALL LCMPUT(KPLIB,'IPOS'//CM,NBMIX,1,IPOS)
         CALL LCMPUT(KPLIB,'SIGW'//CM,NBMIX,2,GAR(1,1))
      ENDIF
  230 CONTINUE
  240 CONTINUE
*----
*  PROCESS THE REACTION VECTORS TOTAL, TOTAL-P1, STRD, H-FACTOR, OVERV
*  AND TRANC.
*----
      LWP1=.FALSE.
      LSTRD=.FALSE.
      LH=.FALSE.
      LOVERV=.FALSE.
      DO 340 IBM=1,NBMIX
      IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
         DO 250 IP=1,12
         DO 250 LLL=1,NGROUP
  250    GAF(IBM,LLL,IP)=0.0
         TOTDEN=0.0
         DO 320 ISOT=1,NBISO
         IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 320
         TOTDEN=TOTDEN+DEN(ISOT)
         JPLIB=IPISO(ISOT)
*-
         DENISO=DEN(ISOT)
         DO 315 IXSPER=1,NXSPER
         CALL LCMGET(JPLIB,'NTOT0   '//NORD(IXSPER),GA1)
         DO 260 LLL=1,NGROUP
  260    GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
         CALL LCMLEN(JPLIB,'NTOT1   '//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            LWP1=.TRUE.
            CALL LCMGET(JPLIB,'NTOT1   '//NORD(IXSPER),GA1)
            DO 270 LLL=1,NGROUP
  270       GAF(IBM,LLL,3)=GAF(IBM,LLL,3)+GA1(LLL)*DENISO
         ENDIF
         IF(LDIFF) THEN
            CALL LCMLEN(JPLIB,'STRD    '//NORD(IXSPER),ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               LSTRD=.TRUE.
               CALL LCMGET(JPLIB,'STRD    '//NORD(IXSPER),GA1)
               DO 280 LLL=1,NGROUP
  280          GAF(IBM,LLL,5)=GAF(IBM,LLL,5)+GA1(LLL)*DENISO
            ENDIF
         ENDIF
         CALL LCMLEN(JPLIB,'H-FACTOR'//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            LH=.TRUE.
            CALL LCMGET(JPLIB,'H-FACTOR'//NORD(IXSPER),GA1)
            DO 290 LLL=1,NGROUP
  290       GAF(IBM,LLL,7)=GAF(IBM,LLL,7)+GA1(LLL)*DENISO
         ENDIF
         CALL LCMLEN(JPLIB,'OVERV   '//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            LOVERV=.TRUE.
            CALL LCMGET(JPLIB,'OVERV   '//NORD(IXSPER),GA1)
            DO 300 LLL=1,NGROUP
  300       GAF(IBM,LLL,9)=GAF(IBM,LLL,9)+GA1(LLL)*DENISO
         ENDIF
         IF(ITRANC.NE.0) THEN
            CALL LCMGET(JPLIB,'TRANC   '//NORD(IXSPER),GA1)
            DO 310 LLL=1,NGROUP
  310       GAF(IBM,LLL,11)=GAF(IBM,LLL,11)+GA1(LLL)*DENISO
         ENDIF
  315    DENISO=DENISO*TIMFCT
*-
  320    CONTINUE
         IF(LOVERV) THEN
            DO 330 LLL=1,NGROUP
            IF(GAF(IBM,LLL,9).NE.0.0) THEN
               GAF(IBM,LLL,9)=GAF(IBM,LLL,9)/TOTDEN
            ENDIF
  330       CONTINUE
         ENDIF
      ENDIF
  340 CONTINUE
      DO 420 LLL=1,NGROUP
      KPLIB=IPGRP(LLL)
      IF(MASKL(LLL).OR.LALL) THEN
         IF(MASKK) THEN
            CALL XDRSET(GAF(1,LLL,2),NBMIX,0.0)
            CALL LCMGET(KPLIB,'NTOT0',GAF(1,LLL,2))
            DO 350 IBM=1,NBMIX
            IF(.NOT.MASK(IBM)) GAF(IBM,LLL,1)=GAF(IBM,LLL,2)
  350       CONTINUE
         ENDIF
         CALL LCMPUT(KPLIB,'NTOT0',NBMIX,2,GAF(1,LLL,1))
         IF(LWP1) THEN
            IF(MASKK) THEN
               CALL XDRSET(GAF(1,LLL,4),NBMIX,0.0)
               CALL LCMGET(KPLIB,'NTOT1',GAF(1,LLL,4))
               DO 360 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) GAF(IBM,LLL,3)=GAF(IBM,LLL,4)
  360          CONTINUE
            ENDIF
            CALL LCMPUT(KPLIB,'NTOT1',NBMIX,2,GAF(1,LLL,3))
         ENDIF
         IF(LSTRD) THEN
            IF(MASKK) THEN
               CALL XDRSET(GAF(1,LLL,6),NBMIX,0.0)
               CALL LCMGET(KPLIB,'DIFF',GAF(1,LLL,6))
               DO 370 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) THEN
                  GAF(IBM,LLL,5)=1.0/(3.0*GAF(IBM,LLL,6))
               ENDIF
  370          CONTINUE
            ENDIF
            DO 380 IBM=1,NBMIX
            IF(GAF(IBM,LLL,5).NE.0.0) THEN
               GAF(IBM,LLL,5)=1.0/(3.0*GAF(IBM,LLL,5))
            ENDIF
  380       CONTINUE
            CALL LCMPUT(KPLIB,'DIFF',NBMIX,2,GAF(1,LLL,5))
         ENDIF
         IF(LH) THEN
            IF(MASKK) THEN
               CALL XDRSET(GAF(1,LLL,8),NBMIX,0.0)
               CALL LCMGET(KPLIB,'H-FACTOR',GAF(1,LLL,8))
               DO 390 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) GAF(IBM,LLL,7)=GAF(IBM,LLL,8)
  390          CONTINUE
            ENDIF
            CALL LCMPUT(KPLIB,'H-FACTOR',NBMIX,2,GAF(1,LLL,7))
         ENDIF
         IF(LOVERV) THEN
            IF(MASKK) THEN
               CALL XDRSET(GAF(1,LLL,10),NBMIX,0.0)
               CALL LCMGET(KPLIB,'OVERV',GAF(1,LLL,10))
               DO 400 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) GAF(IBM,LLL,9)=GAF(IBM,LLL,10)
  400          CONTINUE
            ENDIF
            CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAF(1,LLL,9))
         ENDIF
         IF(ITRANC.NE.0) THEN
            IF(MASKK) THEN
               CALL XDRSET(GAF(1,LLL,12),NBMIX,0.0)
               CALL LCMGET(KPLIB,'TRANC',GAF(1,LLL,12))
               DO 410 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) GAF(IBM,LLL,11)=GAF(IBM,LLL,12)
  410          CONTINUE
            ENDIF
            CALL LCMPUT(KPLIB,'TRANC',NBMIX,2,GAF(1,LLL,11))
         ENDIF
      ENDIF
  420 CONTINUE
*----
*  PROCESS THE FISSION VECTORS FOR EACH NEW FISSILE ISOTOPE.
*----
      NFISS0=NFISSI
      DO 460 ISOT=1,NBISO
      IBM=MIX(ISOT)
      IF(IBM.EQ.0) GO TO 460
      IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
         JPLIB=IPISO(ISOT)
         CALL LCMLEN(JPLIB,'NUSIGF',LENGTH,ITYLCM)
         IF(NESP.EQ.1) THEN
            CALL LCMLEN(JPLIB,'CHI',LENGTZ,ITYLCM)
         ELSE
            CALL LCMLEN(JPLIB,'CHI--01',LENGTZ,ITYLCM)
         ENDIF
         IF((LENGTH.GT.0).AND.(LENGTZ.GT.0)) THEN
            IF(NESP.EQ.1) THEN
               CALL LCMGET(JPLIB,'CHI',GA1)
            ELSE
               CALL LCMGET(JPLIB,'CHI--01',GA1)
            ENDIF
            LFISS=.FALSE.
            DO 425 IGR=1,NGROUP
            LFISS=LFISS.OR.(GA1(IGR).GT.0.0)
  425       CONTINUE
            IF(.NOT.LFISS) GO TO 455
            DO 430 IFIS=1,NFISSI
            IWFIS=INDFIS(IBM,IFIS)
            IF((IWFIS.EQ.ISOT).OR.(IWFIS.EQ.0)) THEN
               KFIS=IFIS
               GO TO 450
            ENDIF
  430       CONTINUE
            NFISSI=NFISSI+1
            IF(NFISSI.GT.MAXNFI) CALL XABORT('LIBDEN: INDFIS IS FULL.')
            KFIS=NFISSI
            DO 440 JBM=1,NBMIX
  440       INDFIS(JBM,KFIS)=0
  450       INDFIS(IBM,KFIS)=ISOT
         ENDIF
  455    CONTINUE
      ENDIF
  460 CONTINUE
      IF(NFISS0.GT.0) THEN
         ALLOCATE(WRK1(NBM0,NFISS0*NESP),WRK2(NBM0,NFISS0*NESP))
         DO 480 LLL=1,NGROUP
         IF(MASKL(LLL).OR.LALL) THEN
            DO 465 IDEL=0,NDEL
            CALL XDRSET(ZNUS(1,LLL,IDEL),NBMIX*NFISS0*NESP,0.0)
            CALL XDRSET(ZCHI(1,LLL,IDEL),NBMIX*NFISS0*NESP,0.0)
  465       CONTINUE
            KPLIB=IPGRP(LLL)
            CALL LCMLEN(KPLIB,'NUSIGF',LENGTH,ITYLCM)
            IF(LENGTH.NE.NBM0*NFISS0*NESP) THEN
               CALL XABORT('LIBDEN: NBM ERROR.')
            ENDIF
            CALL LCMGET(KPLIB,'NUSIGF',WRK1)
            CALL LCMGET(KPLIB,'CHI',WRK2)
            DO 466 IFIS=1,NFISS0*NESP
            DO 466 IBM=1,NBM0
            ZNUS((IFIS-1)*NBMIX+IBM,LLL,0)=WRK1(IBM,IFIS)
  466       ZCHI((IFIS-1)*NBMIX+IBM,LLL,0)=WRK2(IBM,IFIS)
            DO 475 IDEL=1,NDEL
            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
            CALL LCMLEN(KPLIB,TEXT12,LENGTH,ITYLCM)
            IF(LENGTH.NE.0) THEN
               CALL LCMGET(KPLIB,TEXT12,WRK1)
               WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
               CALL LCMGET(KPLIB,TEXT12,WRK2)
               DO 470 IFIS=1,NFISS0*NESP
               DO 470 IBM=1,NBM0
               ZNUS((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK1(IBM,IFIS)
  470          ZCHI((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK2(IBM,IFIS)
            ENDIF
  475       CONTINUE
         ENDIF
  480    CONTINUE
         DEALLOCATE(WRK2,WRK1)
      ENDIF
      IF(NFISSI.GT.0) THEN
         DO 520 ISP=1,NESP
         DO 520 KFIS=1,NFISSI
         IF(KFIS.GT.NFISS0*NESP) THEN
            DO 490 IDEL=0,NDEL
            DO 490 LLL=1,NGROUP
            DO 490 IBM=1,NBMIX
            IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
            ZNUS(IOF,LLL,IDEL)=0.0
  490       ZCHI(IOF,LLL,IDEL)=0.0
         ELSE
            DO 510 IBM=1,NBMIX
            IWFIS=INDFIS(IBM,KFIS)
            IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
               DO 500 IDEL=0,NDEL
               DO 500 LLL=1,NGROUP
               IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
               ZNUS(IOF,LLL,IDEL)=0.0
  500          ZCHI(IOF,LLL,IDEL)=0.0
            ENDIF
  510       CONTINUE
         ENDIF
  520    CONTINUE
*-
         IF(NESP.EQ.1) THEN
*          ONE FISSION SPECTRUM (CLASSICAL CASE)
           DO 580 KFIS=1,NFISSI
           DO 580 IBM=1,NBMIX
           IWFIS=INDFIS(IBM,KFIS)
           IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
              IF(LSAME) THEN
                 IOF=IBM
              ELSE
                 IOF=(KFIS-1)*NBMIX+IBM
              ENDIF
              JPLIB=IPISO(IWFIS)
*-
              DENISO=DEN(IWFIS)
              DO 570 IXSPER=1,NXSPER
              CALL LCMGET(JPLIB,'NUSIGF  '//NORD(IXSPER),GA1)
              DO 530 LLL=1,NGROUP
  530         ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO
              IF(NDEL.GT.0) THEN
                 WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,LENGTH,ITYLCM)
                 IF(LENGTH.GT.0) THEN
                    DO 540 IDEL=1,NDEL
                    WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 540 LLL=1,NGROUP
  540               ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)*
     1              DENISO
                 ENDIF
                 WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,LENGTH,ITYLCM)
                 IF((LENGTH.GT.0).AND.(IXSPER.EQ.1)) THEN
                    DO 550 IDEL=1,NDEL
                    WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 550 LLL=1,NGROUP
  550               ZCHI(IOF,LLL,IDEL)=GA1(LLL)
                 ENDIF
              ENDIF
              IF(IXSPER.EQ.1) THEN
                 CALL LCMGET(JPLIB,'CHI     '//NORD(IXSPER),GA1)
                 DO 560 LLL=1,NGROUP
  560            ZCHI(IOF,LLL,0)=GA1(LLL)
              ENDIF
  570         DENISO=DENISO*TIMFCT
           ENDIF
  580      CONTINUE
         ELSE
*          NESP>1 MULTIPLE FISSION SPECTRA CASE
           DO 660 ISP=1,NESP
           DO 660 KFIS=1,NFISSI
           DO 660 IBM=1,NBMIX
           IWFIS=INDFIS(IBM,KFIS)
           IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
              IF(LSAME) THEN
                 IOF=IBM
              ELSE
                 IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
              ENDIF
              JPLIB=IPISO(IWFIS)
*-
              DENISO=DEN(IWFIS)
              DO 650 IXSPER=1,NXSPER
              CALL LCMGET(JPLIB,'NUSIGF  '//NORD(IXSPER),GA1)
              DO 610 LLL=IESP(ISP)+1,IESP(ISP+1)
  610         ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO
              IF((NDEL.GT.0).AND.(ISP.EQ.1)) THEN
                 WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,LENGTH,ITYLCM)
                 IF(LENGTH.GT.0) THEN
                    DO 620 IDEL=1,NDEL
                    WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 620 LLL=1,NGROUP
  620               ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)*
     1              DENISO
                 ENDIF
                 WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,LENGTH,ITYLCM)
                 IF((LENGTH.GT.0).AND.(IXSPER.EQ.1)) THEN
                    DO 630 IDEL=1,NDEL
                    WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 630 LLL=1,NGROUP
  630               ZCHI(IOF,LLL,IDEL)=GA1(LLL)
                 ENDIF
              ENDIF
              IF(IXSPER.EQ.1) THEN
                 WRITE(TEXT2,'(I2.2)') ISP
                 TEXT12='CHI--'//TEXT2//' '//NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
                 IF(ILONG.EQ.NGROUP) THEN
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 640 LLL=1,NGROUP
  640               ZCHI(IOF,LLL,0)=GA1(LLL)
                 ENDIF
              ENDIF
  650         DENISO=DENISO*TIMFCT
           ENDIF
  660      CONTINUE
         ENDIF 
*-
         DO 680 LLL=1,NGROUP
         IF(MASKL(LLL).OR.LALL) THEN
            KPLIB=IPGRP(LLL)
            ILONG=NBMIX*NFISSI*NESP
            IF(LSAME) ILONG=NBMIX
            CALL LCMPUT(KPLIB,'NUSIGF',ILONG,2,ZNUS(1,LLL,0))
            CALL LCMPUT(KPLIB,'CHI',ILONG,2,ZCHI(1,LLL,0))
            DO 670 IDEL=1,NDEL
            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
            CALL LCMPUT(KPLIB,TEXT12,ILONG,2,ZNUS(1,LLL,IDEL))
            WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
            CALL LCMPUT(KPLIB,TEXT12,ILONG,2,ZCHI(1,LLL,IDEL))
  670       CONTINUE
         ENDIF
  680    CONTINUE
      ENDIF
*----
*  PROCESS THE EXTRA VECTOR EDITS.
*----
      DO 770 IED=1,NED
      WRITE(CV,'(2A4)') (NAMEAD(I0,IED),I0=1,2)
      IF(CV(:2).EQ.'NW') GO TO 770
      IF(CV.EQ.'TRANC') GO TO 770
      EXIST=.FALSE.
      DO 740 IBM=1,NBMIX
      IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
         DO 690 LLL=1,NGROUP
  690    GAF(IBM,LLL,1)=0.0
         DO 730 ISOT=1,NBISO
         IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 730
         JPLIB=IPISO(ISOT)
*-
         DENISO=DEN(ISOT)
         DO 710 IXSPER=1,NXSPER
         CALL LCMLEN(JPLIB,CV(:8)//NORD(IXSPER),LENGTH,ITYLCM)
         IF(LENGTH.EQ.0) GO TO 720
         EXIST=.TRUE.
         CALL LCMGET(JPLIB,CV(:8)//NORD(IXSPER),GA1)
         DO 700 LLL=1,NGROUP
  700    GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
  710    DENISO=DENISO*TIMFCT
*-
  720    CONTINUE
  730    CONTINUE
      ENDIF
  740 CONTINUE
      DO 760 LLL=1,NGROUP
      IF(MASKL(LLL).OR.LALL) THEN
         KPLIB=IPGRP(LLL)
         IF(MASKK) THEN
            CALL LCMLEN(KPLIB,CV,LENGTH,ITYLCM)
            IF(LENGTH.GT.0) THEN
               EXIST=.TRUE.
               CALL XDRSET(GAF(1,LLL,2),NBMIX,0.0)
               CALL LCMGET(KPLIB,CV,GAF(1,LLL,2))
               DO 750 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) GAF(IBM,LLL,1)=GAF(IBM,LLL,2)
  750          CONTINUE
            ENDIF
         ENDIF
         IF(EXIST) CALL LCMPUT(KPLIB,CV,NBMIX,2,GAF(1,LLL,1))
      ENDIF
  760 CONTINUE
  770 CONTINUE
*
      CALL LCMGET(IPLIB,'ENERGY',GA1)
      IF(GA1(NGROUP+1).EQ.0.0) GA1(NGROUP+1)=1.0E-5
      CALL LCMSIX(IPLIB,'MACROLIB',1)
      IF(NED.GT.0) CALL LCMPUT(IPLIB,'ADDXSNAME-P0',2*NED,3,NAMEAD)
      IF(MASKK) THEN
        CALL LCMGET(IPLIB,'STATE-VECTOR',IDATA)
        IDATA(2)=MAX(NBM0,NBMIX)
        IDATA(3)=MAX(IDATA(3),NL)
        IDATA(4)=NFISSI*NESP
        IDATA(5)=MAX(IDATA(5),NED)
      ELSE
        IDATA(1)=NGROUP
        IDATA(2)=NBMIX
        IDATA(3)=NL
        IDATA(4)=NFISSI*NESP
        IDATA(5)=NED
        TEXT12='L_MACROLIB'
        CALL LCMPTC(IPLIB,'SIGNATURE',12,1,TEXT12)
        CALL LCMPUT(IPLIB,'ENERGY',NGROUP+1,2,GA1)
      ENDIF
*----
*  COMPUTE 1/V (ENER IS IN EV, NEUTRON MASS IS IN KG)
*----
      IF(.NOT.LOVERV) THEN
         DO 800 LLL=1,NGROUP
         ENEAVG=SQRT(GA1(LLL)*GA1(LLL+1))
         ZNU=1.0/(SQRT(ENEAVG)*SQFMAS)
         DO 790 IBM=1,NBMIX
  790    GAR(IBM,1)=REAL(ZNU)
         KPLIB=IPGRP(LLL)
         CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAR(1,1))
  800    CONTINUE
      ENDIF
*----
*  SET THE STATE VECTOR
*----
      IF(LSAME) IDATA(4)=MIN(NFISSI*NESP,1)
      IDATA(6)=ITRANC
      IF(ITRANC.NE.0) IDATA(6)=2
      IDATA(7)=NDEL
      IDATA(8)=0
      IDATA(9)=0
      IF(LSTRD) IDATA(9)=1
      IDATA(10)=0
      IF(LWP1) IDATA(10)=1
      DO 810 I=11,NSTATE
  810 IDATA(I)=0
      CALL LCMLEN(IPLIB,'SPH',LENGTH,ITYLCM)
      IF(LENGTH.NE.0) IDATA(14)=1
      CALL LCMPUT(IPLIB,'TIMESTAMP',3,2,TMPDAY)
      CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,IDATA)
*----
*  RECOVER THE PRECURSOR DECAY CONSTANTS.
*----
      IF(NDEL*NFISSI.GT.0) THEN
         IF(NFISS0.GT.0) THEN
            CALL LCMLEN(IPLIB,'LAMBDA-D',LENGTH,ITYLCM)
            IF(LENGTH.EQ.0) THEN
               CALL XDRSET(GA3(1,1),NDEL,0.0)
            ELSE
               CALL LCMGET(IPLIB,'LAMBDA-D',GA3(1,1))
            ENDIF
         ENDIF
         DO 820 KFIS=NFISS0+1,NFISSI
         DO 820 IDEL=1,NDEL
  820    GA3(IDEL,KFIS)=0.0
         CALL LCMSIX(IPLIB,' ',2)
         DO 830 KFIS=1,NFISSI
         DO 830 IBM=1,NBMIX
         IWFIS=INDFIS(IBM,KFIS)
         IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
            JPLIB=IPISO(IWFIS)
            CALL LCMLEN(JPLIB,'LAMBDA-D',LENGTH,ITYLCM)
            IF(LSAME.AND.(LENGTH.GT.0)) THEN
               CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,1))
            ELSE IF(LENGTH.GT.0) THEN
               CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,KFIS))
            ENDIF
         ENDIF
  830    CONTINUE
         CALL LCMSIX(IPLIB,'MACROLIB',1)
         IF(LSAME) THEN
            CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL,2,GA3(1,1))
         ELSE
            CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL*NFISSI,2,GA3)
         ENDIF
      ENDIF
*
      IF((NFISSI.GT.0).AND.(.NOT.LSAME)) THEN
        CALL LCMPUT(IPLIB,'FISSIONINDEX',NBMIX*NFISSI,1,INDFIS)
      ENDIF
*
      DO 850 LLL=1,NGROUP
      IF(MASKL(LLL).OR.LALL) THEN
         KPLIB=IPGRP(LLL)
         DO 840 M=0,NL-1
         IF(M.LE.10) THEN
            CM=HCM(M)//'  '
         ELSE
            WRITE(CM,'(I2.2,2X)') M
         ENDIF
         CALL LCMPUT(KPLIB,'CHECK'//CM,NBMIX,2,CHECK(1,LLL,M+1))
  840    CONTINUE
      ENDIF
  850 CONTINUE
      CALL LCMSIX(IPLIB,' ',2)
*----
*  RECOVER THE INTEGRATED FLUX
*----
      CALL LCMLEN(IPLIB,'MIXTURESVOL',LENGTH,ITYLCM)
      IF(LENGTH.GT.0) THEN
        ALLOCATE(VOLMIX(NBMIX),NWTMIX(NGROUP),FLUX(NBMIX,NGROUP,2))
        CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMIX)
        LWT0=.FALSE.
        LWT1=.FALSE.
        CALL XDRSET(FLUX,NBMIX*NGROUP*2,0.0)
        DO 860 ISOT=1,NBISO
        IBM=MIX(ISOT)
        IF(IBM.GT.0) THEN
          JPLIB=IPISO(ISOT)
          IF(C_ASSOCIATED(JPLIB)) THEN
            CALL LCMLEN(JPLIB,'NWT0',LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
              LWT0=.TRUE.
              CALL LCMGET(JPLIB,'NWT0',NWTMIX)
              DO IGR=1,NGROUP
                FLUX(IBM,IGR,1)=NWTMIX(IGR)*VOLMIX(IBM)
              ENDDO
            ENDIF
            CALL LCMLEN(JPLIB,'NWT1',LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
              LWT1=.TRUE.
              CALL LCMGET(JPLIB,'NWT1',NWTMIX)
              DO IGR=1,NGROUP
                FLUX(IBM,IGR,2)=NWTMIX(IGR)*VOLMIX(IBM)
              ENDDO
            ENDIF
          ENDIF
        ENDIF
  860   CONTINUE
        CALL LCMSIX(IPLIB,'MACROLIB',1)
        CALL LCMPUT(IPLIB,'VOLUME',NBMIX,2,VOLMIX)
        JPLIB=LCMGID(IPLIB,'GROUP')
        DO 870 IGR=1,NGROUP
        KPLIB=LCMGIL(JPLIB,IGR)
        IF(LWT0) CALL LCMPUT(KPLIB,'FLUX-INTG',NBMIX,2,FLUX(1,IGR,1))
        IF(LWT1) CALL LCMPUT(KPLIB,'FLUX-INTG-P1',NBMIX,2,FLUX(1,IGR,2))
  870   CONTINUE
        CALL LCMSIX(IPLIB,' ',2)
        DEALLOCATE(FLUX,NWTMIX,VOLMIX)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(LMADE)
      DEALLOCATE(IPGRP)
      DEALLOCATE(ZCHI,ZNUS,CHECK,SCAT,GAF,GAR,GA3,GA2,GA1)
      DEALLOCATE(NJJ,IJJ,INDFIS,IPOS,IJJM,NJJM)
      RETURN
*----
*  FORMAT
*----
 6000 FORMAT(' WARNING IN LIBDEN FOR PERTURBATION'/
     >       ' EXTRAPOLATION BELOW PRETURBATION TABLES'/
     >       ' INITIAL TIME       = ',F15.6,' DAYS'/
     >       ' EXTRAPOLATION TIME = ',F15.6,' DAYS')
 6001 FORMAT(' WARNING IN LIBDEN FOR PERTURBATION'/
     >       ' EXTRAPOLATION ABOVE PRETURBATION TABLES'/
     >       ' FINAL TIME         = ',F15.6,' DAYS'/
     >       ' EXTRAPOLATION TIME = ',F15.6,' DAYS')
      END
