*DECK EDIMIC
      SUBROUTINE EDIMIC(IPEDIT,IPFLUX,IPLIB,NL,NDEL,NBISO,NDEPL,ISONAM,
     1 ISONRF,MIX,TN,NED,HVECT,IPRINT,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,
     2 NDFI,ILEAKS,ILUPS,NWGTH,MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,
     3 IMERGE,FLUXES,EIGENK,B2,SPH,DEN,ITYPE,IEVOL,LSISO,EMEVF,EMEVG,
     4 DECAY,YIELD,IPIFI,PYIELD,ITRANC,LISO)
*
*-----------------------------------------------------------------------
*
*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).
* NL      number of Legendre orders required in the calculation
*         (NL=1 or higher).
* NDEL    number of delayed precursor groups.
* 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.
* 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.
* 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.
* 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).
* NWGTH   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 (=' ' for no save).
* IGCOND  limits of condensed groups.
* IMERGE  index of merged regions.
* FLUXES  fluxes.
* EIGENK  effective multiplication factor.
* B2      bucklings.
* SPH     SPH homogenization factors.
* DEN     number density of each isotope.
* ITYPE   type of each isotope.
* IEVOL   flag making an isotope non-depleting:
*         =1 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.
* IPIFI   isotope index associated to each fissile isotope of IPLIB.
* 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.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPEDIT,IPFLUX,IPLIB
      INTEGER   NL,NDEL,NBISO,NDEPL,ISONAM(3,NBISO),ISONRF(3,NBISO),
     1          MIX(NBISO),NED,IPRINT,NGROUP,NGCOND,NBMIX,NREGIO,
     2          NMERGE,NDFI,ILEAKS,ILUPS,NWGTH,MATCOD(NREGIO),
     3          KEYFLX(NREGIO),IGCOND(NGCOND),IMERGE(NREGIO),
     4          ITYPE(NBISO),IEVOL(NBISO),LSISO(NBISO),
     5          IPIFI(NDFI,NMERGE),ITRANC
      REAL      TN(NBISO),VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NWGTH+1),
     1          EIGENK,B2(4),SPH(NMERGE,NGCOND,NWGTH+1),DEN(NBISO),
     2          EMEVF(NBISO),EMEVG(NBISO),DECAY(NBISO),
     3          YIELD(NGCOND+1,NBISO,NMERGE),PYIELD(NDFI,NBISO,NMERGE)
      CHARACTER HVECT(NED)*(*),CURNAM*(*)
      LOGICAL   LISO
*----
*  LOCAL VARIABLES
*----
      PARAMETER (NSTATE=40)
      TYPE(C_PTR) JPLIB,KPLIB,JPFLUX
      LOGICAL    LOGIC,LSTRD,LAWR,LMEVF,LMEVG,LDECA,LWD,LFIS,LONE
      CHARACTER  CM*2,HNEW*12,HMAKE(100)*12,TEXT12*12,HSMG*131,
     1           HNAMIS*12
      INTEGER    IPAR(NSTATE)
      REAL       B2T(3)
      DOUBLE PRECISION TMP,TMP2,PARM1,PARM2,PARM3,VOLMER,DDEN,DDENZ,
     1           SQFMAS,XDRCST,NMASS,EVJ,CONV
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ISMIX,ISTYP,ISTOD,ITYPRO,
     1 JPIFI,MILVO
      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
      REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR,WGAR
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: GAS
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT
*----
*  SCRATCH STORAGE ALLOCATION
*----
*
* GAR/GAS CONTENTS:
*            1 : 'NWT0'
*            2 : 'NWT1'
*            3 : 'SIGS00' |
*            4 : 'SIGS01' | NL VALUES
*  ...                    |
*         3+NL : 'NTOT0'
*         4+NL : 'NTOT1'
*         5+NL : 'NUSIGF'
*         6+NL : HVECT(1) |
*         7+NL : HVECT(2) | NED VALUES
*  ...                    |
*  MAXH-2*NDEL-4 : 'H-FACTOR'
*  MAXH-2*NDEL-3 : 'OVERV'
*  MAXH-2*NDEL-2 : 'TRANC'
*  MAXH-2*NDEL-1 : 'NUSIGF01' |
*  MAXH-2*NDEL   : 'NUSIGF02' |
*  MAXH-2*NDEL+1 : 'NUSIGF03' | NDEL VALUES
*  MAXH-2*NDEL+2 : 'NUSIGF04' |
*  ...                        |
*  MAXH-NDEL-1 : 'CHI'
*    MAXH-NDEL : 'CHI01' |
*  MAXH-NDEL+1 : 'CHI02' |
*  MAXH-NDEL+2 : 'CHI03' | NDEL VALUES
*  MAXH-NDEL+3 : 'CHI04' |
*  ...                   |
*         MAXH : 'STRD'
*
      ALLOCATE(IGAR(NGROUP,3,NL),IHNISO(3,NBISO*NMERGE),
     1 ISMIX(NBISO*NMERGE),ISTYP(NBISO*NMERGE),ISTOD(NBISO*NMERGE),
     2 ITYPRO(NL),JPIFI(NDFI),MILVO(NMERGE))
      ALLOCATE(MASK(NBISO))
      ALLOCATE(GAR(NGROUP,10+NL+NED+2*NDEL),WGAR(NGROUP**2,NL),
     1 XSECT(0:NBMIX),WSTRD(NGCOND),SDEN(NBISO*NMERGE),
     2 VOLISO(NBISO*NMERGE),TNISO(NBISO*NMERGE),TMPXS(NGCOND),
     3 WDLA(NDEL),WORK(NGROUP))
      ALLOCATE(WSCAT(NGCOND,NGCOND,NL),GAS(NGCOND,10+NL+NED+2*NDEL))
