Initial commit from Polytechnique Montreal

1 files changed, 1096 insertions, 0 deletions

diff --git a/Dragon/src/EDIMIC.f b/Dragon/src/EDIMIC.f
new file mode 100644
index 0000000..323d864
--- /dev/null
+++ b/Dragon/src/EDIMIC.f
@@ -0,0 +1,1096 @@
+*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