path: root/Dragon/src/EDIMIC.f

*DECK EDIMIC
      SUBROUTINE EDIMIC(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO,
     1 NDEPL,ISONAM,ISONRF,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRINT,
     2 NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW,
     3 MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK,
     4 EIGINF,B2,DEN,ITYPE,IEVOL,LSISO,EMEVF,EMEVG,DECAY,YIELD,FIPI,
     5 FIFP,PYIELD,ITRANC,LISO,NMLEAK)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Homogenization and condensation of microscopic cross sections.
*
*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
* IPEDIT  pointer to the edition LCM object (L_EDIT signature).
* IPFLUX  pointer to the solution LCM object (L_FLUX signature).
* IPLIB   pointer to the reference microscopic cross section library
*         LCM object (L_LIBRARY signature).
* IADJ    type of flux weighting:
*         =0: direct flux weighting;
*         =1: direct-adjoint flux weighting.
* NL      number of Legendre orders required in the calculation
*         (NL=1 or higher).
* NDEL    number of delayed precursor groups.
* NBESP   number of energy-dependent fission spectra.
* NBISO   number of isotopes.
* NDEPL   number of depleting isotopes.
* ISONAM  local names of NBISO isotopes:
*         chars 1 to 8  is the local isotope name;
*         chars 9 to 12 is a suffix function of the mix number.
* ISONRF  library name of isotopes.
* IPISO   pointer array towards microlib isotopes.
* MIX     mixture number associated with each isotope.
* TN      absolute temperature associated with each isotope.
* NED     number of extra vector edits from MATXS.
* HVECT   MATXS names of the extra vector edits.
* NOUT    number of output cross section types (set to zero to recover
*         all cross section types).
* HVOUT   MATXS names of the output cross section types.
* IPRINT  print index.
* NGROUP  number of energy groups.
* NGCOND  number of condensed groups.
* NBMIX   number of mixtures.
* NREGIO  number of volumes.
* NMERGE  number of merged regions.
* NDFI    number of fissile isotopes.
* NDFP    number of fission products.
* ILEAKS  leakage calculation type: =0: no leakage; =1: homogeneous
*         leakage (Diffon); =2: isotropic streaming (Ecco);
*         =3: anisotropic streaming (Tibere).
* ILUPS   up-scattering removing flag (=1 to remove up-scattering from
*         output cross-sections).
* NW      type of weighting for P1 cross section info (=0: P0 ; =1: P1).
* MATCOD  mixture index per volume.
* VOLUME  volumes.
* KEYFLX  position of average fluxes.
* CURNAM  name of the LCM directory where the microscopic cross sections
*         are stored (a blank value means no save).
* IGCOND  limits of condensed groups.
* IMERGE  index of merged regions.
* FLUXES  fluxes.
* AFLUXE  adjoint fluxes.
* EIGENK  effective multiplication factor.
* EIGINF  infinite multiplication factor.
* B2      bucklings.
* DEN     number density of each isotope.
* ITYPE   type of each isotope.
* IEVOL   flag making an isotope non-depleting. A value of
*         1 is used to force an isotope to be non-depleting.
* LSISO   flag for isotopes saved.
* EMEVF   fission production energy.
* EMEVG   capture production energy.
* DECAY   radioactive decay constant.
* YIELD   group-ordered condensed fission product yield.
* FIPI    fissile isotope index assigned to each microlib isotope.
* FIFP    fission product index assigned to each microlib isotope.
* PYIELD  fissile isotope ordered condensed fission product yield.
* ITRANC  type of transport correction (=0: no correction).
* LISO    =.TRUE. if we want to keep all the isotopes after 
*         homogeneization.
* NMLEAK  number of leakage zones.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPEDIT,IPFLUX,IPLIB,IPISO(NBISO)
      INTEGER   IADJ,NL,NDEL,NBESP,NBISO,NDEPL,ISONAM(3,NBISO),
     1          ISONRF(3,NBISO),MIX(NBISO),NED,NOUT,IPRINT,NGROUP,
     2          NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,ILUPS,NW,
     3          MATCOD(NREGIO),KEYFLX(NREGIO),IGCOND(NGCOND),
     4          IMERGE(NREGIO),ITYPE(NBISO),IEVOL(NBISO),LSISO(NBISO),
     5          FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE),ITRANC,NMLEAK
      REAL      TN(NBISO),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1),
     1          AFLUXE(NREGIO,NGROUP,NW+1),EIGENK,EIGINF,B2(4),
     2          DEN(NBISO),EMEVF(NBISO),EMEVG(NBISO),DECAY(NBISO),
     3          YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE)
      CHARACTER HVECT(NED)*8,HVOUT(NOUT)*8,CURNAM*12
      LOGICAL   LISO
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40,MAXESP=4)
      TYPE(C_PTR) JPLIB,KPLIB,JPFLUX,JPEDIT,KPEDIT
      LOGICAL    LOGIC,LSTRD,LAWR,LMEVF,LMEVG,LDECA,LWD,LONE
      CHARACTER  CM*2,HNEW*12,TEXT8*8,TEXT12*12,HSMG*131,HNAMIS*12
      INTEGER    IPAR(NSTATE),IESP2(MAXESP+1)
      REAL       B2T(3),EESP(MAXESP+1),EESP2(MAXESP+1)
      DOUBLE PRECISION TMP,PARM0,PARM3,PARM4,VOLMER,DDEN,DDENZ,SQFMAS,
     1           XDRCST,NMASS,EVJ,CONV,ZNU,ZDEN,ZFL1,ZFL2,DENVOL
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ISMIX,ISTYP,ISTOD,ITYPRO,
     1 JPIFI,MILVO,ITYPS,IMERGL
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHNISO
      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IGAR
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK
      REAL, ALLOCATABLE, DIMENSION(:) :: XSECT,WSTRD,SDEN,VOLISO,TNISO,
     1 TMPXS,WDLA,WORK,WORKF,ENR,GA1,GA2,VOLM,YPIFI
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR,WGAR,DIFHET
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: PARM12,PHIAV,AHIAV
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: GAS
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT
      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HMAKE