*----
*  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)
*
      DO 10 ISO=1,NBISO*NMERGE
      SDEN(ISO)=0.0
   10 VOLISO(ISO)=0.0
      MAXH=10+NL+NED+2*NDEL
      IF(MAXH+NL.GT.100) CALL XABORT('EDIMIC: STATIC STORAGE EXCEEDED')
      JJISO=0
      IF(IPRINT.GT.4) THEN
        WRITE(6,'(/34H EDIMIC: MERGING FLAG PER ISOTOPE:/(1X,20I6))')
     1  (LSISO(I),I=1,NBISO)
      ENDIF
      CONV=1.0D6*XDRCST('eV','J')
      DO 440 INM=1,NMERGE
*----
*  PRELIMINARY CALCULATIONS FOR STRD CROSS SECTIONS
*----
      LSTRD=ILEAKS.GE.1
      IF(LSTRD) THEN
         IF(ILEAKS.EQ.1) THEN
            CALL LCMGET(IPFLUX,'DIFFB1HOM',GAR(1,1))
         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.0
         ZDEN=0.0
         ZFL1=0.0
         ZFL2=0.0
         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
         DO 20 IREGIO=1,NREGIO
         MATNUM=MATCOD(IREGIO)
         IF(IMERGE(IREGIO).EQ.INM) THEN
            VOLREG=VOLUME(IREGIO)
            IF(NWGTH.EQ.0) THEN
               ZLEAK=0.0
               IF(ILEAKS.EQ.1) THEN
                  ZLEAK=GAR(IGR,1)*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)*FLUXES(IREGIO,IGR,1)*VOLREG
               ZFL1=ZFL1+FLUXES(IREGIO,IGR,1)*VOLREG
               ZFL2=ZFL2+FLUXES(IREGIO,IGR,1)*VOLREG
            ELSE
               ZNU=ZNU+FLUXES(IREGIO,IGR,2)*VOLREG
               ZDEN=ZDEN+XSECT(MATNUM)*FLUXES(IREGIO,IGR,2)*VOLREG
               ZFL1=ZFL1+FLUXES(IREGIO,IGR,1)*VOLREG
               ZFL2=ZFL2+FLUXES(IREGIO,IGR,2)*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(NWGTH.EQ.0) THEN
                  ZDEN=ZDEN-XSECT(MATNUM)*FLUXES(IREGIO,IGR,1)*VOLREG
               ELSE
                  ZDEN=ZDEN-XSECT(MATNUM)*FLUXES(IREGIO,IGR,2)*VOLREG
               ENDIF
            ENDIF
   30       CONTINUE
         ENDIF
   40    CONTINUE
         CALL LCMSIX(IPLIB,' ',2)
         ZFL1=ZFL1/SPH(INM,IGRCND,1)
         ZFL2=ZFL2/SPH(INM,IGRCND,1)
   50    WSTRD(IGRCND)=(ZFL1/(3.0*ZNU))*ZFL2/ZDEN
      ENDIF
