path: root/Dragon/src/LIBDEN.f

*DECK LIBDEN
      SUBROUTINE LIBDEN (IPLIB,NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM,
     1 IPISO,MIX,DEN,MASK,MASKL,NED,NAMEAD,ITRANC,MAXNFI,NPART,LSAME,
     2 ITSTMP,TMPDAY,STERN)
*
*-----------------------------------------------------------------------
*
*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 and A. Naceur
*
*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.
* ISONAM  names of microlib isotopes.
* 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.
* NPART   number of companion particles.
* 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.
* STERN   Sternheimer flag (=0/1: off/on).
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLIB,IPISO(NBISO)
      INTEGER NGROUP,NBISO,NBMIX,NL,NDEL,NESP,ISONAM(3,NBISO),
     1 MIX(NBISO),NED,ITRANC,MAXNFI,NPART,NAMEAD(2,NED),ITSTMP,STERN 
      REAL DEN(NBISO),TMPDAY(3)
      LOGICAL MASK(NBMIX),MASKL(NGROUP),LSAME
*----
*  LOCAL VARIABLES
*----
      INTEGER NBLK,NSTATE,IOUT,MAXESP
      PARAMETER (NBLK=50,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,HPRT1*1
      LOGICAL EXIST,MASKK,LOGL,LALL,LWP1,LSTRD,LH,LC,LOVERV,LDIFF,
     1 LFISS,LWT0,LWT1
      INTEGER IDATA(NSTATE),IESP(MAXESP+1),I,J,I0,IOF,IOF0,IP,IPOSDE,
     1 IPASS,ISP,IGR,IG1,LLL,LLL0,IGMIN,IGMAX,IBM,JBM,IDEL,IED,IFIS,
     2 NXSPER,ISOT,IBLK,ILONG,LENGTZ,ITYLCM,IWFIS,IXSPER,KFIS,M,NBM0,
     3 NFISS0,NFISSI,NGROUPS
      REAL TMPPER(2,3),TIMFCT,DENISO,ENEAVG,FACT,TOTDEN,XTF
      DOUBLE PRECISION SQFMAS,XDRCST,NMASS,EVJ,ZNU
      TYPE(C_PTR) JPLIB,KPLIB
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS,IJJ,NJJ,IWRK,NGPART
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NJJM,IJJM,INDFIS
      REAL, ALLOCATABLE, DIMENSION(:) :: GA1,GA2,SCAT,VOLMIX,NWTMIX,
     1 VOLI,C2PART,KGAS,ENER
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GA3,GAR,WRK1,WRK2,DENMAT
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAF,CHECK,ZNUS,ZCHI,FLUX
      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:,:) :: IPGRP
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LMADE
      CHARACTER(LEN=1), ALLOCATABLE, DIMENSION(:) :: HNPART
      CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: ISONRF
*----
*  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(GA2(NGROUP*NGROUP),GA3(NDEL,MAXNFI),GAR(NBMIX,NBLK+1),
     1 GAF(NBMIX,NGROUP,NBLK),SCAT(NGROUP*NBMIX),CHECK(NBMIX,NGROUP,NL),
     2 ZNUS(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL),
     3 ZCHI(NBMIX*MAXNFI*NESP,NGROUP,0:NDEL))
      ALLOCATE(IPGRP(NGROUP,NPART+1))
      ALLOCATE(LMADE(NBISO))
      ALLOCATE(NGPART(NPART+1),C2PART(NPART+1),HNPART(NPART+1))
      ALLOCATE(DENMAT(NBMIX,NGROUP+1)) 