*----
*  SCRATCH STORAGE ALLOCATION
*----
*
* GAR/GAS CONTENTS:
*              1 : 'NWT0'  |  P0 direct flux
*              2 : 'NWT1'  |  P1 direct flux / NW values
*  ...                     |
*           2+NW : 'NWAT0' |  P0 adjoint flux
*           3+NW : 'NWAT1' |  P1 adjoint flux / NW values
*  ...                     |
*         3+2*NW : 'NTOT0' |  P0 total cross section
*         4+2*NW : 'NTOT1' |  P1 total cross section / NW values
*  ...                     |
*         4+3*NW : 'SIGS00' |
*         5+3*NW : 'SIGS01' | NL VALUES
*  ...                      |
*      4+NL+3*NW : 'NUSIGF'
*      5+NL+3*NW : HVECT(1) |
*      6+NL+3*NW : HVECT(2) | NED VALUES
*  ...                      |
*  5+NED+NL+3*NW : 'H-FACTOR'
*  6+NED+NL+3*NW : 'OVERV'
*  7+NED+NL+3*NW : 'TRANC'
*  8+NED+NL+3*NW : 'STRD'
*        IOF0H+1 : 'NUSIGF01' |
*        IOF0H+2 : 'NUSIGF02' | NDEL VALUES
*  ...                        |
*   IOF1H+NDEL+1 : 'CHI'
*   IOF1H+NDEL+2 : 'CHI01' |
*   IOF1H+NDEL+3 : 'CHI02' | NDEL VALUES
*  ...                     |
* IOF1H+2*NDEL+2 : 'CHI--01' |
* IOF1H+2*NDEL+3 : 'CHI--02' | NBESP VALUES
*  ...                       |
*
      MAXH=9+NBESP+2*NDEL+NED+NL+3*NW
      CALL EDIMAX(NBISO,ISONAM,MIX,IPRINT,NREGIO,NMERGE,MATCOD,IMERGE,
     1 LSISO,LISO,MAXISO)
      
      ALLOCATE(IGAR(NGROUP,3,NL),IHNISO(3,MAXISO),ISMIX(MAXISO),
     1 ISTYP(MAXISO),ISTOD(MAXISO),ITYPRO(NL),MILVO(NMERGE),
     2 ITYPS(NBISO),IMERGL(NBMIX))
      ALLOCATE(MASK(NBISO))
      ALLOCATE(GAR(NGROUP,MAXH),WGAR(NGROUP**2,NL),XSECT(0:NBMIX),
     1 DIFHET(NMLEAK,NGROUP),WSTRD(NGCOND),SDEN(MAXISO),VOLISO(MAXISO),
     2 TNISO(MAXISO),TMPXS(NGCOND),WDLA(NDEL),WORK(NGROUP))
      ALLOCATE(WSCAT(NGCOND,NGCOND,NL),GAS(NGCOND,MAXH))
      ALLOCATE(HMAKE(MAXH+NL))
      ALLOCATE(JPIFI(MAXISO),YPIFI(MAXISO))
*----
*  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)
*
      JPEDIT=C_NULL_PTR
      IF(CURNAM.NE.' ') THEN
        CALL LCMSIX(IPEDIT,CURNAM,1)
        IF(MAXISO.GT.0) JPEDIT=LCMLID(IPEDIT,'ISOTOPESLIST',MAXISO)
      ENDIF
*
      DO 10 ISO=1,MAXISO
      SDEN(ISO)=0.0
      VOLISO(ISO)=0.0
      JPIFI(ISO)=0
   10 CONTINUE
      IOF0H=8+NED+NL+3*NW
      IOF1H=8+NED+NL+3*NW+NDEL
      IOF2H=8+NED+NL+3*NW+2*NDEL
      JJISO=0
      JJNDFI=0
      CONV=1.0E6 ! convert MeV to eV
      DO 430 INM=1,NMERGE
*----
*  PRELIMINARY CALCULATIONS FOR STRD CROSS SECTIONS
*----
      LSTRD=ILEAKS.GE.1
      IF(LSTRD) THEN
         IF(ILEAKS.EQ.1) THEN
            CALL LCMLEN(IPFLUX,'DIFFHET',ILCMLN,ITYLCM)
            IF(ILCMLN.EQ.0) THEN
               CALL XABORT('EDIMIC: UNABLE TO RECOVER THE DIFFHET RECO'
     1         //'RD IN THE FLUX OBJECT.')
            ENDIF
            CALL LCMGET(IPFLUX,'IMERGE-LEAK',IMERGL)
            CALL LCMGET(IPFLUX,'DIFFHET',DIFHET)
         ELSE IF(ILEAKS.EQ.3) THEN
            CALL LCMGET(IPFLUX,'B2  HETE',B2T)
            B2ALL=B2T(1)+B2T(2)+B2T(3)
            IF(B2ALL.EQ.0.0) THEN
               B2T(1)=1.0/3.0
               B2T(2)=B2T(1)
               B2T(3)=B2T(1)
            ELSE
               B2T(1)=B2T(1)/B2ALL
               B2T(2)=B2T(2)/B2ALL
               B2T(3)=B2T(3)/B2ALL
            ENDIF
         ENDIF
         IGRFIN=0
         XSECT(0)=0.0
         DO 50 IGRCND=1,NGCOND
         ZNU=0.0D0
         ZDEN=0.0D0
         ZFL1=0.0D0
         ZFL2=0.0D0
         IGRDEB=IGRFIN+1
         IGRFIN=IGCOND(IGRCND)
         CALL LCMSIX(IPLIB,'MACROLIB',1)
         JPLIB=LCMGID(IPLIB,'GROUP')
         JPFLUX=LCMGID(IPFLUX,'FLUX')
         DO 40 IGR=IGRDEB,IGRFIN
         KPLIB=LCMGIL(JPLIB,IGR)
         CALL LCMGET(KPLIB,'NTOT0',XSECT(1))
         IF((ILEAKS.EQ.2).OR.(ILEAKS.EQ.3)) THEN
            CALL LCMLEL(JPFLUX,IGR,ILCMLN,ITYLCM)
            IF(ILCMLN.EQ.0) CALL XABORT('EDIMIC: MISSING FLUX INFO.')
            ALLOCATE(WORKF(ILCMLN))
            CALL LCMGDL(JPFLUX,IGR,WORKF)
         ENDIF
         FL1=0.0
         FL2=0.0
         DO 20 IREGIO=1,NREGIO
         MATNUM=MATCOD(IREGIO)
         IF(IMERGE(IREGIO).EQ.INM) THEN
            VOLREG=VOLUME(IREGIO)
            IF(IADJ.EQ.0) THEN
              FL1=FLUXES(IREGIO,IGR,1)
              IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2)
            ELSE IF(IADJ.EQ.1) THEN
              IF(ILEAKS.NE.1) CALL XABORT('EDIMIC: DIRECT-ADJOINT WEIG'
     1        //'HTING NOT IMPLEMENTED.')
              FL1=FLUXES(IREGIO,IGR,1)*AFLUXE(IREGIO,IGR,1)
              IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2)*
     1        AFLUXE(IREGIO,IGR,2)
            ENDIF
            IF(NW.EQ.0) THEN
               ZLEAK=0.0
               IF(ILEAKS.EQ.1) THEN
                 IME=IMERGL(MATNUM)
                 IF(IME.GT.0) ZLEAK=DIFHET(IME,IGR)*FLUXES(IREGIO,IGR,1)
               ELSE IF(ILEAKS.EQ.2) THEN
                 ZLEAK=WORKF(KEYFLX(IREGIO)+ILCMLN/2)
               ELSE IF(ILEAKS.EQ.3) THEN
                 ZLEAK=B2T(1)*WORKF(KEYFLX(IREGIO)+NREGIO)+
     1                 B2T(2)*WORKF(KEYFLX(IREGIO)+2*NREGIO)+
     2                 B2T(3)*WORKF(KEYFLX(IREGIO)+3*NREGIO)
               ENDIF
               ZNU=ZNU+ZLEAK*VOLREG
               ZDEN=ZDEN+XSECT(MATNUM)*FL1*VOLREG
               ZFL1=ZFL1+FL1*VOLREG
               ZFL2=ZFL2+FL1*VOLREG
            ELSE
               ZNU=ZNU+FL2*VOLREG
               ZDEN=ZDEN+XSECT(MATNUM)*FL2*VOLREG
               ZFL1=ZFL1+FL1*VOLREG
               ZFL2=ZFL2+FL2*VOLREG
            ENDIF
         ENDIF
   20    CONTINUE
         IF((ILEAKS.EQ.2).OR.(ILEAKS.EQ.3)) DEALLOCATE(WORKF)
         CALL LCMLEN(KPLIB,'SIGS01',LENGTH,ITYLCM)
         IF((LENGTH.EQ.NBMIX).AND.(NL.GE.2)) THEN
            CALL LCMGET(KPLIB,'SIGS01',XSECT(1))
            DO 30 IREGIO=1,NREGIO
            MATNUM=MATCOD(IREGIO)
            IF(IMERGE(IREGIO).EQ.INM) THEN
               VOLREG=VOLUME(IREGIO)
               IF(IADJ.EQ.0) THEN
                 FL1=FLUXES(IREGIO,IGR,1)
                 IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2)
               ELSE IF(IADJ.EQ.1) THEN
                 FL1=FLUXES(IREGIO,IGR,1)*AFLUXE(IREGIO,IGR,1)
                 IF(NW.GE.1) FL2=FLUXES(IREGIO,IGR,2)*
     1           AFLUXE(IREGIO,IGR,2)
               ENDIF
               IF(NW.EQ.0) THEN
                  ZDEN=ZDEN-XSECT(MATNUM)*FL1*VOLREG
               ELSE
                  ZDEN=ZDEN-XSECT(MATNUM)*FL2*VOLREG
               ENDIF
            ENDIF
   30       CONTINUE
         ENDIF
   40    CONTINUE
         CALL LCMSIX(IPLIB,' ',2)
         WSTRD(IGRCND)=REAL((ZFL1/(3.0*ZNU))*ZFL2/ZDEN)
   50    CONTINUE
      ENDIF