*
      VOLMER=0.0D0
      DO 60 IREGIO=1,NREGIO
      IF(IMERGE(IREGIO).EQ.INM) VOLMER=VOLMER+VOLUME(IREGIO)
   60 CONTINUE
      CALL XDISET(JPIFI,NDFI,0)
      CALL XDLSET(MASK,NBISO,.FALSE.)
      LFIS=.FALSE.
      DO 420 ISO=1,NBISO
      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','SIGS'//CM, 'SCAT'//CM,
*  'NTOT0', 'NUSIGF', 'CHI', 'CHIxx', 'STRD' AND HVECT
*----
      DO 110 J=1,MAXH+NL
  110 HMAKE(J)=' '
      DO 120 J=1,MAXH
      DO 120 I=1,NGCOND
  120 GAS(I,J)=0.0D0
      DO 130 K=1,NL
      DO 130 J=1,NGCOND
      DO 130 I=1,NGCOND
  130 WSCAT(I,J,K)=0.0D0
      DO 140 I=1,NDEL
  140 WDLA(I)=0.0
*----
*  RECOVER THE RADIOACTIVE DECAY CONSTANTS OF DELAYED NEUTRON
*  GROUPS FROM THE MACROLIB IF THEY EXIST
*----
      LWD=.FALSE.
      IF(CURNAM.NE.' ') THEN
         CALL LCMSIX(IPEDIT,CURNAM,1)
         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)
         CALL LCMSIX(IPEDIT,' ',2)
      ENDIF