*----
*  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',ILONG,ITYLCM)
      IF((ILONG.GE.2).AND.(ILONG.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
*----
*  RECOVER MIXTURE VOLUMES IN MICROLIB.
*----
      CALL LCMLEN(IPLIB,'ISOTOPESVOL',ILONG,ITYLCM)
      IF(ILONG.GT.0) THEN
        ALLOCATE(VOLMIX(NBMIX),VOLI(NBISO))
        CALL LCMGET(IPLIB,'ISOTOPESVOL',VOLI)
        VOLMIX(:NBMIX)=0.0
        DO ISOT=1,NBISO
          IBM=MIX(ISOT)
          IF(IBM.GT.0) VOLMIX(IBM)=VOLI(ISOT)
        ENDDO
        CALL LCMPUT(IPLIB,'MIXTURESVOL',NBMIX,2,VOLMIX)
        DEALLOCATE(VOLI,VOLMIX)
      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',ILONG,ITYLCM)
      MASKK=(ILONG.EQ.-1)
      IF(MASKK) THEN
         CALL LCMSIX(IPLIB,'MACROLIB',1)
         CALL LCMGTC(IPLIB,'SIGNATURE',12,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',ILONG,ITYLCM)
            IF(ILONG.EQ.0) THEN
*              THE NAMES ARE NOT DEFINED.
               DO 11 IFIS=1,NFISSI
               DO 10 IBM=1,NBMIX
               INDFIS(IBM,IFIS)=0
   10          CONTINUE
   11          CONTINUE
            ELSE IF(ILONG.EQ.NFISSI*NBMIX) THEN
               CALL LCMGET(IPLIB,'FISSIONINDEX',INDFIS)
               DO 16 IFIS=1,NFISSI
               DO 15 IBM=1,NBMIX
               IF(INDFIS(IBM,IFIS).GT.NBISO) THEN
                  CALL XABORT('LIBDEN: INVALID RECORD FISSIONINDEX.')
               ENDIF
   15          CONTINUE
   16          CONTINUE
            ELSE IF(ILONG.LT.NFISSI*NBMIX) THEN
*              REORDER THE 'FISSIONINDEX' MATRIX.
               ALLOCATE(IWRK(ILONG))
               CALL LCMGET(IPLIB,'FISSIONINDEX',IWRK)
               DO 31 IFIS=1,NFISSI
               DO 20 IBM=1,NBM0
               INDFIS(IBM,IFIS)=IWRK((IFIS-1)*NBM0+IBM)
   20          CONTINUE
               DO 30 IBM=NBM0+1,NBMIX
               INDFIS(IBM,IFIS)=0
   30          CONTINUE
   31          CONTINUE
               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
*----
*  RECOVER PARTICLE DATA
*----
      CALL LCMLEN(IPLIB,'PARTICLE',ILONG,ITYLCM)
      IF(ILONG.EQ.0) THEN
        HPRT1=' '
        HNPART(1)=' '
      ELSE
        CALL LCMGTC(IPLIB,'PARTICLE',1,HPRT1)
        CALL LCMGTC(IPLIB,'PARTICLE-NAM',1,NPART+1,HNPART)
        CALL LCMGET(IPLIB,'PARTICLE-NGR',NGPART)
        CALL LCMGET(IPLIB,'PARTICLE-MC2',C2PART)
        CALL LCMSIX(IPLIB,'MACROLIB',1)
        CALL LCMPTC(IPLIB,'PARTICLE',1,HPRT1)
        CALL LCMPTC(IPLIB,'PARTICLE-NAM',1,NPART+1,HNPART)
        CALL LCMPUT(IPLIB,'PARTICLE-NGR',NPART+1,1,NGPART)
        CALL LCMPUT(IPLIB,'PARTICLE-MC2',NPART+1,2,C2PART)
        CALL LCMSIX(IPLIB,' ',2)
        IF(HPRT1.NE.HNPART(1)) THEN
          WRITE(HSMG,'(27HLIBDEN: MICROLIB PARTICLE (,A1,10H) IS DIFFE,
     1    26HRENT FROM PARTICLE-NAM(1)=,A1,1H.)') HPRT1,HNPART(1)
          CALL XABORT(HSMG)
        ENDIF
        DO IP=2,NPART+1
          ALLOCATE(GA1(NGPART(IP)+1))
          CALL LCMGET(IPLIB,HNPART(IP)//'ENERGY',GA1)
          CALL LCMSIX(IPLIB,'MACROLIB',1)
          CALL LCMPUT(IPLIB,HNPART(IP)//'ENERGY',NGPART(IP)+1,2,GA1)
          CALL LCMSIX(IPLIB,' ',2)
          DEALLOCATE(GA1)
        ENDDO
      ENDIF
*----
*  SELECT NUMBER OF GROUPS TO PROCESS
*----
      NGROUPS=0
      DO 35 LLL=1,NGROUP
      IF(MASKL(LLL).OR.LALL) NGROUPS=NGROUPS+1
   35 CONTINUE
      IF(NGROUPS.EQ.0) GO TO 880
*----
*  CHECK IF ALL REQUIRED ISOTOPES ARE PRESENT IN THE MICROLIB
*----
      ALLOCATE(GA1(NGROUP+1))
      DO 40 ISOT=1,NBISO
      IF(MIX(ISOT).EQ.0) GO TO 40
      IF(.NOT.MASK(MIX(ISOT))) GO TO 40
      JPLIB=IPISO(ISOT)
      IF(.NOT.C_ASSOCIATED(JPLIB)) THEN
         WRITE(HSMG,'(17HLIBDEN: ISOTOPE '',3A4,8H'' (SPEC=,I6,5H) IS ,
     >   30HNOT AVAILABLE IN THE MICROLIB.)') (ISONAM(I0,ISOT),I0=1,3),
     >   ISOT
         CALL XABORT(HSMG)
      ENDIF
   40 CONTINUE
*----
*  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,1)=LCMDIL(JPLIB,LLL)
   45 CONTINUE
      DO 47 IP=2,NPART+1
      JPLIB=LCMLID(IPLIB,'GROUP-'//HNPART(IP),NGROUP)
      DO 46 LLL=1,NGROUP
      IPGRP(LLL,IP)=LCMDIL(JPLIB,LLL)
   46 CONTINUE
   47 CONTINUE
      CALL LCMSIX(IPLIB,' ',2)
*----
*  PROCESS THE SCATTERING TABLES.
*----
      DO 52 I=1,NGROUP
      DO 51 IBM=1,NBMIX
      DO 50 J=1,NL
      CHECK(IBM,I,J)=0.0
   50 CONTINUE
   51 CONTINUE
   52 CONTINUE
      DO 245 IP=1,NPART+1
      DO 240 M=1,NL
      IF(M.LE.11) THEN
         CM=HCM(M-1)//'  '
      ELSE
         WRITE(CM,'(I2.2,2X)') M-1
      ENDIF
      DO 235 IPASS=0,(NGROUP-1)/NBLK
      LLL0=IPASS*NBLK
      DO 70 IBLK=1,NBLK
      DO 60 IBM=1,NBMIX
      GAR(IBM,IBLK)=0.0
   60 CONTINUE
      DO 71 LLL=1,NGROUP
      DO 72 IBM=1,NBMIX
      GAF(IBM,LLL,IBLK)=0.0
   72 CONTINUE
   71 CONTINUE
   70 CONTINUE
      DO 80 ISOT=1,NBISO
      LMADE(ISOT)=DEN(ISOT).EQ.0.0
   80 CONTINUE
      DO 140 ISOT=1,NBISO
      IF(LMADE(ISOT)) GO TO 140
      JPLIB=IPISO(ISOT)
      IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 140
*
*     RECOVER THE MICROSCOPIC TRANSFER XS WITHOUT USING XDRLGS (IN
*     ORDER TO REDUCE CPU TIME)
      IF(IP.GE.2) CALL LCMSIX(JPLIB,HNPART(IP),1)
      FACT=1.0
      DO 135 IXSPER=1,NXSPER
      CALL LCMLEN(JPLIB,'SIGS'//CM//NORD(IXSPER),ILONG,ITYLCM)
      IF(ILONG.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
      IOF0=IOF0+NJJ(LLL)
   90 CONTINUE
      DO 110 IBM=1,NBMIX
      IF((MASK(IBM).OR.(.NOT.MASKK)).AND.(MIX(ISOT).EQ.IBM)) THEN
         IOF=IOF0
         DO 105 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
         GAF(IBM,IG1,IBLK)=GAF(IBM,IG1,IBLK)+GA2(IOF)*DEN(ISOT)*FACT
  100    CONTINUE
  105    CONTINUE
      ENDIF
  110 CONTINUE
      LMADE(ISOT)=.TRUE.
  130 FACT=FACT*TIMFCT
  135 CONTINUE
      IF(IP.GE.2) CALL LCMSIX(JPLIB,' ',2)
*-
  140 CONTINUE
      DO 230 IBLK=1,NBLK
      LLL=LLL0+IBLK
      IF(LLL.GT.NGROUP) GO TO 230
      KPLIB=IPGRP(LLL,IP)
      IF(MASKL(LLL).OR.LALL) THEN
         IF(MASKK) THEN
           ILONG=1
           IF(M.GT.1) CALL LCMLEN(KPLIB,'SIGS'//CM,ILONG,ITYLCM)
           GAR(:NBMIX,NBLK+1)=0.0
           IF(ILONG.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 165 IBM=1,NBMIX
      DO 160 IG1=1,NGROUP
      LOGL=LOGL.OR.(MASKL(IG1).AND.(GAF(IBM,IG1,IBLK).NE.0.0))
  160 CONTINUE
  165 CONTINUE
      IF(LOGL) THEN
         IF(MASKK) THEN
           ILONG=1
           IF(M.GT.1) CALL LCMLEN(KPLIB,'SCAT'//CM,ILONG,ITYLCM)
           IF(ILONG.GT.0) THEN
             DO 170 I=1,NBMIX
             IPOS(I)=-99
  170        CONTINUE
             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)
                IPOSDE=IPOSDE+1
  180           CONTINUE
             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)
         CHECK(IBM,IG1,M)=CHECK(IBM,IG1,M)+SCAT(IPOSDE)
  210    CONTINUE
         GAR(IBM,1)=SCAT(IPOS(IBM)+IJJM(IBM,IBLK)-LLL)
  220    CONTINUE
         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
  235 CONTINUE
  240 CONTINUE
  245 CONTINUE
*----
*  STERNHEIMER DENSITY CORRECTION FOR CHARGED PARTICLE CASES
*----      
      IF(HPRT1.EQ.'B'.OR.HPRT1.EQ.'C') THEN 
        ALLOCATE(ISONRF(NBISO),ENER(NGROUP+1),KGAS(NBMIX))
        CALL LCMGTC(IPLIB,'ISOTOPERNAME',12,NBISO,ISONRF)
        CALL LCMGET(IPLIB,'ENERGY',ENER)
        CALL LCMGET(IPLIB,'MIXTUREGAS',KGAS)
        CALL LIBSDC(NBMIX,NGROUP,NBISO,ISONRF,MIX,DEN,MASK,ENER,KGAS,
     1  DENMAT)  
        DEALLOCATE(KGAS,ENER,ISONRF)
      ENDIF
*----
*  PROCESS THE REACTION VECTORS TOTAL, TOTAL-P1, STRD, H-FACTOR,
*  C-FACTOR, OVERV AND TRANC.
*----
      LWP1=.FALSE.
      LSTRD=.FALSE.
      LH=.FALSE.
      LC=.FALSE.
      LOVERV=.FALSE.
      DO 340 IBM=1,NBMIX
      IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
         DO 255 IP=1,14 
         DO 250 LLL=1,NGROUP
         GAF(IBM,LLL,IP)=0.0
  250    CONTINUE
  255    CONTINUE
         TOTDEN=0.0
         DO 320 ISOT=1,NBISO
         IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 320
         JPLIB=IPISO(ISOT)
         IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 320
*-
         DENISO=DEN(ISOT)
         TOTDEN=TOTDEN+DENISO
         DO 315 IXSPER=1,NXSPER
         CALL LCMGET(JPLIB,'NTOT0   '//NORD(IXSPER),GA1)
         DO 260 LLL=1,NGROUP
         GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
  260    CONTINUE
         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
            GAF(IBM,LLL,3)=GAF(IBM,LLL,3)+GA1(LLL)*DENISO
  270       CONTINUE
         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
               GAF(IBM,LLL,5)=GAF(IBM,LLL,5)+GA1(LLL)*DENISO
  280          CONTINUE
            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) !eV-barns
            DO 290 LLL=1,NGROUP
            GAF(IBM,LLL,7)=GAF(IBM,LLL,7)+GA1(LLL)*DENISO !MeV/cm
  290       CONTINUE
         ENDIF
         CALL LCMLEN(JPLIB,'C-FACTOR'//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.GT.0) THEN
            LC=.TRUE.
            CALL LCMGET(JPLIB,'C-FACTOR'//NORD(IXSPER),GA1)
            DO 295 LLL=1,NGROUP
            GAF(IBM,LLL,13)=GAF(IBM,LLL,13)+GA1(LLL)*DENISO
  295       CONTINUE
         ENDIF
         CALL LCMLEN(JPLIB,'OVERV   '//NORD(IXSPER),ILONG,ITYLCM)
         IF((ILONG.GT.0).AND.((HPRT1.EQ.'N').OR.(HPRT1.EQ.'NEUT').OR.
     1   (HPRT1.EQ.' '))) THEN
            LOVERV=.TRUE.
            CALL LCMGET(JPLIB,'OVERV   '//NORD(IXSPER),GA1)
            DO 300 LLL=1,NGROUP
            GAF(IBM,LLL,9)=GAF(IBM,LLL,9)+GA1(LLL)*DENISO
  300       CONTINUE
         ENDIF
         IF(ITRANC.NE.0) THEN
            CALL LCMGET(JPLIB,'TRANC   '//NORD(IXSPER),GA1)
            DO 310 LLL=1,NGROUP
            GAF(IBM,LLL,11)=GAF(IBM,LLL,11)+GA1(LLL)*DENISO
  310       CONTINUE
         ENDIF
         DENISO=DENISO*TIMFCT
  315    CONTINUE
*-
  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
      !-----------------------------------------------------------
      !APPLY STERNHEIMER DENSITY CORRECTION ON HEAT DEPOSITION FOR
      !ELECTRON AND POSITRON.
      !REASON: SOFT INLEASTIC HEAT DEPOSITION IN ELECTR
      !CONTAINS A COLLISONNAL STOPPING POWER WHICH HAS NOT
      !BEEN CORRECTED IN NJOY.
      !-----------------------------------------------------------
      IF (STERN.EQ.1) THEN
         IF (HPRT1.EQ.'B'.OR.HPRT1.EQ.'C') THEN
            DO LLL=1,NGROUP
               GAF(IBM,LLL,7)=GAF(IBM,LLL,7)-DENMAT(IBM,LLL) !eV/cm
            ENDDO
          ENDIF
      ENDIF
  340 CONTINUE
      DO 420 LLL=1,NGROUP
      KPLIB=IPGRP(LLL,1)
      IF(MASKL(LLL).OR.LALL) THEN
         IF(MASKK) THEN
            GAF(:NBMIX,LLL,2)=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
               GAF(:NBMIX,LLL,4)=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
               GAF(:NBMIX,LLL,6)=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
               GAF(:NBMIX,LLL,8)=0.0
               CALL LCMLEN(KPLIB,'H-FACTOR',ILONG,ITYLCM)
               IF(ILONG.GT.0) THEN
                  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
            ENDIF
            CALL LCMPUT(KPLIB,'H-FACTOR',NBMIX,2,GAF(1,LLL,7)) !eV/cm
         ENDIF
         IF(LC) THEN
            IF(MASKK) THEN
               GAF(:NBMIX,LLL,14)=0.0
               CALL LCMGET(KPLIB,'C-FACTOR',GAF(1,LLL,14))
               DO 395 IBM=1,NBMIX
               IF(.NOT.MASK(IBM)) GAF(IBM,LLL,13)=GAF(IBM,LLL,14)
  395          CONTINUE
            ENDIF
            CALL LCMPUT(KPLIB,'C-FACTOR',NBMIX,2,GAF(1,LLL,13)) !e/cm
         ENDIF
         IF(LOVERV) THEN
            IF(MASKK) THEN
               GAF(:NBMIX,LLL,10)=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
               GAF(:NBMIX,LLL,12)=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)
         IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 460
         CALL LCMLEN(JPLIB,'NUSIGF',ILONG,ITYLCM)
         IF(NESP.EQ.1) THEN
            CALL LCMLEN(JPLIB,'CHI',LENGTZ,ITYLCM)
         ELSE
            CALL LCMLEN(JPLIB,'CHI--01',LENGTZ,ITYLCM)
         ENDIF
         IF((ILONG.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
            INDFIS(JBM,KFIS)=0
  440       CONTINUE
  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
            ZNUS(:NBMIX*MAXNFI*NESP,LLL,IDEL)=0.0
            ZCHI(:NBMIX*MAXNFI*NESP,LLL,IDEL)=0.0
  465       CONTINUE
            KPLIB=IPGRP(LLL,1)
            CALL LCMLEN(KPLIB,'NUSIGF',ILONG,ITYLCM)
            IF(ILONG.NE.NBM0*NFISS0*NESP) THEN
               CALL XABORT('LIBDEN: NBM ERROR.')
            ENDIF
            CALL LCMGET(KPLIB,'NUSIGF',WRK1)
            CALL LCMGET(KPLIB,'CHI',WRK2)
            DO 467 IFIS=1,NFISS0*NESP
            DO 466 IBM=1,NBM0
            ZNUS((IFIS-1)*NBMIX+IBM,LLL,0)=WRK1(IBM,IFIS)
            ZCHI((IFIS-1)*NBMIX+IBM,LLL,0)=WRK2(IBM,IFIS)
  466       CONTINUE
  467       CONTINUE
            DO 475 IDEL=1,NDEL
            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
            CALL LCMLEN(KPLIB,TEXT12,ILONG,ITYLCM)
            IF(ILONG.NE.0) THEN
               CALL LCMGET(KPLIB,TEXT12,WRK1)
               WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
               CALL LCMGET(KPLIB,TEXT12,WRK2)
               DO 471 IFIS=1,NFISS0*NESP
               DO 470 IBM=1,NBM0
               ZNUS((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK1(IBM,IFIS)
               ZCHI((IFIS-1)*NBMIX+IBM,LLL,IDEL)=WRK2(IBM,IFIS)
  470          CONTINUE
  471          CONTINUE
            ENDIF
  475       CONTINUE
         ENDIF
  480    CONTINUE
         DEALLOCATE(WRK2,WRK1)
      ENDIF
      IF(NFISSI.GT.0) THEN
         DO 525 ISP=1,NESP
         DO 520 KFIS=1,NFISSI
         IF(KFIS.GT.NFISS0*NESP) THEN
            DO 492 IDEL=0,NDEL
            DO 491 LLL=1,NGROUP
            DO 490 IBM=1,NBMIX
            IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
            ZNUS(IOF,LLL,IDEL)=0.0
            ZCHI(IOF,LLL,IDEL)=0.0
  490       CONTINUE
  491       CONTINUE
  492       CONTINUE
         ELSE
            DO 510 IBM=1,NBMIX
            IWFIS=INDFIS(IBM,KFIS)
            IF((IWFIS.NE.0).AND.(MASK(IBM).OR.(.NOT.MASKK))) THEN
               DO 505 IDEL=0,NDEL
               DO 500 LLL=1,NGROUP
               IOF=(KFIS-1)*NBMIX*NESP+(ISP-1)*NBMIX+IBM
               ZNUS(IOF,LLL,IDEL)=0.0
               ZCHI(IOF,LLL,IDEL)=0.0
  500          CONTINUE
  505          CONTINUE
            ENDIF
  510       CONTINUE
         ENDIF
  520    CONTINUE
  525    CONTINUE
*-
         IF(NESP.EQ.1) THEN
*          ONE FISSION SPECTRUM (CLASSICAL CASE)
           DO 585 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)
              IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 580
*-
              DENISO=DEN(IWFIS)
              DO 570 IXSPER=1,NXSPER
              CALL LCMGET(JPLIB,'NUSIGF  '//NORD(IXSPER),GA1)
              DO 530 LLL=1,NGROUP
              ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO
  530         CONTINUE
              IF(NDEL.GT.0) THEN
                 WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
                 IF(ILONG.GT.0) THEN
                    DO 545 IDEL=1,NDEL
                    WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 540 LLL=1,NGROUP
                    ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)*
     1              DENISO
  540               CONTINUE
  545               CONTINUE
                 ENDIF
                 WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
                 IF((ILONG.GT.0).AND.(IXSPER.EQ.1)) THEN
                    DO 555 IDEL=1,NDEL
                    WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 550 LLL=1,NGROUP
                    ZCHI(IOF,LLL,IDEL)=GA1(LLL)
  550               CONTINUE
  555               CONTINUE
                 ENDIF
              ENDIF
              IF(IXSPER.EQ.1) THEN
                 CALL LCMGET(JPLIB,'CHI     '//NORD(IXSPER),GA1)
                 DO 560 LLL=1,NGROUP
                 ZCHI(IOF,LLL,0)=GA1(LLL)
  560            CONTINUE
              ENDIF
              DENISO=DENISO*TIMFCT
  570         CONTINUE
           ENDIF
  580      CONTINUE
  585      CONTINUE
         ELSE
*          NESP>1 MULTIPLE FISSION SPECTRA CASE
           DO 662 ISP=1,NESP
           DO 661 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)
              IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 660
*-
              DENISO=DEN(IWFIS)
              DO 650 IXSPER=1,NXSPER
              CALL LCMGET(JPLIB,'NUSIGF  '//NORD(IXSPER),GA1)
              DO 610 LLL=IESP(ISP)+1,IESP(ISP+1)
              ZNUS(IOF,LLL,0)=ZNUS(IOF,LLL,0)+GA1(LLL)*DENISO
  610         CONTINUE
              IF((NDEL.GT.0).AND.(ISP.EQ.1)) THEN
                 WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
                 IF(ILONG.GT.0) THEN
                    DO 625 IDEL=1,NDEL
                    WRITE(TEXT12,'(6HNUSIGF,I2.2,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 620 LLL=1,NGROUP
                    ZNUS(IOF,LLL,IDEL)=ZNUS(IOF,LLL,IDEL)+GA1(LLL)*
     1              DENISO
  620               CONTINUE
  625               CONTINUE
                 ENDIF
                 WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') NDEL,NORD(IXSPER)
                 CALL LCMLEN(JPLIB,TEXT12,ILONG,ITYLCM)
                 IF((ILONG.GT.0).AND.(IXSPER.EQ.1)) THEN
                    DO 635 IDEL=1,NDEL
                    WRITE(TEXT12,'(3HCHI,I2.2,3X,A4)') IDEL,NORD(IXSPER)
                    CALL LCMGET(JPLIB,TEXT12,GA1)
                    DO 630 LLL=1,NGROUP
                    ZCHI(IOF,LLL,IDEL)=GA1(LLL)
  630               CONTINUE
  635               CONTINUE
                 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
                    ZCHI(IOF,LLL,0)=GA1(LLL)
  640               CONTINUE
                 ENDIF
              ENDIF
              DENISO=DENISO*TIMFCT
  650         CONTINUE
           ENDIF
  660      CONTINUE
  661      CONTINUE
  662      CONTINUE
         ENDIF 
*-
         DO 680 LLL=1,NGROUP
         IF(MASKL(LLL).OR.LALL) THEN
            KPLIB=IPGRP(LLL,1)
            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
      IF((CV(:3).EQ.'BST').OR.(CV(:3).EQ.'CST')) GO TO 770
      IF(CV(:8).EQ.'H-FACTOR') GO TO 770
      EXIST=.FALSE.
      DO 740 IBM=1,NBMIX
      IF(MASK(IBM).OR.(.NOT.MASKK)) THEN
         DO 690 LLL=1,NGROUP
         GAF(IBM,LLL,1)=0.0
  690    CONTINUE
         DO 730 ISOT=1,NBISO
         IF((MIX(ISOT).NE.IBM).OR.(DEN(ISOT).EQ.0.0)) GO TO 730
         JPLIB=IPISO(ISOT)
         IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 730
*-
         DENISO=DEN(ISOT)
         DO 710 IXSPER=1,NXSPER
         CALL LCMLEN(JPLIB,CV(:8)//NORD(IXSPER),ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 720
         EXIST=.TRUE.
         CALL LCMGET(JPLIB,CV(:8)//NORD(IXSPER),GA1)
         DO 700 LLL=1,NGROUP
         GAF(IBM,LLL,1)=GAF(IBM,LLL,1)+GA1(LLL)*DENISO
  700    CONTINUE
         DENISO=DENISO*TIMFCT
  710    CONTINUE
*-
  720    CONTINUE
  730    CONTINUE
      ENDIF
  740 CONTINUE
      DO 760 LLL=1,NGROUP
      IF(MASKL(LLL).OR.LALL) THEN
         KPLIB=IPGRP(LLL,1)
         IF(MASKK) THEN
            CALL LCMLEN(KPLIB,CV,ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
               EXIST=.TRUE.
               GAF(:NBMIX,LLL,2)=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,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).AND.((HPRT1.EQ.'N').OR.(HPRT1.EQ.'NEUT').OR.
     1   (HPRT1.EQ.' '))) THEN
         DO 800 LLL=1,NGROUP
         ENEAVG=SQRT(GA1(LLL)*GA1(LLL+1))
         ZNU=1.0/(SQRT(ENEAVG)*SQFMAS)
         DO 790 IBM=1,NBMIX
         GAR(IBM,1)=REAL(ZNU)
  790    CONTINUE
         KPLIB=IPGRP(LLL,1)
         CALL LCMPUT(KPLIB,'OVERV',NBMIX,2,GAR(1,1))
  800    CONTINUE
      ENDIF
      DEALLOCATE(GA1)
*----
*  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
      IDATA(I)=0
  810 CONTINUE
      CALL LCMLEN(IPLIB,'SPH',ILONG,ITYLCM)
      IF(ILONG.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',ILONG,ITYLCM)
            IF(ILONG.EQ.0) THEN
               GA3(:NDEL,1)=0.0
            ELSE
               CALL LCMGET(IPLIB,'LAMBDA-D',GA3(1,1))
            ENDIF
         ENDIF
         DO 825 KFIS=NFISS0+1,NFISSI
         DO 820 IDEL=1,NDEL
         GA3(IDEL,KFIS)=0.0
  820    CONTINUE
  825    CONTINUE
         CALL LCMSIX(IPLIB,' ',2)
         DO 835 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)
            IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 830
            CALL LCMLEN(JPLIB,'LAMBDA-D',ILONG,ITYLCM)
            IF(LSAME.AND.(ILONG.GT.0)) THEN
               CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,1))
            ELSE IF(ILONG.GT.0) THEN
               CALL LCMGET(JPLIB,'LAMBDA-D',GA3(1,KFIS))
            ENDIF
         ENDIF
  830    CONTINUE
  835    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,1)
         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',ILONG,ITYLCM)
      IF(ILONG.GT.0) THEN
        ALLOCATE(VOLMIX(NBMIX),NWTMIX(NGROUP),FLUX(NBMIX,NGROUP,2))
        CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMIX)
        LWT0=.FALSE.
        LWT1=.FALSE.
        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',ILONG,ITYLCM)
            IF(ILONG.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',ILONG,ITYLCM)
            IF(ILONG.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
*----
  880 DEALLOCATE(DENMAT)
      DEALLOCATE(HNPART,C2PART,NGPART)
      DEALLOCATE(LMADE)
      DEALLOCATE(IPGRP)
      DEALLOCATE(ZCHI,ZNUS,CHECK,SCAT,GAF,GAR,GA3,GA2)
      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