*DECK LIBDEN
      SUBROUTINE LIBDEN (IPLIB,NGROUP,NBISO,NBMIX,NL,NDEL,ISONAM,MIX,
     1 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.
* ISONAM  alias name of 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
      INTEGER NGROUP,NBISO,NBMIX,NL,NDEL,ISONAM(3,NBISO),MIX(NBISO),
     1 NED,ITRANC,MAXNFI,ITSTMP,NAMEAD(2,NED)
      REAL DEN(NBISO),TMPDAY(3)
      LOGICAL MASK(NBMIX),MASKL(NGROUP),LSAME
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40,IOUT=6)
      CHARACTER CM*4,CV*12,HSMG*131,TEXT12*12,HMACRO*8,HCM(0:10)*2,
     1 NORD(3)*4
      LOGICAL EXIST,MASKK,LOGL,LALL,LWP1,LSTRD,LH,LOVERV,LDIFF,LFISS
      INTEGER IDATA(NSTATE),KCHAR(3)
      REAL TMPPER(2,3)
      DOUBLE PRECISION SQFMAS,XDRCST,NMASS,EVJ,ZNU
      TYPE(C_PTR) JPLIB,KPLIB
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS,IJJ,NJJ,IWRK
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NJJM,IJJM,INDFIS
      REAL, ALLOCATABLE, DIMENSION(:) :: GA1,GA2,SCAT
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GA3,GAR,WRK1,WRK2
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAF,CHECK,ZNUS,ZCHI
      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPGRP
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LMADE
      DATA HMACRO/'MACROLIB'/
      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,NGROUP,0:NDEL),
     3 ZCHI(NBMIX*MAXNFI,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 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,HMACRO,LENGTH,ITYLCM)
      MASKK=(LENGTH.EQ.-1)
      IF(MASKK) THEN
         CALL LCMSIX(IPLIB,HMACRO,1)
         CALL LCMGET(IPLIB,'SIGNATURE',KCHAR)
         WRITE(TEXT12,'(3A4)') (KCHAR(I),I=1,3)
         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)
         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
      NGRPS=0
      DO 40 LLL=1,NGROUP
      IF(MASKL(LLL).OR.LALL) NGRPS=NGRPS+1
   40 CONTINUE
      IF(NGRPS.EQ.0) RETURN
*----
*  SET THE LCM MACROLIB GROUPWISE DIRECTORIES
*----
      CALL LCMSIX(IPLIB,HMACRO,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)
      WRITE(TEXT12,'(3A4)') (ISONAM(I0,ISOT),I0=1,3)
      CALL LCMLEN(IPLIB,TEXT12,LENGTH,ITYLCM)
      IF(LENGTH.EQ.0) THEN
         WRITE(HSMG,'(37HLIBDEN: EMPTY DIRECTORY FOR ISOTOPE '',A12,
     1   2H''.)') TEXT12
         CALL XABORT(HSMG)
      ENDIF
      CALL LCMSIX(IPLIB,TEXT12,1)