*
      HMAKE(1)='NWT0'
      LAWR=.FALSE.
      LDECA=.FALSE.
      LMEVF=.FALSE.
      LMEVG=.FALSE.
      IF(NWGTH.GE.1) HMAKE(2)='NWT1'
      DO 260 IREGIO=1,NREGIO
      MATNUM=MATCOD(IREGIO)
      VOL=VOLUME(IREGIO)
      IF(IMERGE(IREGIO).EQ.INM) THEN
         IGRFIN=0
         DO 150 IGRCND=1,NGCOND
         IGRDEB=IGRFIN+1
         IGRFIN=IGCOND(IGRCND)
         DO 150 IGR=IGRDEB,IGRFIN
         GAS(IGRCND,1)=GAS(IGRCND,1)+DBLE(FLUXES(IREGIO,IGR,1)*VOL)
         IF(NWGTH.GE.1) THEN
            GAS(IGRCND,2)=GAS(IGRCND,2)+DBLE(FLUXES(IREGIO,IGR,2)*VOL)
         ENDIF
  150    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.
            DENJSO=MAX(DEN(JSO),1.0E-20)
            DDEN=DDEN+DENJSO*VOL
            DDENZ=DDENZ+DEN(JSO)*VOL
            WRITE(HNAMIS,'(3A4)') (ISONAM(I0,JSO),I0=1,3)
            CALL LCMSIX(IPLIB,HNAMIS,1)
            IF(LONE) THEN
               CALL LCMLEN(IPLIB,'AWR',LENGTH,ITYLCM)
               LAWR=(LENGTH.EQ.1)
               IF(LAWR) CALL LCMGET(IPLIB,'AWR',AWR)
               CALL LCMLEN(IPLIB,'MEVF',LENGTH,ITYLCM)
               IF(LENGTH.EQ.1) CALL LCMGET(IPLIB,'MEVF',EMEVF(ISO))
               LMEVF=(LENGTH.EQ.1).OR.(EMEVF(ISO).GT.0.0)
               CALL LCMLEN(IPLIB,'MEVG',LENGTH,ITYLCM)
               IF(LENGTH.EQ.1) CALL LCMGET(IPLIB,'MEVG',EMEVG(ISO))
               LMEVG=(LENGTH.EQ.1).OR.(EMEVG(ISO).GT.0.0)
               CALL LCMLEN(IPLIB,'DECAY',LENGTH,ITYLCM)
               IF(LENGTH.EQ.1) CALL LCMGET(IPLIB,'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(IPLIB,'SIGS'//CM,LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(IPLIB,'SIGS'//CM,GAR(1,3+IL))
               HMAKE(3+IL)='SIGS'//CM
            ENDIF
            CALL LCMLEN(IPLIB,'NJJS'//CM,LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(IPLIB,'NJJS'//CM,IGAR(1,1,1+IL))
               CALL LCMGET(IPLIB,'IJJS'//CM,IGAR(1,2,1+IL))
               CALL LCMGET(IPLIB,'SCAT'//CM,WGAR(1,1+IL))
               HMAKE(MAXH+1+IL)=CM
               IPO=0
               DO 160 IGR=1,NGROUP
               IGAR(IGR,3,1+IL)=IPO+1
  160          IPO=IPO+IGAR(IGR,1,1+IL)
            ENDIF
  170       CONTINUE
            CALL LCMGET(IPLIB,'NTOT0',GAR(1,3+NL))
            HMAKE(3+NL)='NTOT0'
            IF(NWGTH.GE.1) THEN
               CALL LCMLEN(IPLIB,'NTOT1',ILONG,ITYLCM)
               IF(ILONG.NE.0) THEN
                  CALL LCMGET(IPLIB,'NTOT1',GAR(1,4+NL))
               ELSE
                  CALL LCMGET(IPLIB,'NTOT0',GAR(1,4+NL))
               ENDIF
               HMAKE(4+NL)='NTOT1'
            ENDIF
            CALL LCMLEN(IPLIB,'NUSIGF',LENGTH,ITYLCM)
            IF(LENGTH.EQ.NGROUP) THEN
               CALL LCMGET(IPLIB,'NUSIGF',GAR(1,5+NL))
               HMAKE(5+NL)='NUSIGF'
               CALL LCMGET(IPLIB,'CHI',GAR(1,MAXH-NDEL-1))
               HMAKE(MAXH-NDEL-1)='CHI'
            ENDIF
            IF(NDEL.GT.0) THEN
               WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL
               CALL LCMLEN(IPLIB,TEXT12,LENGTH,ITYLCM)
               IF(LENGTH.EQ.NGROUP) THEN
                  DO 180 IDEL=1,NDEL
                  WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
                  CALL LCMGET(IPLIB,TEXT12,GAR(1,MAXH-2*NDEL-2+IDEL))
  180             HMAKE(MAXH-2*NDEL-2+IDEL)=TEXT12
               ENDIF
               WRITE(TEXT12,'(3HCHI,I2.2)') NDEL
               CALL LCMLEN(IPLIB,TEXT12,LENGTH,ITYLCM)
               IF(LENGTH.EQ.NGROUP) THEN
                  DO 185 IDEL=1,NDEL
                  WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
                  CALL LCMGET(IPLIB,TEXT12,GAR(1,MAXH-NDEL-1+IDEL))
  185             HMAKE(MAXH-NDEL-1+IDEL)=TEXT12
               ENDIF
            ENDIF
            IF(ITRANC.NE.0) THEN
               CALL LCMGET(IPLIB,'TRANC',GAR(1,MAXH-2*NDEL-2))
               HMAKE(MAXH-2*NDEL-2)='TRANC'
            ENDIF
            DO 186 IGR=1,NGROUP
  186       GAR(IGR,MAXH-2*NDEL-4)=0.0
            IF(LMEVF) THEN
               CALL LCMGET(IPLIB,'NFTOT',WORK)
               HMAKE(MAXH-2*NDEL-4)='H-FACTOR'
               DO 190 IGR=1,NGROUP
  190          GAR(IGR,MAXH-2*NDEL-4)=GAR(IGR,MAXH-2*NDEL-4)+WORK(IGR)*
     1         EMEVF(ISO)*REAL(CONV)
            ENDIF
            IF(LMEVG) THEN
               CALL LCMGET(IPLIB,'NG',WORK)
               HMAKE(MAXH-2*NDEL-4)='H-FACTOR'
               DO 195 IGR=1,NGROUP
  195          GAR(IGR,MAXH-2*NDEL-4)=GAR(IGR,MAXH-2*NDEL-4)+WORK(IGR)*
     1         EMEVG(ISO)*REAL(CONV)
            ENDIF
            DO 200 IED=1,NED
            CALL LCMLEN(IPLIB,HVECT(IED),LENGTH,ITYLCM)
            IF((LENGTH.GT.0).AND.(HVECT(IED).NE.'TRANC')) THEN
               CALL LCMGET(IPLIB,HVECT(IED),GAR(1,5+NL+IED))
               HMAKE(5+NL+IED)=HVECT(IED)
            ENDIF
  200       CONTINUE
            CALL LCMSIX(IPLIB,' ',2)
            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))
  205       GAR(IGR,MAXH-2*NDEL-3)=1.0/(REAL(SQFMAS)*SQRT(ENEAVG))
            DEALLOCATE(ENR)
            HMAKE(MAXH-2*NDEL-3)='OVERV'
*
            IW=MIN(1,NWGTH)+1
            IGRFIN=0
            DO 240 IGRCND=1,NGCOND
            IGRDEB=IGRFIN+1
            IGRFIN=IGCOND(IGRCND)
            DO 240 IGR=IGRDEB,IGRFIN
            PARM1=FLUXES(IREGIO,IGR,1)*DENJSO*VOL
            PARM2=FLUXES(IREGIO,IGR,IW)*DENJSO*VOL
            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=DENJSO*VOL*PARM3/VOLMER
            DO 215 J=3,MAXH-NDEL-2
            IF(HMAKE(J).NE.' ') THEN
               IF(J.EQ.MAXH-2*NDEL-3) THEN
                  GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM3
               ELSE IF((J.EQ.4+NL).OR.((J.GE.4).AND.(J.LE.2+NL))) THEN
                  GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM2
               ELSE
                  GAS(IGRCND,J)=GAS(IGRCND,J)+DBLE(GAR(IGR,J))*PARM1
               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,NWGTH)+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
               TMP=TMP+WGAR(IPO,1+IL)*FLUXES(IREGIO,JGR,IW)*DENJSO*VOL
  220          IPO=IPO+1
  230          WSCAT(IGRCND,JGRCND,1+IL)=WSCAT(IGRCND,JGRCND,1+IL)+TMP
            ENDIF
  240       CONTINUE
            MASK(JSO)=.TRUE.
            GO TO 250
         ENDIF
  250    CONTINUE
      ENDIF
  260 CONTINUE
      IF(LOGIC) THEN
         JJISO=JJISO+1
         IF(JJISO.GT.NBISO*NMERGE) CALL XABORT('EDIMIC: INSUFFICIENT A'
     1   //'LLOCATED SPACE FOR ISMIX, ISTYP, SDEN, VOLISO AND IHNISO.')
         IF(LISO) THEN
           WRITE(HNEW,'(3A4)') (ISONAM(I0,ISO),I0=1,3)
           READ(HNEW,'(3A4)') (IHNISO(I0,JJISO),I0=1,3)
         ELSE
           WRITE(HNEW,'(2A4,I4.4)') (ISONAM(I0,ISO),I0=1,2),INM
           READ(HNEW,'(3A4)') (IHNISO(I0,JJISO),I0=1,3)
         ENDIF
         ISMIX(JJISO)=INM
         ISTYP(JJISO)=ISO
         SDEN(JJISO)=REAL(DDENZ/VOLMER)
         VOLISO(JJISO)=REAL(VOLMER)
         TNISO(JJISO)=TN(ISO)
         DO 270 I=1,NDFI
         IF(IPIFI(I,INM).EQ.0) GO TO 270
         IF((ISONAM(1,IPIFI(I,INM)).EQ.ISONAM(1,ISO)).AND.
     1      (ISONAM(2,IPIFI(I,INM)).EQ.ISONAM(2,ISO))) JPIFI(I)=JJISO
  270    CONTINUE
         LFIS=LFIS.OR.(ITYPE(ISO).EQ.2)
*
*        UP-SCATTERING CORRECTIONS.
         IF(IPRINT.GT.1) THEN
            WRITE (6,600) HNEW
            WRITE(6,'(/17H NUMBER DENSITY =,1P,E12.4)') DDEN/VOLMER
         ENDIF
         IF(ILUPS.EQ.1) THEN
            DO 280 JGR=2,NGCOND
            DO 280 IGR=1,JGR-1
            DO 280 IL=0,NL-1
            WSCAT(JGR,IGR,1+IL)=WSCAT(JGR,IGR,1+IL)-WSCAT(IGR,JGR,1+IL)
  280       WSCAT(IGR,JGR,1+IL)=0.0D0
         ENDIF
*
*        PROMPT/DELAYED FISSION SPECTRUM CONDENSATION AND NORMALIZATION.
         DO 320 IDEL=0,NDEL
         IOFSET=MAXH-NDEL-1+IDEL
         IF(HMAKE(IOFSET).NE.' ') THEN
            TMP2=0.0D0
            DO 290 IGR=1,NGROUP
  290       TMP2=TMP2+GAR(IGR,IOFSET)
            IGRFIN=0
            DO 310 IGRCND=1,NGCOND
            IGRDEB=IGRFIN+1
            IGRFIN=IGCOND(IGRCND)
            DO 300 IGR=IGRDEB,IGRFIN
  300       GAS(IGRCND,IOFSET)=GAS(IGRCND,IOFSET)+DBLE(GAR(IGR,IOFSET))
            IF(TMP2.GT.0.9D0) GAS(IGRCND,IOFSET)=GAS(IGRCND,IOFSET)/TMP2
  310       CONTINUE
         ENDIF
  320    CONTINUE
*
         DO 360 IGRCND=1,NGCOND
         GAS(IGRCND,1)=GAS(IGRCND,1)/DBLE(SPH(INM,IGRCND,1))
         IF(NWGTH.GE.1) THEN
            GAS(IGRCND,2)=GAS(IGRCND,2)/DBLE(SPH(INM,IGRCND,2))
         ENDIF
         DO 340 IL=0,NL-1
         IW=MIN(IL,NWGTH,1)+1
         TMP=GAS(IGRCND,3+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) 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
         IF(GAS(IGRCND,IW).GT.0.0D0) THEN
            WSCAT(JGRCND,IGRCND,1+IL)=WSCAT(JGRCND,IGRCND,1+IL)
     1      *VOLMER/DDEN/GAS(IGRCND,IW)
         ELSE
            WSCAT(JGRCND,IGRCND,1+IL)=0.0D0
         ENDIF
  340    CONTINUE
         DO 350 J=3,MAXH-NDEL-2
         IF(((J.EQ.4+NL).OR.((J.GE.4).AND.(J.LE.2+NL))).AND.
     1   (GAS(IGRCND,2).GT.0.0D0)) THEN
            GAS(IGRCND,J)=GAS(IGRCND,J)*VOLMER/DDEN/GAS(IGRCND,2)
         ELSE IF(GAS(IGRCND,1).GT.0.0D0) THEN
            GAS(IGRCND,J)=GAS(IGRCND,J)*VOLMER/DDEN/GAS(IGRCND,1)
         ELSE
            GAS(IGRCND,J)=0.0D0
         ENDIF
  350    CONTINUE
         IF(LSTRD) THEN
            HMAKE(MAXH)='STRD'
            IF(NWGTH.GE.1) THEN
               GAS(IGRCND,MAXH)=GAS(IGRCND,4+NL)
            ELSE
               GAS(IGRCND,MAXH)=GAS(IGRCND,3+NL)
            ENDIF
            IF((HMAKE(4).NE.' ').AND.(NL.GE.2)) THEN
               GAS(IGRCND,MAXH)=GAS(IGRCND,MAXH)-GAS(IGRCND,4)
            ENDIF
            GAS(IGRCND,MAXH)=GAS(IGRCND,MAXH)*WSTRD(IGRCND)
         ENDIF
         GAS(IGRCND,1)=GAS(IGRCND,1)/VOLMER
         IF(NWGTH.GE.1) GAS(IGRCND,2)=GAS(IGRCND,2)/VOLMER
  360    CONTINUE
         IF(CURNAM.NE.' ') THEN
            CALL LCMSIX(IPEDIT,CURNAM,1)
            CALL LCMSIX(IPEDIT,HNEW,1)
            IF(LAWR)  CALL LCMPUT(IPEDIT,'AWR',1,2,AWR)
            IF(LMEVF) CALL LCMPUT(IPEDIT,'MEVF',1,2,EMEVF(ISO))
            IF(LMEVG) CALL LCMPUT(IPEDIT,'MEVG',1,2,EMEVG(ISO))
            IF(LDECA) CALL LCMPUT(IPEDIT,'DECAY',1,2,DECAY(ISO))
            DO 380 J=1,MAXH
            IF(HMAKE(J).NE.' ') THEN
              DO 370 IGCD=1,NGCOND
                TMPXS(IGCD)=REAL(GAS(IGCD,J))
  370         CONTINUE
              CALL LCMPUT(IPEDIT,HMAKE(J),NGCOND,2,TMPXS)
            ENDIF
  380       CONTINUE
            DO 390 IL=1,NL
            ITYPRO(IL)=0
            IF(HMAKE(MAXH+IL+1).NE.' ') ITYPRO(IL)=1
  390       CONTINUE
            ALLOCATE(GA1(NL*NGCOND),GA2(NL*NGCOND*NGCOND))
            IOF1=0
            IOF2=0
            DO 400 IL=1,NL
            DO 400 IG2=1,NGCOND
            IOF1=IOF1+1
            GA1(IOF1)=REAL(GAS(IG2,2+IL))
            DO 400 IG1=1,NGCOND
            IOF2=IOF2+1
  400       GA2(IOF2)=REAL(WSCAT(IG1,IG2,IL))
            CALL XDRLGS(IPEDIT,1,IPRINT,0,NL-1,1,NGCOND,GA1,GA2,ITYPRO)
            DEALLOCATE(GA2,GA1)
            IF(NDEL.NE.0) THEN
               IF(HMAKE(MAXH-2*NDEL-2+NDEL).NE.' ') THEN
                  CALL LCMPUT(IPEDIT,'LAMBDA-D',NDEL,2,WDLA)
               ENDIF
            ENDIF
            CALL LCMSIX(IPEDIT,' ',2)
            CALL LCMSIX(IPEDIT,' ',2)
         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+NL)-GAS(I,3),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
      ENDIF
  420 CONTINUE
*----
*  SAVE FISSION YIELD DATA
*----
      LFIS=LFIS.AND.(NDFI.GT.0).AND.(JJISO.GT.0)
      IF((CURNAM.NE.' ').AND.LFIS) THEN
         DO 425 I=1,NDFI
         IF((JPIFI(I).EQ.0).AND.(IPIFI(I,INM).NE.0)) THEN
            ISO=IPIFI(I,INM)
            IF(DEN(ISO).EQ.0.0) GO TO 425
            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
  425    CONTINUE
         CALL LCMSIX(IPEDIT,CURNAM,1)
         DO 430 JSO=1,JJISO
         IF(ISMIX(JSO).EQ.INM) THEN
            ISO=ISTYP(JSO)
            WRITE(HNEW,'(3A4)') (IHNISO(I0,JSO),I0=1,3)
            CALL LCMSIX(IPEDIT,HNEW,1)
            IF(YIELD(1,ISO,INM).GT.0.0) THEN
               CALL LCMPUT(IPEDIT,'YIELD',NGCOND+1,2,YIELD(1,ISO,INM))
               CALL LCMPUT(IPEDIT,'PYIELD',NDFI,2,PYIELD(1,ISO,INM))
               CALL LCMPUT(IPEDIT,'PIFI',NDFI,1,JPIFI)
            ENDIF
            CALL LCMSIX(IPEDIT,' ',2)
         ENDIF
  430    CONTINUE
         CALL LCMSIX(IPEDIT,' ',2)
      ENDIF
  440 CONTINUE
*
      IF(CURNAM.NE.' ') THEN
        CALL LCMSIX(IPEDIT,CURNAM,1)
        TEXT12='L_LIBRARY'
        CALL LCMPTC(IPEDIT,'SIGNATURE',12,1,TEXT12)
        MAXISM=0
        DO 460 IBM=1,NMERGE
        MAX0=0
        DO 450 ISO=1,JJISO
        IF(ISMIX(ISO).EQ.IBM) MAX0=MAX0+1
  450   CONTINUE
  460   MAXISM=MAX(MAXISM,MAX0)
        IF(NED.GT.0) THEN
           CALL LCMPTC(IPEDIT,'ADDXSNAME-P0',8,NED,HVECT)
        ENDIF
        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 500 IISO=1,JJISO
           DO 480 I0=1,3
  480      IHNISO(I0,IISO)=ISONRF(I0,ISTYP(IISO))
           ISTOD(IISO)=IEVOL(ISTYP(IISO))
           ISTYP(IISO)=ITYPE(ISTYP(IISO))
           IF((ISTOD(IISO).NE.1).AND.(ISTYP(IISO).GE.1)) THEN
              IBM=ISMIX(IISO)
              IF(IBM.EQ.0) GO TO 500
              DO 490 J=1,NCOMB
              IF(IBM.EQ.MILVO(J)) GO TO 500
  490         CONTINUE
              NCOMB=NCOMB+1
              IF(NCOMB.GT.NMERGE) CALL XABORT('EDIMIC: MILVO OVERFLOW.')
              MILVO(NCOMB)=IBM
           ENDIF
  500      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))
        CALL XDRSET(VOLM,NMERGE,0.0)
        DO 510 IREGIO=1,NREGIO
        INM=IMERGE(IREGIO)
        IF(INM.GT.0) VOLM(INM)=VOLM(INM)+VOLUME(IREGIO)
  510   CONTINUE
        CALL LCMPUT(IPEDIT,'MIXTURESVOL',NMERGE,2,VOLM)
        CALL LCMPUT(IPEDIT,'K-EFFECTIVE',1,2,EIGENK)
        IF(ILEAKS.GT.0) CALL LCMPUT(IPEDIT,'B2  B1HOM',1,2,B2(4))
        DEALLOCATE(VOLM)
        CALL XDISET(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(18)=1
        IPAR(19)=NDEL
        IPAR(20)=NDFI
        IPAR(22)=MAXISM
        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,15),(IPAR(I),I=17,23)
        ENDIF
        ALLOCATE(ENR(NGROUP+1))
        CALL LCMGET(IPLIB,'ENERGY',ENR)
        DO 520 IGRCND=1,NGCOND
  520   ENR(IGRCND+1)=ENR(IGCOND(IGRCND)+1)
        IF(ENR(NGCOND+1).EQ.0.0) ENR(NGCOND+1)=1.0E-5
        CALL LCMPUT(IPEDIT,'ENERGY',NGCOND+1,2,ENR)
        DO 530 IGRCND=1,NGCOND
  530   ENR(IGRCND)=LOG(ENR(IGRCND)/ENR(IGRCND+1))
        CALL LCMPUT(IPEDIT,'DELTAU',NGCOND,2,ENR)
        DEALLOCATE(ENR)