*
      VOLMER=0.0D0
      DO 60 IREGIO=1,NREGIO
      IF(IMERGE(IREGIO).EQ.INM) VOLMER=VOLMER+VOLUME(IREGIO)
   60 CONTINUE
      MASK(:NBISO)=.FALSE.
      DO 420 ISO=1,NBISO
      ITYPS(ISO)=ITYPE(ISO)
      IF(MASK(ISO).OR.(LSISO(ISO).EQ.0)) GO TO 420
      DO 90 IREGIO=1,NREGIO
      IF((IMERGE(IREGIO).EQ.INM).AND.(MATCOD(IREGIO).EQ.MIX(ISO)))
     1 GO TO 100
   90 CONTINUE
      GO TO 420
  100 LOGIC=.FALSE.
      DDEN=0.0D0
      DDENZ=0.0D0
*----
*  MERGE/CONDENSE REACTIONS 'NWT0','NWT1','NWAT0','NWAT1','SIGS'//CM,
*   'SCAT'//CM, 'NTOT0', 'NUSIGF', 'CHI', 'CHIxx', 'STRD' AND HVECT
*----
      DO 110 J=1,MAXH+NL
      HMAKE(J)=' '
  110 CONTINUE
      DO 121 J=1,MAXH
      DO 120 I=1,NGCOND
      GAS(I,J)=0.0D0
  120 CONTINUE
  121 CONTINUE
      DO 132 K=1,NL
      DO 131 J=1,NGCOND
      DO 130 I=1,NGCOND
      WSCAT(I,J,K)=0.0D0
  130 CONTINUE
  131 CONTINUE
  132 CONTINUE
      DO 140 I=1,NDEL
      WDLA(I)=0.0
  140 CONTINUE
*----
*  RECOVER THE RADIOACTIVE DECAY CONSTANTS OF DELAYED NEUTRON
*  GROUPS FROM THE MACROLIB IF THEY EXIST
*----
      LWD=.FALSE.
      IF(CURNAM.NE.' ') THEN
         CALL LCMSIX(IPEDIT,'MACROLIB',1)
         CALL LCMLEN(IPEDIT,'LAMBDA-D',ILONG,ITYLCM)
         LWD=(ILONG.EQ.NDEL).AND.(NDEL.GT.0)
         IF(LWD) CALL LCMGET(IPEDIT,'LAMBDA-D',WDLA)
         CALL LCMSIX(IPEDIT,' ',2)
      ENDIF