*-
      FACT=1.0
      DO 130 IXSPER=1,NXSPER
      CALL LCMLEN(IPLIB,'SIGS'//CM//NORD(IXSPER),LENGTH,ITYLCM)
      IF(LENGTH.EQ.0) GO TO 130
      CALL LCMGET(IPLIB,'SIGS'//CM//NORD(IXSPER),GA1)
      CALL LCMGET(IPLIB,'NJJS'//CM//NORD(IXSPER),NJJ)
      CALL LCMGET(IPLIB,'IJJS'//CM//NORD(IXSPER),IJJ)
      CALL LCMGET(IPLIB,'SCAT'//CM//NORD(IXSPER),GA2)
      IOF0=0
      DO 90 LLL=1,LLL0
   90 IOF0=IOF0+NJJ(LLL)
      DO 120 JSOT=ISOT,NBISO
      IF((ISONAM(1,JSOT).EQ.ISONAM(1,ISOT)).AND.
     1   (ISONAM(2,JSOT).EQ.ISONAM(2,ISOT)).AND.
     2   (ISONAM(3,JSOT).EQ.ISONAM(3,ISOT))) THEN
         DO 110 IBM=1,NBMIX
         IF((MASK(IBM).OR.(.NOT.MASKK)).AND.(MIX(JSOT).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(JSOT)
            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(JSOT)*FACT
         ENDIF
  110    CONTINUE
         LMADE(JSOT)=.TRUE.
      ENDIF
  120 CONTINUE
  130 FACT=FACT*TIMFCT
*-
      CALL LCMSIX(IPLIB,' ',2)
  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)
         WRITE(TEXT12,'(3A4)') (ISONAM(I0,ISOT),I0=1,3)
         CALL LCMSIX(IPLIB,TEXT12,1)
*-
         DENISO=DEN(ISOT)
         DO 315 IXSPER=1,NXSPER
         CALL LCMGET(IPLIB,'NTOT0   '//NORD(IXSPER),GA1)
         DO 260 LLL=1,NGROUP
  260    GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
         CALL LCMLEN(IPLIB,'NTOT1   '//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            LWP1=.TRUE.
            CALL LCMGET(IPLIB,'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(IPLIB,'STRD    '//NORD(IXSPER),ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               LSTRD=.TRUE.
               CALL LCMGET(IPLIB,'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(IPLIB,'H-FACTOR'//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            LH=.TRUE.
            CALL LCMGET(IPLIB,'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(IPLIB,'OVERV   '//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            LOVERV=.TRUE.
            CALL LCMGET(IPLIB,'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(IPLIB,'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
*-
         CALL LCMSIX(IPLIB,' ',2)
  320    CONTINUE
         IF(LOVERV.AND.(GAF(IBM,LLL,9).NE.0.0)) THEN
            DO 330 LLL=1,NGROUP
  330       GAF(IBM,LLL,9)=GAF(IBM,LLL,9)/TOTDEN
         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
         WRITE(TEXT12,'(3A4)') (ISONAM(I0,ISOT),I0=1,3)
         CALL LCMSIX(IPLIB,TEXT12,1)
         CALL LCMLEN(IPLIB,'NUSIGF',LENGTH,ITYLCM)
         CALL LCMLEN(IPLIB,'CHI',LENGTZ,ITYLCM)
         IF((LENGTH.GT.0).AND.(LENGTZ.GT.0)) THEN
            CALL LCMGET(IPLIB,'CHI',GA1)
            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    CALL LCMSIX(IPLIB,' ',2)
      ENDIF
  460 CONTINUE
      IF(NFISS0.GT.0) THEN
         ALLOCATE(WRK1(NBM0,NFISS0),WRK2(NBM0,NFISS0))
         DO 480 LLL=1,NGROUP
         IF(MASKL(LLL).OR.LALL) THEN
            DO 465 IDEL=0,NDEL
            CALL XDRSET(ZNUS(1,LLL,IDEL),NBMIX*NFISS0,0.0)
            CALL XDRSET(ZCHI(1,LLL,IDEL),NBMIX*NFISS0,0.0)
  465       CONTINUE
            KPLIB=IPGRP(LLL)
            CALL LCMLEN(KPLIB,'NUSIGF',LENGTH,ITYLCM)
            IF(LENGTH.NE.NBM0*NFISS0) CALL XABORT('LIBDEN: NBM ERROR.')
            CALL LCMGET(KPLIB,'NUSIGF',WRK1)
            CALL LCMGET(KPLIB,'CHI',WRK2)
            DO 466 IFIS=1,NFISS0
            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
               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 KFIS=1,NFISSI
         IF(KFIS.GT.NFISS0) THEN
            DO 490 IDEL=0,NDEL
            DO 490 LLL=1,NGROUP
            DO 490 IBM=1,NBMIX
            ZNUS((KFIS-1)*NBMIX+IBM,LLL,IDEL)=0.0
  490       ZCHI((KFIS-1)*NBMIX+IBM,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
               ZNUS((KFIS-1)*NBMIX+IBM,LLL,IDEL)=0.0
  500          ZCHI((KFIS-1)*NBMIX+IBM,LLL,IDEL)=0.0
            ENDIF
  510       CONTINUE
         ENDIF
  520    CONTINUE
         DO 570 KFIS=1,NFISSI
         DO 570 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
            WRITE(TEXT12,'(3A4)') (ISONAM(I0,IWFIS),I0=1,3)
            CALL LCMSIX(IPLIB,TEXT12,1)
*-
            DENISO=DEN(IWFIS)
            DO 565 IXSPER=1,NXSPER
            CALL LCMGET(IPLIB,'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(IPLIB,TEXT12,LENGTH,ITYLCM)
               IF(LENGTH.GT.0) THEN
                  DO 540 IDEL=1,NDEL
                  WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER)
                  CALL LCMGET(IPLIB,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(IPLIB,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(IPLIB,TEXT12,GA1)
                  DO 550 LLL=1,NGROUP
  550             ZCHI(IOF,LLL,IDEL)=GA1(LLL)
               ENDIF
            ENDIF
            IF(IXSPER.EQ.1) THEN
               CALL LCMGET(IPLIB,'CHI     '//NORD(IXSPER),GA1)
               DO 560 LLL=1,NGROUP
  560          ZCHI(IOF,LLL,0)=GA1(LLL)
            ENDIF
  565       DENISO=DENISO*TIMFCT
*-
            CALL LCMSIX(IPLIB,' ',2)
         ENDIF
  570    CONTINUE
         DO 590 LLL=1,NGROUP
         IF(MASKL(LLL).OR.LALL) THEN
            KPLIB=IPGRP(LLL)
            ILONG=NBMIX*NFISSI
            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 580 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))
  580       CONTINUE
         ENDIF
  590    CONTINUE
      ENDIF
*----
*  PROCESS THE EXTRA VECTOR EDITS.
*----
      DO 670 IED=1,NED
      WRITE(CV,'(2A4)') (NAMEAD(I0,IED),I0=1,2)
      IF(CV(:2).EQ.'NW') GO TO 670
      IF(CV.EQ.'TRANC') GO TO 670
      EXIST=.FALSE.
      DO 640 IBM=1,NBMIX
      IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
         DO 600 LLL=1,NGROUP
  600    GAF(IBM,LLL,1)=0.0
         DO 630 ISOT=1,NBISO
         IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 630
         WRITE(TEXT12,'(3A4)') (ISONAM(I0,ISOT),I0=1,3)
         CALL LCMSIX(IPLIB,TEXT12,1)
*-
         DENISO=DEN(ISOT)
         DO 615 IXSPER=1,NXSPER
         CALL LCMLEN(IPLIB,CV(:8)//NORD(IXSPER),LENGTH,ITYLCM)
         IF(LENGTH.EQ.0) GO TO 620
         EXIST=.TRUE.
         CALL LCMGET(IPLIB,CV(:8)//NORD(IXSPER),GA1)
         DO 610 LLL=1,NGROUP
  610    GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
  615    DENISO=DENISO*TIMFCT
*-
  620    CALL LCMSIX(IPLIB,' ',2)
  630    CONTINUE
      ENDIF
  640 CONTINUE
      DO 660 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 650 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) GAF(IBM,LLL,1)=GAF(IBM,LLL,2)
  650          CONTINUE
            ENDIF
         ENDIF
         IF(EXIST) CALL LCMPUT(KPLIB,CV,NBMIX,2,GAF(1,LLL,1))
      ENDIF
  660 CONTINUE
  670 CONTINUE
*
      CALL LCMGET(IPLIB,'ENERGY',GA1)
      IF(GA1(NGROUP+1).EQ.0.0) GA1(NGROUP+1)=1.0E-5
      CALL LCMSIX(IPLIB,HMACRO,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
        IDATA(5)=MAX(IDATA(5),NED)
      ELSE
        IDATA(1)=NGROUP
        IDATA(2)=NBMIX
        IDATA(3)=NL
        IDATA(4)=NFISSI
        IDATA(5)=NED
        TEXT12='L_MACROLIB'
        READ(TEXT12,'(3A4)') (KCHAR(I),I=1,3)
        CALL LCMPUT(IPLIB,'SIGNATURE',3,3,KCHAR)
        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 700 LLL=1,NGROUP
         ENEAVG=SQRT(GA1(LLL)*GA1(LLL+1))
         ZNU=1.0D0/(SQRT(ENEAVG)*SQFMAS)
         DO 690 IBM=1,NBMIX
  690    GAR(IBM,1)=REAL(ZNU)
         KPLIB=IPGRP(LLL)
         CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAR(1,1))
  700    CONTINUE
      ENDIF
*----
*  SET THE STATE VECTOR
*----
      IF(LSAME) IDATA(4)=MIN(NFISSI,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 710 I=11,NSTATE
  710 IDATA(I)=0
      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 720 KFIS=NFISS0+1,NFISSI
         DO 720 IDEL=1,NDEL
  720    GA3(IDEL,KFIS)=0.0
         CALL LCMSIX(IPLIB,' ',2)
         DO 730 KFIS=1,NFISSI
         DO 730 IBM=1,NBMIX
         IWFIS=INDFIS(IBM,KFIS)
         IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
            WRITE(TEXT12,'(3A4)') (ISONAM(I0,IWFIS),I0=1,3)
            CALL LCMSIX(IPLIB,TEXT12,1)
            CALL LCMLEN(IPLIB,'LAMBDA-D',LENGTH,ITYLCM)
            IF(LSAME.AND.(LENGTH.GT.0)) THEN
               CALL LCMGET(IPLIB,'LAMBDA-D',GA3(1,1))
            ELSE IF(LENGTH.GT.0) THEN
               CALL LCMGET(IPLIB,'LAMBDA-D',GA3(1,KFIS))
            ENDIF
            CALL LCMSIX(IPLIB,' ',2)
         ENDIF
  730    CONTINUE
         CALL LCMSIX(IPLIB,HMACRO,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 750 LLL=1,NGROUP
      IF(MASKL(LLL).OR.LALL) THEN
         KPLIB=IPGRP(LLL)
         DO 740 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))
  740    CONTINUE
      ENDIF
  750 CONTINUE
      CALL LCMSIX(IPLIB,' ',2)
*----
*  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