*
        CALL LCMSIX(IPEDIT,' ',2)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(GAS,WSCAT)
      DEALLOCATE(WORK,WDLA,TMPXS,TNISO,VOLISO,SDEN,WSTRD,XSECT,WGAR,GAR)
      DEALLOCATE(MASK)
      DEALLOCATE(MILVO,JPIFI,ITYPRO,ISTOD,ISTYP,ISMIX,IHNISO,IGAR)
      RETURN
*
  600 FORMAT (//44H CROSS SECTION OF MERGED/CONDENSED ISOTOPE ',A12,
     1 2H':)
  610 FORMAT (/11H REACTION ',A12,2H':/(1X,1P,10E12.4))
  620 FORMAT(/52H *** WARNING *** NORMALIZATION OF THE WITHIN-GROUP S,
     1 27HCATTERING TRANSFER IN GROUP,I4,10H AND ORDER,I3,3H BY,F6.2,
     2 11H% ISOTOPE=',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 IPROC ,I6,48H   (-1=SKIP LIBRARY PROCESSING/0=DILUTION INTERP,
     3 48HOLATION/1=USE PHYSICAL TABLES/2=BUILD A DRAGLIB/,
     4 55H3=COMPUTE CALENDF TABLES/4=COMPUTE SLOWING-DOWN TABLES)/
     5 7H IMAC  ,I6,45H   (0=DO NOT/1=DO BUILD AN EMBEDDED MACROLIB)/
     6 7H NDEL  ,I6,31H   (NUMBER OF PRECURSOR GROUPS)/
     7 7H NFISS ,I6,31H   (NUMBER OF FISSILE ISOTOPES)/
     8 7H ISOADD,I6,37H   (0=COMPLETE BURNUP CHAIN/1=DO NOT)/
     9 7H MAXISM,I6,40H   (MAX. NUMBER OF ISOTOPES PER MIXTURE)/
     1 7H IPRECI,I6,34H   (CALENDF ACCURACY FLAG:1/2/3/4))
      END