*
      HMAKE(1)='NWT0'
      LAWR=.FALSE.
      LDECA=.FALSE.
      LMEVF=.FALSE.
      LMEVG=.FALSE.
      DO 145 IW=1,MIN(NW+1,10)
        WRITE(HMAKE(IW),'(3HNWT,I1)') IW-1
        IF(IADJ.EQ.1) WRITE(HMAKE(1+NW+IW),'(4HNWAT,I1)') IW-1
  145 CONTINUE
      ALLOCATE(PARM12(NW+1))
      DO 260 IREGIO=1,NREGIO
      MATNUM=MATCOD(IREGIO)
      VOL=VOLUME(IREGIO)
      IF(IMERGE(IREGIO).EQ.INM) THEN
         IGRFIN=0
         DO 154 IGRCND=1,NGCOND
         IGRDEB=IGRFIN+1
         IGRFIN=IGCOND(IGRCND)
         DO 151 IGR=IGRDEB,IGRFIN
         DO 150 IW=1,NW+1
           GAS(IGRCND,IW)=GAS(IGRCND,IW)+DBLE(FLUXES(IREGIO,IGR,IW)*VOL)
           IF(IADJ.EQ.1) GAS(IGRCND,1+NW+IW)=GAS(IGRCND,1+NW+IW)+
     >     DBLE(FLUXES(IREGIO,IGR,IW)*AFLUXE(IREGIO,IGR,IW)*VOL)
  150    CONTINUE
  151    CONTINUE
         IF(IADJ.EQ.1) THEN
           DO 153 IW=1,NW+1
           GAS(IGRCND,1+NW+IW)=GAS(IGRCND,1+NW+IW)*VOLMER/GAS(IGRCND,IW)
  153      CONTINUE
         ENDIF
  154    CONTINUE
         LONE=.TRUE.
         DO 250 JSO=ISO,NBISO
         IF((ISONAM(1,ISO).EQ.ISONAM(1,JSO)).AND.
     1      (ISONAM(2,ISO).EQ.ISONAM(2,JSO)).AND.
     2      (MATNUM.EQ.MIX(JSO)).AND.(LSISO(JSO).NE.0)) THEN
            IF(LISO) THEN
              IF(ISONAM(3,ISO).EQ.ISONAM(3,JSO)) GOTO 155
              GOTO 250
            ENDIF
  155       LOGIC=.TRUE.
            ITYPS(ISO)=MAX(ITYPS(ISO),ITYPE(JSO))
            DENVOL=MAX(DEN(JSO),1.0E-20)*VOL
            DDEN=DDEN+DENVOL
            DDENZ=DDENZ+DEN(JSO)*VOL
            KPLIB=IPISO(JSO) ! set JSO-th isotope
            IF(LONE) THEN
               CALL LCMLEN(KPLIB,'AWR',LENGTH,ITYLCM)
               LAWR=(LENGTH.EQ.1)
               IF(LAWR) CALL LCMGET(KPLIB,'AWR',AWR)
               CALL LCMLEN(KPLIB,'MEVF',LENGTH,ITYLCM)
               IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVF',EMEVF(ISO))
               LMEVF=(LENGTH.EQ.1).OR.(EMEVF(ISO).GT.0.0)
               CALL LCMLEN(KPLIB,'MEVG',LENGTH,ITYLCM)
               IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'MEVG',EMEVG(ISO))
               LMEVG=(LENGTH.EQ.1).OR.(EMEVG(ISO).GT.0.0)
               CALL LCMLEN(KPLIB,'DECAY',LENGTH,ITYLCM)
               IF(LENGTH.EQ.1) CALL LCMGET(KPLIB,'DECAY',DECAY(ISO))
               LDECA=(LENGTH.EQ.1).OR.(DECAY(ISO).GT.0.0)
               LONE=.FALSE.
            ENDIF
            DO 170 IL=0,NL-1
            WRITE (CM,'(I2.2)') IL
            CALL LCMLEN(KPLIB,'SIGS'//CM,LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(KPLIB,'SIGS'//CM,GAR(1,4+3*NW+IL))
               HMAKE(4+3*NW+IL)='SIGS'//CM
            ENDIF
            CALL LCMLEN(KPLIB,'NJJS'//CM,LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(KPLIB,'NJJS'//CM,IGAR(1,1,1+IL))
               CALL LCMGET(KPLIB,'IJJS'//CM,IGAR(1,2,1+IL))
               CALL LCMGET(KPLIB,'SCAT'//CM,WGAR(1,1+IL))
               HMAKE(MAXH+1+IL)='SCAT'//CM
               IPO=0
               DO 160 IGR=1,NGROUP
               IGAR(IGR,3,1+IL)=IPO+1
               IPO=IPO+IGAR(IGR,1,1+IL)
  160          CONTINUE
            ENDIF
  170       CONTINUE
            DO IW=0,MIN(NW,9)
              WRITE(HMAKE(3+2*NW+IW),'(4HNTOT,I1)') IW
              CALL LCMLEN(KPLIB,HMAKE(3+2*NW+IW),ILONG,ITYLCM)
              IF(ILONG.NE.0) THEN
                CALL LCMGET(KPLIB,HMAKE(3+2*NW+IW),GAR(1,3+2*NW+IW))
              ELSE
                CALL LCMGET(KPLIB,'NTOT0',GAR(1,3+2*NW+IW))
              ENDIF
            ENDDO
            CALL LCMLEN(KPLIB,'NUSIGF',LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(KPLIB,'NUSIGF',GAR(1,4+NL+3*NW))
               HMAKE(4+NL+3*NW)='NUSIGF'
            ENDIF
            CALL LCMLEN(KPLIB,'CHI',LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(KPLIB,'CHI',GAR(1,1+IOF1H))
               HMAKE(1+IOF1H)='CHI'
            ENDIF
            IF(NDEL.GT.0) THEN
               WRITE(TEXT8,'(6HNUSIGF,I2.2)') NDEL
               CALL LCMLEN(KPLIB,TEXT8,LENGTH,ITYLCM)
               IF(LENGTH.EQ.NGROUP) THEN
                  DO 180 IDEL=1,NDEL
                  WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL
                  CALL LCMGET(KPLIB,TEXT8,GAR(1,IOF0H+IDEL))
                  HMAKE(IOF0H+IDEL)=TEXT8
  180             CONTINUE
               ENDIF
               WRITE(TEXT8,'(3HCHI,I2.2)') NDEL
               CALL LCMLEN(KPLIB,TEXT8,LENGTH,ITYLCM)
               IF(LENGTH.EQ.NGROUP) THEN
                  DO 184 IDEL=1,NDEL
                  WRITE(TEXT8,'(3HCHI,I2.2)') IDEL
                  CALL LCMGET(KPLIB,TEXT8,GAR(1,1+IOF1H+IDEL))
                  HMAKE(1+IOF1H+IDEL)=TEXT8
  184             CONTINUE
               ENDIF
            ENDIF
            DO 185 ISP=1,NBESP
            WRITE(TEXT8,'(5HCHI--,I2.2)') ISP
            CALL LCMLEN(KPLIB,TEXT8,LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(KPLIB,TEXT8,GAR(1,1+IOF2H+ISP))
               HMAKE(1+IOF2H+ISP)=TEXT8
            ENDIF
  185       CONTINUE
            IF(ITRANC.NE.0) THEN
               CALL LCMGET(KPLIB,'TRANC',GAR(1,7+NED+NL+3*NW))
               HMAKE(7+NED+NL+3*NW)='TRANC'
            ENDIF
            DO 186 IGR=1,NGROUP
            GAR(IGR,5+NED+NL+3*NW)=0.0
  186       CONTINUE
            CALL LCMLEN(KPLIB,'H-FACTOR',LENGTH,ITYLCM)
            IF(LENGTH.GT.0) THEN
               CALL LCMGET(KPLIB,'H-FACTOR',GAR(1,5+NED+NL+3*NW))
               HMAKE(5+NED+NL+3*NW)='H-FACTOR'
            ELSE
               IF(LMEVF) THEN
                  CALL LCMGET(KPLIB,'NFTOT',WORK)
                  HMAKE(5+NED+NL+3*NW)='H-FACTOR'
                  DO 190 IGR=1,NGROUP
                  GAR(IGR,5+NED+NL+3*NW)=GAR(IGR,5+NED+NL+3*NW)+
     1            WORK(IGR)*EMEVF(ISO)*REAL(CONV)
  190             CONTINUE
               ENDIF
               IF(LMEVG) THEN
                  CALL LCMGET(KPLIB,'NG',WORK)
                  HMAKE(5+NED+NL+3*NW)='H-FACTOR'
                  DO 195 IGR=1,NGROUP
                  GAR(IGR,5+NED+NL+3*NW)=GAR(IGR,5+NED+NL+3*NW)+
     1            WORK(IGR)*EMEVG(ISO)*REAL(CONV)
  195             CONTINUE
               ENDIF
            ENDIF
            DO 200 IED=1,NED
            IF(HVECT(IED).EQ.'H-FACTOR') GO TO 200
            CALL LCMLEN(KPLIB,HVECT(IED),LENGTH,ITYLCM)
            IF((LENGTH.GT.0).AND.(HVECT(IED).NE.'TRANC')) THEN
               CALL LCMGET(KPLIB,HVECT(IED),GAR(1,4+NL+3*NW+IED))
               HMAKE(4+NL+3*NW+IED)=HVECT(IED)
            ENDIF
  200       CONTINUE
            CALL LCMLEN(KPLIB,'OVERV',LENGTH,ITYLCM)
            IF(LENGTH.GT.0) THEN
               CALL LCMGET(KPLIB,'OVERV',GAR(1,6+NED+NL+3*NW))
            ELSE
               ALLOCATE(ENR(NGROUP+1))
               CALL LCMGET(IPLIB,'ENERGY',ENR)
               IF(ENR(NGROUP+1).EQ.0.0) ENR(NGROUP+1)=1.0E-5
               DO 205 IGR=1,NGROUP
               ENEAVG=SQRT(ENR(IGR)*ENR(IGR+1))
               GAR(IGR,6+NED+NL+3*NW)=1.0/(REAL(SQFMAS)*SQRT(ENEAVG))
  205          CONTINUE
               DEALLOCATE(ENR)
            ENDIF
            HMAKE(6+NED+NL+3*NW)='OVERV'
*
            IGRFIN=0
            DO 242 IGRCND=1,NGCOND
            IGRDEB=IGRFIN+1
            IGRFIN=IGCOND(IGRCND)
            DO 241 IGR=IGRDEB,IGRFIN
            PARM0=FLUXES(IREGIO,IGR,1)*DENVOL
            PARM3=0.0D0
            PARM4=0.0D0
            PARM12(:NW+1)=0.0D0
            IF(IADJ.EQ.0) THEN
              DO 206 IW=1,NW+1
                PARM12(IW)=FLUXES(IREGIO,IGR,IW)*DENVOL
  206         CONTINUE
              PARM3=0.0D0
              DO 210 JREGIO=1,NREGIO
              IF(IMERGE(JREGIO).EQ.INM) THEN
                PARM3=PARM3+FLUXES(JREGIO,IGR,1)*VOLUME(JREGIO)
              ENDIF
  210         CONTINUE
              PARM3=DENVOL*PARM3/VOLMER
              PARM4=DENVOL
            ELSE IF(IADJ.EQ.1) THEN
              DO 211 IW=1,NW+1
                PARM12(IW)=FLUXES(IREGIO,IGR,IW)*AFLUXE(IREGIO,IGR,IW)*
     >          DENVOL
  211         CONTINUE
              PARM3=0.0D0
              DO 212 JREGIO=1,NREGIO
              IF(IMERGE(JREGIO).EQ.INM) THEN
                PARM3=PARM3+FLUXES(JREGIO,IGR,1)*AFLUXE(JREGIO,IGR,1)*
     >          VOLUME(JREGIO)
              ENDIF
  212         CONTINUE
              PARM3=DENVOL*PARM3/VOLMER
              PARM4=AFLUXE(IREGIO,IGR,1)*DENVOL
            ENDIF
            DO 215 J=3+2*NW,MAXH
            IF(HMAKE(J).NE.' ') THEN
              IF(J.EQ.6+NED+NL+3*NW) THEN
                GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM3 ! OVERV
              ELSE IF((J.EQ.4+NL+3*NW).OR.
     >          ((J.GE.1+IOF0H).AND.(J.LE.NDEL+IOF0H))) THEN
                GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM0 ! nu*fission cross sections
              ELSE IF((J.GE.1+IOF1H).AND.(J.LE.MAXH)) THEN
                GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM4 ! fission spectrum
              ELSE IF((J.GE.4+2*NW).AND.(J.LE.3+3*NW)) THEN
                IW=J-2-2*NW                      ! NTOT1 cross sections
                GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM12(IW)
              ELSE IF((J.GE.5+3*NW).AND.(J.LE.3+NL+3*NW)) THEN
                IW=MIN(J-3-3*NW,NW+1)            ! SOGS01 cross sections
                GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM12(IW)
              ELSE IF(J.EQ.8+NED+NL+3*NW) THEN
                GO TO 215 ! STRD case
              ELSE IF(J.LE.IOF1H) THEN
                GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM12(1) ! P0 cross sections
              ENDIF
            ENDIF
  215       CONTINUE
            DO 240 IL=0,NL-1
            IF(HMAKE(MAXH+1+IL).NE.' ') THEN
*              IGRCND IS THE SECONDARY GROUP.
               IW=MIN(IL,NW)+1
               NGSCAT=IGAR(IGR,1,1+IL)
               IGSCAT=IGAR(IGR,2,1+IL)
               JGRFIN=0
               DO 230 JGRCND=1,NGCOND
               JGRDEB=JGRFIN+1
               JGRFIN=IGCOND(JGRCND)
               J2=MIN(JGRFIN,IGSCAT)
               J1=MAX(JGRDEB,IGSCAT-NGSCAT+1)
               TMP=0.0D0
               IPO=IGAR(IGR,3,1+IL)+IGSCAT-J2
               DO 220 JGR=J2,J1,-1
               IF(IADJ.EQ.0) THEN
                 TMP=TMP+WGAR(IPO,1+IL)*FLUXES(IREGIO,JGR,IW)*DENVOL
               ELSE IF(IADJ.EQ.1) THEN
                 TMP=TMP+WGAR(IPO,1+IL)*AFLUXE(IREGIO,IGR,IW)*
     >           FLUXES(IREGIO,JGR,IW)*DENVOL
               ENDIF
               IPO=IPO+1
  220          CONTINUE
               WSCAT(IGRCND,JGRCND,1+IL)=WSCAT(IGRCND,JGRCND,1+IL)+TMP
  230          CONTINUE
            ENDIF
  240       CONTINUE
  241       CONTINUE
  242       CONTINUE
            MASK(JSO)=.TRUE.
            GO TO 250
         ENDIF
  250    CONTINUE
      ENDIF
  260 CONTINUE
      DEALLOCATE(PARM12)
      IF(LOGIC) THEN
         JJISO=JJISO+1
         IF(JJISO.GT.MAXISO) CALL XABORT('EDIMIC: INSUFFICIENT ALLOCAT'
     1   //'ED SPACE FOR ISMIX, ISTYP, SDEN, VOLISO AND IHNISO.')
         IF(LISO) THEN
           WRITE(HNEW,'(3A4)') (ISONAM(I0,ISO),I0=1,3)
         ELSE
           WRITE(HNEW,'(2A4,I4.4)') (ISONAM(I0,ISO),I0=1,2),INM
         ENDIF
         READ(HNEW,'(3A4)') (IHNISO(I0,JJISO),I0=1,3)
         ISMIX(JJISO)=INM
         ISTYP(JJISO)=ISO
         SDEN(JJISO)=REAL(DDENZ/VOLMER)
         VOLISO(JJISO)=REAL(VOLMER)
         TNISO(JJISO)=TN(ISO)
         IF(IPRINT.GT.1) THEN
           WRITE (6,600) HNEW,JJISO
           WRITE(6,'(/17H NUMBER DENSITY =,1P,E12.4)') DDEN/VOLMER
         ENDIF
         IF(NDFI.GT.0) THEN
           IFI=FIPI(ISO,INM)
           IF(IFI.GT.0) THEN
             JJNDFI=JJNDFI+1
             IF(JJNDFI.GT.MAXISO) CALL XABORT('EDIMIC: JPIFI OVERFLOW.')
             JPIFI(JJNDFI)=JJISO
             IF(IPRINT.GT.1) WRITE(6,'(24H FISSILE ISOTOPE INDEX =,I5)')
     1       JJNDFI
           ENDIF
         ENDIF
*
*        UP-SCATTERING CORRECTIONS.
         IF(ILUPS.EQ.1) THEN
            DO 282 JGR=2,NGCOND
            DO 281 IGR=1,JGR-1 ! IGR < JGR
            GAS(3+2*NW,IGR)=GAS(3+2*NW,IGR)-WSCAT(IGR,JGR,1)
            GAS(3+2*NW,JGR)=GAS(3+2*NW,JGR)-WSCAT(IGR,JGR,1)
            IF((NW.GE.1).AND.(NL.GE.1)) THEN
              GAS(4+2*NW,IGR)=GAS(4+2*NW,IGR)-WSCAT(IGR,JGR,2)
              GAS(4+2*NW,JGR)=GAS(4+2*NW,JGR)-WSCAT(IGR,JGR,2)
            ENDIF
            DO 280 IL=0,NL-1
            GAS(4+3*NW+IL,IGR)=GAS(4+3*NW+IL,IGR)-WSCAT(IGR,JGR,1+IL)
            GAS(4+3*NW+IL,JGR)=GAS(4+3*NW+IL,JGR)-WSCAT(IGR,JGR,1+IL)
            WSCAT(JGR,IGR,1+IL)=WSCAT(JGR,IGR,1+IL)-WSCAT(IGR,JGR,1+IL)
            WSCAT(IGR,JGR,1+IL)=0.0D0
  280       CONTINUE
  281       CONTINUE
  282       CONTINUE
         ENDIF
*
         ALLOCATE(PHIAV(NW+1),AHIAV(NW+1))
         DO 360 IGRCND=1,NGCOND
*
*        DIVIDE MATRIX XS BY INTEGRATED FLUX
         DO 341 IL=0,NL-1
         IW=MIN(IL,NW)+1
         PHIAV(IW)=GAS(IGRCND,IW)/VOLMER
         TMP=GAS(IGRCND,4+3*NW+IL)
         DO 330 JGRCND=1,NGCOND
         IF(JGRCND.NE.IGRCND) TMP=TMP-WSCAT(JGRCND,IGRCND,1+IL)
  330    CONTINUE
         QEN=REAL(MAX(ABS(TMP),ABS(WSCAT(IGRCND,IGRCND,1+IL))))
         IF((QEN.GT.0.0).AND.(IADJ.EQ.0)) THEN
            ERR=ABS(REAL(TMP-WSCAT(IGRCND,IGRCND,1+IL)))/QEN
            IF(ERR.GT.1.0E-3) WRITE(6,620) IGRCND,IL,100.0*ERR,HNEW
            WSCAT(IGRCND,IGRCND,1+IL)=TMP
         ENDIF
         DO 340 JGRCND=1,NGCOND
         AHIAV(IW)=1.0D0
         IF(IADJ.EQ.1) AHIAV(IW)=GAS(JGRCND,1+NW+IW)/VOLMER
         IF(PHIAV(IW).GT.0.0D0) THEN
            WSCAT(JGRCND,IGRCND,1+IL)=WSCAT(JGRCND,IGRCND,1+IL)
     1      /(DDEN*AHIAV(IW)*PHIAV(IW))
         ELSE
            WSCAT(JGRCND,IGRCND,1+IL)=0.0D0
         ENDIF
  340    CONTINUE
  341    CONTINUE
*
*        DIVIDE VECTORIAL XS BY INTEGRATED FLUX
         DO 345 IW=1,NW+1
         PHIAV(IW)=GAS(IGRCND,IW)/VOLMER
         AHIAV(IW)=1.0
         IF(IADJ.EQ.1) AHIAV(IW)=GAS(IGRCND,1+NW+IW)/VOLMER
  345    CONTINUE
         DO 350 J=3+2*NW,MAXH
         IF((J.EQ.4+NL+3*NW).OR.
     >      ((J.GE.1+IOF0H).AND.(J.LE.NDEL+IOF0H))) THEN
            IF(PHIAV(1).GT.0.0D0) THEN
               GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*PHIAV(1)) ! nu*fission cross sections
            ELSE
               GAS(IGRCND,J)=0.0D0
            ENDIF
         ELSE IF((J.GE.1+IOF1H).AND.(J.LE.MAXH)) THEN
            GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(1)) ! fission spectrum
         ELSE IF((J.GE.4+2*NW).AND.(J.LE.3+3*NW)) THEN
            IW=J-2-2*NW
            IF(PHIAV(IW).NE.0.0) THEN
              GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(IW)*PHIAV(IW)) ! NTOT1 cross sections
            ELSE
              GAS(IGRCND,J)=0.0D0
            ENDIF
         ELSE IF((J.GE.5+3*NW).AND.(J.LE.3+NL+3*NW)) THEN
            IW=MIN(J-3-3*NW,NW+1)
            IF(PHIAV(IW).NE.0.0) THEN
              GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(IW)*PHIAV(IW)) ! SIGS01 cross sections
            ELSE
              GAS(IGRCND,J)=0.0D0
            ENDIF
         ELSE IF(J.EQ.8+NED+NL+3*NW) THEN
            GO TO 350 ! STRD case
         ELSE IF(PHIAV(1).GT.0.0D0) THEN
            GAS(IGRCND,J)=GAS(IGRCND,J)/(DDEN*AHIAV(1)*PHIAV(1)) ! P0 cross sections
         ELSE
            GAS(IGRCND,J)=0.0D0
         ENDIF
  350    CONTINUE
*
         IF(LSTRD) THEN
            J=8+NED+NL+3*NW
            HMAKE(J)='STRD'
            IF(NW.GE.1) THEN
               GAS(IGRCND,J)=GAS(IGRCND,4+2*NW)
            ELSE
               GAS(IGRCND,J)=GAS(IGRCND,3+2*NW)
            ENDIF
            IF((HMAKE(5+3*NW).NE.' ').AND.(NL.GE.2)) THEN
               GAS(IGRCND,J)=GAS(IGRCND,J)-GAS(IGRCND,5+3*NW)
            ENDIF
            GAS(IGRCND,J)=GAS(IGRCND,J)*WSTRD(IGRCND)
         ENDIF
  360    CONTINUE
         DEALLOCATE(AHIAV,PHIAV)
*
*        DIVIDE INTEGRATED FLUXES BY VOLUMES
         DO 366 IW=1,NW+1
         DO 365 IGRCND=1,NGCOND
         GAS(IGRCND,IW)=GAS(IGRCND,IW)/VOLMER
         IF(IADJ.EQ.1) GAS(IGRCND,NW+IW)=GAS(IGRCND,NW+IW)/VOLMER
  365    CONTINUE
  366    CONTINUE
*
         IF(CURNAM.NE.' ') THEN
            IF(NOUT.GT.0) THEN
              DO J=1,MAXH+NL
                DO IOUT=1,NOUT
                  IF(HMAKE(J).EQ.HVOUT(IOUT)) GO TO 370
                ENDDO
                HMAKE(J)=' '
  370           CONTINUE
              ENDDO
            ENDIF
            KPEDIT=LCMDIL(JPEDIT,JJISO) ! set JJISO-th isotope
            CALL LCMPTC(KPEDIT,'ALIAS',12,HNEW)
            IF(LAWR)  CALL LCMPUT(KPEDIT,'AWR',1,2,AWR)
            IF(LMEVF) CALL LCMPUT(KPEDIT,'MEVF',1,2,EMEVF(ISO))
            IF(LMEVG) CALL LCMPUT(KPEDIT,'MEVG',1,2,EMEVG(ISO))
            IF(LDECA) CALL LCMPUT(KPEDIT,'DECAY',1,2,DECAY(ISO))
            DO 380 J=1,MAXH
            IF(HMAKE(J).NE.' ') THEN
              DO 375 IGCD=1,NGCOND
                TMPXS(IGCD)=REAL(GAS(IGCD,J))
  375         CONTINUE
              CALL LCMPUT(KPEDIT,HMAKE(J),NGCOND,2,TMPXS)
            ENDIF
  380       CONTINUE
            DO 390 IL=1,NL
            ITYPRO(IL)=0
            IF(HMAKE(MAXH+IL).NE.' ') ITYPRO(IL)=1
  390       CONTINUE
            IF(ITYPRO(1).EQ.0) GO TO 405
            ALLOCATE(GA1(NL*NGCOND),GA2(NL*NGCOND*NGCOND))
            IOF1=0
            IOF2=0
            DO 402 IL=1,NL
            DO 401 IG2=1,NGCOND
            IOF1=IOF1+1
            GA1(IOF1)=REAL(GAS(IG2,3+3*NW+IL))
            DO 400 IG1=1,NGCOND
            IOF2=IOF2+1
            GA2(IOF2)=REAL(WSCAT(IG1,IG2,IL))
  400       CONTINUE
  401       CONTINUE
  402       CONTINUE
            CALL XDRLGS(KPEDIT,1,IPRINT,0,NL-1,1,NGCOND,GA1,GA2,ITYPRO)
            DEALLOCATE(GA2,GA1)
  405       IF(NDEL.NE.0) THEN
               IF(HMAKE(IOF0H+1).NE.' ') THEN
                  CALL LCMPUT(KPEDIT,'LAMBDA-D',NDEL,2,WDLA)
               ENDIF
            ENDIF
         ENDIF
         IF(IPRINT.GT.3) THEN
            DO 410 J=1,MAXH
            IF(HMAKE(J).NE.' ') THEN
               WRITE (6,610) HMAKE(J),(GAS(I,J),I=1,NGCOND)
            ENDIF
  410       CONTINUE
            WRITE (6,610) 'SIGA    ',(GAS(I,3+2*NW)-GAS(I,4+3*NW),
     >                    I=1,NGCOND)
            WRITE (6,610) 'SIGW00  ',(WSCAT(I,I,1),I=1,NGCOND)
            IF(NL.GT.1) THEN
               WRITE (6,610) 'SIGW01  ',(WSCAT(I,I,2),I=1,NGCOND)
            ENDIF
            IF(LWD) WRITE (6,610) 'LAMBDA-D',(WDLA(I),I=1,NDEL)
         ENDIF
         IF(IPRINT.GT.4) CALL LCMLIB(KPEDIT)
      ENDIF
  420 CONTINUE
  430 CONTINUE
      IF(CURNAM.NE.' ') CALL LCMSIX(IPEDIT,' ',2)
*----
*  VALIDATE FISSION YIELD DATA
*----
      IF((NDFI.GT.0).AND.(JJISO.GT.0)) THEN
        DO 470 INM=1,NMERGE
        DO 460 ISO=1,NBISO
        IF((DEN(ISO).EQ.0.0).OR.(IEVOL(ISO).EQ.1)) GO TO 460
        IF(ITYPE(ISO).EQ.2) THEN
          IF(FIPI(ISO,INM).NE.0) THEN
            ! microlib isotope ISO is a fissile isotope
            DO 450 J=1,JJNDFI
            JJSO=JPIFI(J) ! condensed isotope JJSO is a fissile isotope
            IF(JJSO.EQ.0) GO TO 450
            JSO=ISTYP(JJSO)
            IF((ISMIX(JJSO).EQ.INM).AND.(ISONAM(1,ISO).EQ.ISONAM(1,JSO))
     1         .AND.(ISONAM(2,ISO).EQ.ISONAM(2,JSO))) GO TO 460
  450       CONTINUE
            WRITE(HNAMIS,'(3A4)') (ISONAM(I0,ISO),I0=1,3)
            WRITE(HSMG,'(29HEDIMIC: THE FISSILE ISOTOPE '',A8,
     1      34H'' MUST BE SELECTED IN MICR OPTION.)') HNAMIS(:8)
            CALL XABORT(HSMG)
          ENDIF
        ENDIF
  460   CONTINUE
  470   CONTINUE
      ENDIF
*
      IF(CURNAM.NE.' ') THEN
        CALL LCMSIX(IPEDIT,CURNAM,1)
        TEXT12='L_LIBRARY'
        CALL LCMPTC(IPEDIT,'SIGNATURE',12,TEXT12)
*----
*  FIND THE MAXIMUM NUMBER OF ISOTOPES PER MIXTURE
*----
        MAXISM=0
        DO 490 INM=1,NMERGE
        MAX0=0
        DO 480 IISO=1,JJISO
        IF(ISMIX(IISO).EQ.INM) MAX0=MAX0+1
  480   CONTINUE
        MAXISM=MAX(MAXISM,MAX0)
  490   CONTINUE
*----
*  SAVE FISSION YIELD DATA
*----
        IF(NDFI.GT.0) THEN
          DO 520 INM=1,NMERGE
          DO 510 IISO=1,JJISO
          IF(ISMIX(IISO).EQ.INM) THEN
            ISO=ISTYP(IISO)
            ISOFP=FIFP(ISO,INM)
            IF(ISOFP.GT.0) THEN
              ! condensed isotope IISO is a fission fragment
              IF(ISOFP.GT.NDFP) CALL XABORT('EDIMIC: YIELD OVERFLOW.')
              KPEDIT=LCMGIL(JPEDIT,IISO) ! set IISO-th isotope
              YPIFI(:JJNDFI)=0.0
              DO 500 J=1,JJNDFI
              JJSO=JPIFI(J) ! condensed isotope JJSO is fissile
              JSO=ISTYP(JJSO)
              IFI=FIPI(JSO,INM)
              IF(IFI.GT.0) YPIFI(J)=PYIELD(IFI,ISOFP,INM)
  500         CONTINUE
              CALL LCMPUT(KPEDIT,'YIELD',NGCOND+1,2,YIELD(1,ISOFP,INM))
              IF(JJNDFI.GT.0) THEN
                CALL LCMPUT(KPEDIT,'PYIELD',JJNDFI,2,YPIFI)
                CALL LCMPUT(KPEDIT,'PIFI',JJNDFI,1,JPIFI)
              ENDIF
            ENDIF
          ENDIF
  510     CONTINUE
  520     CONTINUE
        ENDIF
*----
*  SAVE EDITION MICROLIB
*----
        IF(NED.GT.0) CALL LCMPTC(IPEDIT,'ADDXSNAME-P0',8,NED,HVECT)
        NCOMB=0
        IF(JJISO.GT.0) THEN
           CALL LCMPUT(IPEDIT,'ISOTOPESUSED',3*JJISO,3,IHNISO)
           CALL LCMPUT(IPEDIT,'ISOTOPESMIX',JJISO,1,ISMIX)
           CALL LCMPUT(IPEDIT,'ISOTOPESVOL',JJISO,2,VOLISO)
           CALL LCMPUT(IPEDIT,'ISOTOPESTEMP',JJISO,2,TNISO)
           CALL LCMPUT(IPEDIT,'ISOTOPESDENS',JJISO,2,SDEN)
           DO 550 IISO=1,JJISO
           DO 530 I0=1,3
           IHNISO(I0,IISO)=ISONRF(I0,ISTYP(IISO))
  530      CONTINUE
           ISTOD(IISO)=IEVOL(ISTYP(IISO))
           ISTYP(IISO)=ITYPS(ISTYP(IISO))
           IF((ISTOD(IISO).NE.1).AND.(ISTYP(IISO).GE.1)) THEN
              INM=ISMIX(IISO)
              IF(INM.EQ.0) GO TO 550
              DO 540 J=1,NCOMB
              IF(INM.EQ.MILVO(J)) GO TO 550
  540         CONTINUE
              NCOMB=NCOMB+1
              IF(NCOMB.GT.NMERGE) CALL XABORT('EDIMIC: MILVO OVERFLOW.')
              MILVO(NCOMB)=INM
           ENDIF
  550      CONTINUE
           CALL LCMPUT(IPEDIT,'ISOTOPERNAME',3*JJISO,3,IHNISO)
           CALL LCMPUT(IPEDIT,'ISOTOPESTODO',JJISO,1,ISTOD)
           CALL LCMPUT(IPEDIT,'ISOTOPESTYPE',JJISO,1,ISTYP)
        ENDIF
        ALLOCATE(VOLM(NMERGE))
        VOLM(:NMERGE)=0.0
        DO 560 IREGIO=1,NREGIO
        INM=IMERGE(IREGIO)
        IF(INM.GT.0) VOLM(INM)=VOLM(INM)+VOLUME(IREGIO)
  560   CONTINUE
        CALL LCMPUT(IPEDIT,'MIXTURESVOL',NMERGE,2,VOLM)
        CALL LCMPUT(IPEDIT,'K-EFFECTIVE',1,2,EIGENK)
        CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,EIGINF)
        IF(ILEAKS.GT.0) CALL LCMPUT(IPEDIT,'B2  B1HOM',1,2,B2(4))
        DEALLOCATE(VOLM)
        ALLOCATE(ENR(NGROUP+1))
        CALL LCMGET(IPLIB,'ENERGY',ENR)
        DO 570 IGRCND=1,NGCOND
        ENR(IGRCND+1)=ENR(IGCOND(IGRCND)+1)
  570   CONTINUE
        IF(ENR(NGCOND+1).EQ.0.0) ENR(NGCOND+1)=1.0E-5
        CALL LCMPUT(IPEDIT,'ENERGY',NGCOND+1,2,ENR)
        DO 580 IGRCND=1,NGCOND
        ENR(IGRCND)=LOG(ENR(IGRCND)/ENR(IGRCND+1))
  580   CONTINUE
        CALL LCMPUT(IPEDIT,'DELTAU',NGCOND,2,ENR)
        NBESP2=0
        IF(NBESP.GT.0) THEN
          IF(NBESP.GT.MAXESP) CALL XABORT('EDIMIC: MAXESP OVERFLOW.')
          CALL LCMGET(IPLIB,'CHI-ENERGY',EESP)
          EESP2(1)=ENR(1)
          IESP2(1)=0
          IIG=0
          DO IG=1,NGCOND+1
            IF(IIG.GT.NBESP) CALL XABORT('EDIMIC: BAD LIMITS FOR ENERG'
     1      //'Y-DEPENDENT FISSION SPECTRA.')
            IF(EESP(IIG+1).GE.0.999*ENR(IG)) THEN
              IIG=IIG+1
              EESP2(IIG)=ENR(IG)
              IESP2(IIG)=IG-1
            ENDIF
          ENDDO
          NBESP2=IIG-1
          IF(IPRINT.GT.3) THEN
            WRITE(6,'(/42H EDIMIC: ENERGY-DEPENDENT FISSION SPECTRA:)')
            WRITE(6,'(5X,5I12)') IESP2(:NBESP2+1)
            WRITE(6,'(5X,1P,5E12.4)') EESP2(:NBESP2+1)
          ENDIF
          CALL LCMPUT(IPEDIT,'CHI-ENERGY',NBESP2+1,2,EESP2)
          CALL LCMPUT(IPEDIT,'CHI-LIMITS',NBESP2+1,1,IESP2)
        ENDIF
        DEALLOCATE(ENR)
        IPAR(:NSTATE)=0
        IPAR(1)=NMERGE
        IPAR(2)=JJISO
        IPAR(3)=NGCOND
        IPAR(4)=NL
        IPAR(5)=ITRANC
        IF(ITRANC.NE.0) IPAR(5)=2
        IPAR(7)=1
        IPAR(11)=NDEPL
        IPAR(12)=NCOMB
        IPAR(13)=NED
        IPAR(14)=NMERGE
        IPAR(16)=NBESP2
        IPAR(18)=1
        IPAR(19)=NDEL
        IPAR(20)=JJNDFI
        IPAR(22)=MAXISM
        IPAR(25)=NW
        CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IPAR)
        IF(IPRINT.GT.3) THEN
           WRITE(6,630) IPRINT,(IPAR(I),I=1,13)
           WRITE(6,640) (IPAR(I),I=14,25)
        ENDIF
        CALL LCMSIX(IPEDIT,' ',2)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(YPIFI,JPIFI)
      DEALLOCATE(HMAKE)
      DEALLOCATE(GAS,WSCAT)
      DEALLOCATE(WORK,WDLA,TMPXS,TNISO,VOLISO,SDEN,WSTRD,DIFHET,XSECT,
     1 WGAR,GAR)
      DEALLOCATE(MASK)
      DEALLOCATE(IMERGL,ITYPS,MILVO,ITYPRO,ISTOD,ISTYP,ISMIX,IHNISO,
     1 IGAR)
      RETURN
*
  600 FORMAT (//44H CROSS SECTION OF MERGED/CONDENSED ISOTOPE ',A12,
     1 7H' (ISO=,I8,2H):)
  610 FORMAT (/11H REACTION ',A12,2H':/(1X,1P,10E12.4))
  620 FORMAT(/53H EDIMIC: *** WARNING *** NORMALIZATION OF THE WITHIN-,
     1 34HGROUP SCATTERING TRANSFER IN GROUP,I4,10H AND ORDER,I3,3H BY,
     2 F6.2,9H% ISOTOPE,2H=',A12,2H'.)
  630 FORMAT(/8H OPTIONS/8H -------/
     1 7H IPRINT,I6,30H   (0=NO PRINT/1=SHORT/2=MORE)/
     2 7H MAXMIX,I6,31H   (MAXIMUM NUMBER OF MIXTURES)/
     3 7H NBISO ,I6,36H   (NUMBER OF ISOTOPES OR MATERIALS)/
     4 7H NGRP  ,I6,28H   (NUMBER OF ENERGY GROUPS)/
     5 7H NL    ,I6,30H   (NUMBER OF LEGENDRE ORDERS)/
     6 7H ITRANC,I6,45H   (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2,
     7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/
     8 7H IPROB ,I6,23H   (0=DIRECT/1=ADJOINT)/
     9 7H ITIME ,I6,28H   (1=STEADY-STATE/2=PROMPT)/
     1 7H NLIB  ,I6,32H   (NUMBER OF SETS OF LIBRARIES)/
     2 7H NGF   ,I6,48H   (NUMBER OF FAST GROUP WITHOUT SELF-SHIELDING)/
     3 7H IGRMAX,I6,41H   (LAST GROUP INDEX WITH SELF-SHIELDING)/
     4 7H NDEPL ,I6,33H   (NUMBER OF DEPLETING ISOTOPES)/
     5 7H NCOMB ,I6,33H   (NUMBER OF DEPLETING MIXTURES)/
     6 7H NEDMAC,I6,34H   (NUMBER OF CROSS SECTION EDITS))
  640 FORMAT(7H NBMIX ,I6,23H   (NUMBER OF MIXTURES)/
     1 7H NRES  ,I6,40H   (NUMBER OF SETS OF RESONANT MIXTURES)/
     2 7H NBESP ,I6,47H   (NUMBER OF ENERGY-DEPENDENT FISSION SPECTRA)/
     3 7H IPROC ,I6,48H   (-1=SKIP LIBRARY PROCESSING/0=DILUTION INTERP,
     4 48HOLATION/1=USE PHYSICAL TABLES/2=BUILD A DRAGLIB/,
     5 55H3=COMPUTE CALENDF TABLES/4=COMPUTE SLOWING-DOWN TABLES)/
     6 7H IMAC  ,I6,45H   (0=DO NOT/1=DO BUILD AN EMBEDDED MACROLIB)/
     7 7H NDEL  ,I6,31H   (NUMBER OF PRECURSOR GROUPS)/
     8 7H NFISS ,I6,43H   (NUMBER OF FISSILE ISOTOPES IN MICROLIB)/
     9 7H ISOADD,I6,37H   (0=COMPLETE BURNUP CHAIN/1=DO NOT)/
     1 7H MAXISM,I6,40H   (MAX. NUMBER OF ISOTOPES PER MIXTURE)/
     2 7H IPRECI,I6,34H   (CALENDF ACCURACY FLAG:1/2/3/4)/
     3 7H IADF  ,I6,19H   (ADF FLAG:0/1/2)/
     4 7H NW    ,I6,47H   (=0: FLUX WEIGHTING FOR P1 INFO; =1: CURRENT,
     5 23H WEIGHTING FOR P1 INFO))
      END