path: root/Dragon/src/EDIDTX.f

*DECK EDIDTX
      SUBROUTINE EDIDTX(IPEDIT,IPFLUX,IPMACR,IADJ,IPRINT,NL,NDEL,NALBP,
     >                  ITRANC,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,ILEAKS,
     >                  ILUPS,NW,MATCOD,VOLUME,KEYFLX,IGCOND,IMERGE,
     >                  FLUXES,AFLUXE,EIGENK,VOLMER,WLETYC,WENERG,
     >                  RATECM,FLUXCM,FADJCM,FLXINT,SCATTD,SCATTS,
     >                  NIFISS,NSAVES,CURNAM,NEDMAC,SIGS,B2,IGOVE,
     >                  CUREIN,TIMEF,NTAUXT,NMLEAK)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Evaluate and print macroscopic reaction rates.
*
*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): G. Marleau
*
*Parameters: input
* IPEDIT  pointer to the edition LCM object.
* IPFLUX  pointer to the solution LCM object.
* IPMACR  pointer to the macrolib LCM object.
* IADJ    type of flux weighting:
*         = 0 direct flux weighting;
*         = 1 direct-adjoint flux weighting.
* IPRINT  print level;
*         = 0 no print;
*         = 1 print fluxes;
*         = 2 1+print reaction rates;
*         = 3 2+print homogenized cross sections.
* NL      number of Legendre orders.
* NDEL    number of delayed precursor groups.
* NALBP   number of physical albedos.
* ITRANC  type of transport corrections.
* NGROUP  number of groups.
* NGCOND  number of groups condensed.
* NBMIX   number of mixtures.
* NREGIO  number of regions.
* NMERGE  number of merged regions.
* ILEAKS  type of leakage calculation:
*         = 0 no leakage;
*         = 1 homogeneous leakage (Diffon);
*         = 2 isotropic streaming (Ecco);
*         = 3 anisotropic streaming (Tibere).
* ILUPS   flag to remove up-scattering from output.
* NW      type of weighting for P1 cross section info (=0 P0; =1 P1).
* MATCOD  material per region.
* VOLUME  volume of region.
* KEYFLX  average flux position per region.
* IGCOND  limit condensed groups.
* IMERGE  index of merged regions.
* FLUXES  fluxes.
* AFLUXE  adjoint fluxes.
* EIGENK  eigenvalue for problem.
* B2      square buckling:
*         for ILEAKS=1,2: B2(4) is homogeneous;
*         for ILEAKS=3: B2(1),B2(2),B2(3) are directional heterogeneous
*         and B2(4) is homogeneous.
* IGOVE   Golfier-Vergain flag (=0/1: don't/use Golfier-Vergain equ'n).
* CUREIN  infinite multiplication factor.
* NTAUXT  number of reaction rate edits (=15+2*NDEL).
* TIMEF   time stamp in day/burnup/irradiation.
* NMLEAK  number of leakage zones.
*
*Parameters: output
* VOLMER  volume of region merged.
* WLETYC  lethargy width condensed.
* WENERG  energy group limits.
* RATECM  averaged region/group cross sections:
*         = RATECM(*,1) = total P0;
*         = RATECM(*,2) = total P1;
*         = RATECM(*,NW+2) = absorption;
*         = RATECM(*,NW+3) = fission;
*         = RATECM(*,NW+4) = fixed sources / productions;
*         = RATECM(*,NW+5) = leakage;
*         = RATECM(*,NW+6) = total out of group scattering;
*         = RATECM(*,NW+7) = diagonal scattering x-s;
*         = RATECM(*,NW+8) = chi;
*         = RATECM(*,NW+9) = wims type transport correction;
*         = RATECM(*,NW+10) = x-directed leakage;
*         = RATECM(*,NW+11) = y-directed leakage;
*         = RATECM(*,NW+12) = z-directed leakage;
*         = RATECM(*,NW+13) = nu-sigf for delayed neutrons;
*         = RATECM(*,NW+13+NDEL) = fission spectra for delayed neutrons.
* FLUXCM  integrated region/group fluxes:
*         = FLUXCM(*,1) = fluxes P0;
*         = FLUXCM(*,2) = fluxes P1.
* FADJCM  averaged region/group adjoint fluxes:
*         = FADJCM(*,1) = adjoint fluxes P0;
*         = FADJCM(*,2) = adjoint fluxes P1.
* FLXINT  integrated flux.
* SCATTD  scattering rates.
* SCATTS  homogenized scattering cross sections.
* NIFISS  number of fissile isotopes.
* NSAVES  homogenized x-s compute/save flag:
*         = 0  no compute, no save;
*         = 1  compute, no save;
*         = 2  compute and save.
* CURNAM  name of LCM directory where the merged/condensed x-s are
*         stored.
* NEDMAC  number of extra edit vectors.
* SIGS    Legendre dependent scattering cross sections.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPEDIT,IPFLUX,IPMACR
      INTEGER     IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NGROUP,NGCOND,NBMIX,
     >            NREGIO,NMERGE,ILEAKS,ILUPS,NW,MATCOD(NREGIO),
     >            KEYFLX(NREGIO),IGCOND(NGCOND),IMERGE(NREGIO),
     >            NIFISS,NSAVES,NEDMAC,NTAUXT,IGOVE,NMLEAK
      REAL        VOLUME(NREGIO),FLUXES(NREGIO,NGROUP,NW+1),
     >            AFLUXE(NREGIO,NGROUP,NW+1),EIGENK,VOLMER(NMERGE),
     >            WENERG(NGCOND+1),RATECM(NMERGE,NGCOND,NTAUXT),
     >            FLUXCM(NMERGE,NGCOND,NW+1),FADJCM(NMERGE,NGCOND,NW+1),
     >            FLXINT(NREGIO,NGROUP,NW+1),WLETYC(NGCOND),
     >            SCATTS(NMERGE,NGCOND,NGCOND,NL),
     >            SIGS(NMERGE,NGCOND,NL),B2(4),CUREIN,TIMEF(3)
      CHARACTER   CURNAM*12
      DOUBLE PRECISION SCATTD(NMERGE,NGCOND,NGCOND,NL)
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) JPFLUX,JPMACR,KPMACR
      CHARACTER   APG*3
      PARAMETER  (IUNOUT=6,APG=' > ',ILCMUP=1,ILCMDN=2)
      CHARACTER   TEXT12*12,CM*2,OPTION*4
      LOGICAL     LH,LSPH
      DOUBLE PRECISION SCATW,CSCAT,TOTFIS,FXSOUR,FLFUEL,FCELL
      INTEGER     IFSKP,ISKP(3)
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: IFUELR,INGSCT,IFGSCT,IPOSCT,
     > IMERGL
      REAL, ALLOCATABLE, DIMENSION(:) :: DISFCT,SIGMA,XSCAT,WORKF,
     > ENERG,SIGMAF
      REAL, ALLOCATABLE, DIMENSION(:,:) :: FFUEL,FLDMC,OVERV,HFACT,HSPH,
     > DECAY,ALBPGR,DIFHET
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: TAUXE,ALBP,ALBPGR2
      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HVECT
*----
*  SCRATCH STORAGE ALLOCATION
*   HVECT   extra edit names.
*   IFUELR  fuel region location.
*   DISFCT  disadvantage factor.
*   TAUXE   extra edit rates.
*   FFUEL   flux in fuel.
*   FLDMC   fission rate condensed.
*   OVERV   1/v merge condensed.
*   HFACT   H-factors.
*   HSPH    SPH factors.
*   DECAY   precursor decay constants.
*   ALBP    physical albedos.
*----
      ALLOCATE(HVECT(NEDMAC),IFUELR(NREGIO))
      ALLOCATE(DISFCT(NGCOND),TAUXE(NMERGE,NGCOND,NEDMAC),
     > FFUEL(NREGIO,NIFISS),FLDMC(NMERGE,NGCOND),OVERV(NMERGE,NGCOND),
     > HFACT(NMERGE,NGCOND),HSPH(NMERGE,NGCOND),DECAY(NDEL,NIFISS),
     > ALBP(NALBP,NGCOND,NGCOND))
*----
*  ALLOCATE WORK VECTOR AND INITIALIZE REQUIRED VECTORS
*----
      ILEAK2=ILEAKS
      ALLOCATE(INGSCT(NBMIX),IFGSCT(NBMIX),IPOSCT(NBMIX))
      ALLOCATE(SIGMA(0:NBMIX*MAX(NIFISS,1)),XSCAT(NBMIX*NGROUP))
      RATECM(:NMERGE,:NGCOND,:NTAUXT)=0.0
      FLUXCM(:NMERGE,:NGCOND,:NW+1)=0.0
      FADJCM(:NMERGE,:NGCOND,:NW+1)=0.0
      SIGS(:NMERGE,:NGCOND,:NL)=0.0
      OVERV(:NMERGE,:NGCOND)=0.0
      HFACT(:NMERGE,:NGCOND)=0.0
      HSPH(:NMERGE,:NGCOND)=0.0
      TAUXE(:NMERGE,:NGCOND,:NEDMAC)=0.0
      VOLMER(:NMERGE)=0.0
      FFUEL(:NREGIO,:NIFISS)=0.0
      IFUELR(:NREGIO)=0
      SIGMA(0)=0.0
      IF(IADJ.EQ.0) THEN
        IOP=1
      ELSE IF(IADJ.EQ.1) THEN
        IOP=11
      ENDIF
*----
*  FIND EDIT XS
*----
      IF(NEDMAC.GT.0) CALL LCMGTC(IPMACR,'ADDXSNAME-P0',8,NEDMAC,HVECT)
*----
*  ENERGY AND LETHARGY CONDENSATION
*----
      CALL LCMLEN(IPMACR,'ENERGY',ILCMLN,ITYLCM)
      IF(ILCMLN.EQ.0) THEN
        NENER=0
        WLETYC(:NGCOND)=0.0
        WENERG(:NGCOND+1)=0.0
      ELSE IF(ILCMLN.EQ.NGROUP+1) THEN
        NENER=NGCOND+1
        ALLOCATE(ENERG(NGROUP+1))
        CALL LCMGET(IPMACR,'ENERGY',ENERG)
        WENERG(1)=ENERG(1)
        DO 30 IGC=1,NGCOND
          WENERG(IGC+1)=ENERG(IGCOND(IGC)+1)
          WLETYC(IGC)=LOG(WENERG(IGC)/WENERG(IGC+1))
  30    CONTINUE
        IF(ENERG(NGROUP+1).EQ.0.0) ENERG(NGROUP+1)=1.0E-5
        DEALLOCATE(ENERG)
      ELSE
        CALL XABORT('EDIDTX: READ ERROR INVALID NUMBER OF GROUPS')
      ENDIF
*----
*  COMPUTE MERGED VOLUME
*----
      DO 50 IREGIO=1,NREGIO
        IKK=IMERGE(IREGIO)
        IF(IKK.GT.0) THEN
          VOLMER(IKK)=VOLMER(IKK)+VOLUME(IREGIO)
        ENDIF
  50  CONTINUE
*----
*  COMPUTE INTEGRATED/CONDENSED FUNDAMENTAL CURRENTS (ILEAKS=2,3)
*----
      IF(ILEAKS.EQ.2) THEN
        IF(IADJ.EQ.1) CALL XABORT('EDIDTX: DIRECT-ADJOINT WEIGTING NOT'
     >  //' IMPLEMENTED.')
        CALL LCMLEN(IPFLUX,'FLUX',ILCMLN,ITYLCM)
        IF(ILCMLN.EQ.0) CALL XABORT('EDIDTX: MISSING FLUX INFO.')
        JPFLUX=LCMGID(IPFLUX,'FLUX')
        CALL LCMLEL(JPFLUX,1,ILCMLN,ITYLCM)
        ALLOCATE(WORKF(ILCMLN))
        DO 70 IGR=1,NGROUP
          CALL LCMGDL(JPFLUX,IGR,WORKF)
          DO 60 IREG=1,NREGIO
            FLXINT(IREG,IGR,1)=WORKF(KEYFLX(IREG)+ILCMLN/2)*VOLUME(IREG)
  60      CONTINUE
  70    CONTINUE
        IGRFIN=0
        DO 90 IGRC=1,NGCOND
          IGRDEB=IGRFIN+1
          IGRFIN=IGCOND(IGRC)
          DO 80 IGR=IGRDEB,IGRFIN
*----
*  COMPUTE MERGED INTEGRATED CURRENTS
*----
            CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >      VOLUME(1),RATECM(1,IGRC,NW+5),SIGMA(0),IMERGE,NMERGE)
  80      CONTINUE
  90    CONTINUE
        DEALLOCATE(WORKF)
      ELSE IF(ILEAKS.EQ.3) THEN
        IF(IADJ.EQ.1) CALL XABORT('EDIDTX: DIRECT-ADJOINT WEIGTING NOT'
     >  //' IMPLEMENTED.')
        CALL LCMLEN(IPFLUX,'FLUX',ILCMLN,ITYLCM)
        IF(ILCMLN.EQ.0) CALL XABORT('EDIDTX: MISSING FLUX INFO.')
        JPFLUX=LCMGID(IPFLUX,'FLUX')
        CALL LCMLEL(JPFLUX,1,ILCMLN,ITYLCM)
*----
*  CALCULATIONS FOR TIBERE PIJ
*----
        IF(ILCMLN.EQ.12*NREGIO) THEN
          IFSKP=3*NREGIO
          ALLOCATE(WORKF(ILCMLN))
          DO 140 IDIR=1,3
            DO 110 IGR=1,NGROUP
              CALL LCMGDL(JPFLUX,IGR,WORKF)
              DO 100 IREG=1,NREGIO
                FLXINT(IREG,IGR,1)=WORKF(KEYFLX(IREG)+IDIR*IFSKP)
     >          *VOLUME(IREG)
 100          CONTINUE
 110        CONTINUE
            IGRFIN=0
            DO 130 IGRC=1,NGCOND
              IGRDEB=IGRFIN+1
              IGRFIN=IGCOND(IGRC)
              DO 120 IGR=IGRDEB,IGRFIN
*----
*  COMPUTE MERGED INTEGRATED CURRENTS FOR TIBERE PIJ
*----
                CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >                     VOLUME(1),RATECM(1,IGRC,NW+9+IDIR),SIGMA(0),
     >                     IMERGE,NMERGE)
 120          CONTINUE
 130        CONTINUE
 140      CONTINUE
          DEALLOCATE(WORKF)
*----
*  CALCULATIONS FOR TIBERE MoC
*----
        ELSE IF(ILCMLN.NE.0) THEN
          ALLOCATE(WORKF(ILCMLN))
          DO 141 IDIR=1,3
            DO 111 IGR=1,NGROUP
              CALL LCMGDL(JPFLUX,IGR,WORKF)
              DO 101 IREG=1,NREGIO
                ISKP(1)=ILCMLN/4+KEYFLX(IREG)
                ISKP(2)=ILCMLN/2+KEYFLX(IREG)
                ISKP(3)=3*ILCMLN/4+KEYFLX(IREG)
                FLXINT(IREG,IGR,1)=WORKF(ISKP(IDIR))*VOLUME(IREG)
 101          CONTINUE
 111        CONTINUE
            IGRFIN=0
            DO 131 IGRC=1,NGCOND
              IGRDEB=IGRFIN+1
              IGRFIN=IGCOND(IGRC)
              DO 121 IGR=IGRDEB,IGRFIN
*----
*  COMPUTE MERGED INTEGRATED CURRENTS FOR TIBERE MOC
*----
                CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >                     VOLUME(1),RATECM(1,IGRC,NW+9+IDIR),SIGMA(0),
     >                     IMERGE,NMERGE)
 121          CONTINUE
 131        CONTINUE
 141      CONTINUE
          DEALLOCATE(WORKF)
        ENDIF
      ENDIF
*----
*  COMPUTE INTEGRATED FLUX
*----
      DO 170 IW=1,NW+1
        DO 160 IGR=1,NGROUP
          DO 150 IREGIO=1,NREGIO
            FLXINT(IREGIO,IGR,IW)=FLUXES(IREGIO,IGR,IW)*VOLUME(IREGIO)
 150      CONTINUE
 160    CONTINUE
 170  CONTINUE
*----
*  COMPUTE INTEGRATED/CONDENSED FUNDAMENTAL CURRENTS (ILEAKS=1)
*  (OBTAINED AS THE PRODUCT OF THE FUNDAMENTAL FLUX BY THE LEAKAGE
*  COEFFICIENT)
*----
      JPMACR=LCMGID(IPMACR,'GROUP')
      IF(ILEAKS.EQ.1) THEN
        CALL LCMLEN(IPFLUX,'DIFFHET',ILCMLN,ITYLCM)
        IF(ILCMLN.EQ.0) THEN
          CALL XABORT('EDIDTX: UNABLE TO RECOVER THE DIFFHET RECORD IN'
     >    //' THE FLUX OBJECT.')
        ENDIF
        ALLOCATE(DIFHET(NMLEAK,NGROUP),IMERGL(NBMIX))
        CALL LCMLEN(IPFLUX,'IMERGE-LEAK',ILCMLN,ITYLCM)
        IF(ILCMLN.NE.NBMIX) THEN
          CALL XABORT('EDIDTX: IMERGE-LEAK OVERFLOW.')
        ENDIF
        CALL LCMGET(IPFLUX,'IMERGE-LEAK',IMERGL)
        CALL LCMGET(IPFLUX,'DIFFHET',DIFHET)
        CALL LCMGTC(IPFLUX,'OPTION',4,OPTION)
        IGRFIN=0
        DO 200 IGRC=1,NGCOND
          IGRDEB=IGRFIN+1
          IGRFIN=IGCOND(IGRC)
          DO 190 IGR=IGRDEB,IGRFIN
            IF(OPTION.EQ.'LKRD') THEN
              KPMACR=LCMGIL(JPMACR,IGR)
              CALL LCMGET(KPMACR,'DIFF',SIGMA(1))
            ELSE
              IF(NMLEAK.EQ.0) CALL XABORT('EDIDTX: NO LEAKAGE ZONE.')
              SIGMA(0)=0.0
              DO 180 IMIX=1,NBMIX
                IME=IMERGL(IMIX)
                IF(IME.GT.0) SIGMA(IMIX)=DIFHET(IME,IGR)
 180          CONTINUE
            ENDIF
            CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >      AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+5),SIGMA(0),IMERGE,NMERGE)
 190      CONTINUE
 200    CONTINUE
        DEALLOCATE(IMERGL,DIFHET)
      ENDIF
*----
*  READ FIXE SOURCES/COMPUTE FIXE PRODUCTION RATE AND TOTAL SOURCE
*----
      IGRFIN=0
      TOTFIS=0.0D0
      FXSOUR=0.0D0
      DO 250 IGRC=1,NGCOND
        IGRDEB=IGRFIN+1
        IGRFIN=IGCOND(IGRC)
        DO 240 IGR=IGRDEB,IGRFIN
          KPMACR=LCMGIL(JPMACR,IGR)
          CALL LCMLEN(KPMACR,'FIXE',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            CALL LCMGET(KPMACR,'FIXE',SIGMA(1))
            CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,VOLUME(1),
     >      AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+4),SIGMA(0),IMERGE,
     >      NMERGE)
            DO 210 IKK=1,NMERGE
              FXSOUR=FXSOUR+DBLE(RATECM(IKK,IGRC,NW+4))
 210        CONTINUE
          ENDIF
          DO 215 IW=1,NW+1
            CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,IW),
     >                  VOLUME(1),FLUXCM(1,IGRC,IW),SIGMA(0),IMERGE,
     >                  NMERGE)
            IF(IADJ.EQ.1) THEN
              CALL EDIRAT(10,NREGIO,NBMIX,MATCOD,AFLUXE(1,IGR,IW),
     >        FLXINT(1,IGR,IW),FADJCM(1,IGRC,IW),SIGMA(0),IMERGE,NMERGE)
              DO IKK=1,NMERGE
                FADJCM(IKK,IGRC,IW)=FADJCM(IKK,IGRC,IW)/
     >                                               FLUXCM(IKK,IGRC,IW)
              ENDDO
            ENDIF
 215      CONTINUE
*----
*  READ FISSION X-S/ COMPUTE FISSION RATES
*----
          CALL LCMLEN(KPMACR,'NUSIGF',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            CALL LCMGET(KPMACR,'NUSIGF',SIGMA(1))
            DO 230 IFIS=1,NIFISS
              DO 220 IREGIO=1,NREGIO
                IBM=MATCOD(IREGIO)
                IF(IBM.GT.0) THEN
                 IF(SIGMA((IFIS-1)*NBMIX+IBM).GT.0.0) THEN
                   FLXFIS=FLXINT(IREGIO,IGR,1)*SIGMA((IFIS-1)*NBMIX+IBM)
                   FFUEL(IREGIO,IFIS)=FFUEL(IREGIO,IFIS)+FLXFIS
                   TOTFIS=TOTFIS+DBLE(FLXFIS)
                   IFUELR(IREGIO)=1
                 ENDIF
                ENDIF
 220          CONTINUE
 230        CONTINUE
          ENDIF
*----
 240    CONTINUE
 250  CONTINUE
*----
*  RECOVER THE PRECURSOR RADIOACTIVE DECAY CONSTANTS. USE THE VALUES
*  OF THE FISSILE ISOTOPE WITH MAXIMUM FISSION RATE
*----
      IF(CURNAM.NE.' ') THEN
        CALL LCMLEN(IPMACR,'LAMBDA-D',ILCMLN,ITYLCM)
        IF((NDEL.GT.0).AND.(ILCMLN.GT.0)) THEN
          ZMAX=0.0
          KFIS=0
          DO 340 IFIS=1,NIFISS
            ZTOT=0.0
            DO 330 IREGIO=1,NREGIO
            ZTOT=ZTOT+FFUEL(IREGIO,IFIS)
 330        CONTINUE
            IF(ZTOT.GE.ZMAX) THEN
              KFIS=IFIS
              ZMAX=ZTOT
            ENDIF
 340      CONTINUE
          CALL LCMGET(IPMACR,'LAMBDA-D',DECAY)
          CALL LCMSIX(IPEDIT,CURNAM,ILCMUP)
          CALL LCMSIX(IPEDIT,'MACROLIB',ILCMUP)
          CALL LCMPUT(IPEDIT,'LAMBDA-D',NDEL,2,DECAY(1,KFIS))
          CALL LCMSIX(IPEDIT,' ',ILCMDN)
          CALL LCMSIX(IPEDIT,' ',ILCMDN)
        ENDIF
      ENDIF
*----
*  FIND FUEL VOLUME FOR DISADVANTAGE FACTOR
*----
      VFUEL=0.0
      VCELL=0.0
      DO 350 IREGIO=1,NREGIO
        IF(IFUELR(IREGIO).EQ.1) THEN
          VFUEL=VFUEL+VOLUME(IREGIO)
        ENDIF
        VCELL=VCELL+VOLUME(IREGIO)
 350  CONTINUE
      LH=.FALSE.
      LSPH=.FALSE.
      IGRFIN=0
      DO 510 IGRC=1,NGCOND
        FCELL=0.0D0
        FLFUEL=0.0D0
        IGRDEB=IGRFIN+1
        IGRFIN=IGCOND(IGRC)
        DO 380 JGRC=1,NGCOND
          DO 370 I=1,NMERGE
            DO 360 IL=1,NL
              SCATTD(I,IGRC,JGRC,IL)=0.0D0
 360        CONTINUE
 370      CONTINUE
 380    CONTINUE
        DO 500 IGR=IGRDEB,IGRFIN
          KPMACR=LCMGIL(JPMACR,IGR)
*----
*  INTEGRATED 1/V
*----
          CALL LCMLEN(KPMACR,'OVERV',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            CALL LCMGET(KPMACR,'OVERV',SIGMA(1))
            CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >                  AFLUXE(1,IGR,1),OVERV(1,IGRC),SIGMA(0),
     >                  IMERGE,NMERGE)
          ENDIF
*----
*  INTEGRATED H-FACTORS
*----
          CALL LCMLEN(KPMACR,'H-FACTOR',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            LH=.TRUE.
            CALL LCMGET(KPMACR,'H-FACTOR',SIGMA(1))
            CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >                  AFLUXE(1,IGR,1),HFACT(1,IGRC),SIGMA(0),
     >                  IMERGE,NMERGE)
          ENDIF
*----
*  SPH FACTORS
*----
          CALL LCMLEN(KPMACR,'NSPH',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            LSPH=.TRUE.
            CALL LCMGET(KPMACR,'NSPH',SIGMA(1))
            CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >                  AFLUXE(1,IGR,1),HSPH(1,IGRC),SIGMA(0),
     >                  IMERGE,NMERGE)
          ENDIF
*----
*  TOTAL, ABSROPTION, ETC. RATES
*----
          CALL LCMLEN(KPMACR,'NTOT0',ILCMLN,ITYLCM)
          IF(ILCMLN.EQ.0) CALL XABORT('EDIDTX: READ ERROR ON LCM REC'//
     >    'ORD= TOTAL')
          CALL LCMGET(KPMACR,'NTOT0',SIGMA(1))
          CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >    AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+2),SIGMA(0),IMERGE,NMERGE)
          DO 385 IW=1,NW+1
            WRITE(TEXT12,'(4HNTOT,I1)') IW-1
            CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) CALL LCMGET(KPMACR,TEXT12,SIGMA(1))
            CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,IW),
     >      AFLUXE(1,IGR,IW),RATECM(1,IGRC,IW),SIGMA(0),IMERGE,
     >      NMERGE)
 385      CONTINUE
          CALL LCMLEN(KPMACR,'SIGS00',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            CALL LCMGET(KPMACR,'SIGS00',SIGMA(1))
            CALL EDIRAT(-IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >      AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+2),SIGMA(0),IMERGE,NMERGE)
          ENDIF
          IF(ILEAKS.EQ.0) THEN
            CALL LCMLEN(KPMACR,'DIFF',ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) THEN
              CALL LCMGET(KPMACR,'DIFF',SIGMA(1))
              CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >        AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+5),SIGMA(0),IMERGE,
     >        NMERGE)
              ILEAK2=10
            ENDIF
            CALL LCMLEN(KPMACR,'DIFFX',ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) THEN
              CALL LCMGET(KPMACR,'DIFFX',SIGMA(1))
              CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >        AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+10),SIGMA(0),IMERGE,
     >        NMERGE)
              ILEAK2=11
            ENDIF
            CALL LCMLEN(KPMACR,'DIFFY',ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) THEN
              CALL LCMGET(KPMACR,'DIFFY',SIGMA(1))
              CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >        AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+11),SIGMA(0),IMERGE,
     >        NMERGE)
              ILEAK2=11
            ENDIF
            CALL LCMLEN(KPMACR,'DIFFZ',ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) THEN
              CALL LCMGET(KPMACR,'DIFFZ',SIGMA(1))
              CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >        AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+12),SIGMA(0),IMERGE,
     >        NMERGE)
              ILEAK2=11
            ENDIF
          ENDIF
*----
*  READ ADDITIONAL X-SECTIONS
*----
          DO 390 IED=1,NEDMAC
            IF(HVECT(IED)(:2).EQ.'NW') GO TO 390
            CALL LCMLEN(KPMACR,HVECT(IED),ILONG,ITYLCM)
            IF(ILONG.GT.0) THEN
              CALL LCMGET(KPMACR,HVECT(IED),SIGMA(1))
              CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >                    AFLUXE(1,IGR,1),TAUXE(1,IGRC,IED),SIGMA(0),
     >                    IMERGE,NMERGE)
            ENDIF
 390      CONTINUE
*----
*  FISSION SPECTRUM AND NU*SIGF
*----
          CALL LCMLEN(KPMACR,'NUSIGF',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            ALLOCATE(SIGMAF(0:NBMIX))
            SIGMAF(0)=0.0
            CALL LCMGET(KPMACR,'NUSIGF',SIGMA(1))
            DO 400 IFIS=1,NIFISS
              DO 395 IBM=1,NBMIX
                SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM)
 395          CONTINUE
              CALL EDIRAT(1,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >        AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+3),SIGMAF(0),IMERGE,
     >        NMERGE)
 400        CONTINUE
            DEALLOCATE(SIGMAF)
          ENDIF
          CALL LCMLEN(KPMACR,'CHI',ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            ALLOCATE(SIGMAF(0:NBMIX))
            SIGMAF(0)=0.0
            CALL LCMGET(KPMACR,'CHI',SIGMA(1))
            DO 410 IFIS=1,NIFISS
              DO 405 IBM=1,NBMIX
                SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM)
 405          CONTINUE
              CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FFUEL(1,IFIS),
     >        AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+4),SIGMAF(0),IMERGE,
     >        NMERGE)
 410        CONTINUE
            DEALLOCATE(SIGMAF)
          ENDIF
*----
*  DELAYED FISSION SPECTRUM AND NU*SIGF
*----
          DO 440 IDEL=1,NDEL
            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
            CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) THEN
              ALLOCATE(SIGMAF(0:NBMIX))
              SIGMAF(0)=0.0
              CALL LCMGET(KPMACR,TEXT12,SIGMA(1))
              DO 420 IFIS=1,NIFISS
                DO 415 IBM=1,NBMIX
                  SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM)
 415            CONTINUE
                CALL EDIRAT(1,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >          VOLUME(1),RATECM(1,IGRC,12+NW+IDEL),SIGMAF(0),IMERGE,
     >          NMERGE)
 420          CONTINUE
              DEALLOCATE(SIGMAF)
            ENDIF
            WRITE(TEXT12,'(3HCHI,I2.2)') IDEL
            CALL LCMLEN(KPMACR,TEXT12,ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) THEN
              ALLOCATE(SIGMAF(0:NBMIX))
              SIGMAF(0)=0.0
              CALL LCMGET(KPMACR,TEXT12,SIGMA(1))
              DO 430 IFIS=1,NIFISS
                DO 425 IBM=1,NBMIX
                  SIGMAF(IBM)=SIGMA((IFIS-1)*NBMIX+IBM)
 425            CONTINUE
                CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FFUEL(1,IFIS),
     >          AFLUXE(1,IGR,1),RATECM(1,IGRC,12+NW+NDEL+IDEL),
     >          SIGMAF(0),IMERGE,NMERGE)
 430          CONTINUE
              DEALLOCATE(SIGMAF)
            ENDIF
 440      CONTINUE
*----
*  INTEGRATED FLUX AND FORM FACTOR
*----
          DO 450 IREGIO=1,NREGIO
            IF(IFUELR(IREGIO).EQ.1) THEN
              FLFUEL=FLFUEL+DBLE(FLXINT(IREGIO,IGR,1))
            ENDIF
            FCELL=FCELL+DBLE(FLXINT(IREGIO,IGR,1))
 450      CONTINUE
*----
*  TRANSPORT CORRECTION
*----
          IF(ITRANC.NE.0) THEN
            CALL LCMLEN(KPMACR,'TRANC',ILCMLN,ITYLCM)
            IF(ILCMLN.GT.0) THEN
              CALL LCMGET(KPMACR,'TRANC',SIGMA(1))
              CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,1),
     >        AFLUXE(1,IGR,1),RATECM(1,IGRC,NW+9),SIGMA(0),IMERGE,
     >        NMERGE)
            ENDIF
          ENDIF
*----
*  SCATTERING NEUTRONS
*----
          DO 490 IL=1,NL
          IW=MIN(IL,NW+1)
          WRITE (CM,'(I2.2)') IL-1
          CALL LCMLEN(KPMACR,'SIGS'//CM,ILCSCA,ITYLCM)
          IF(ILCSCA.GT.0) THEN
            CALL LCMGET(KPMACR,'SIGS'//CM,SIGMA(1))
            CALL EDIRAT(IOP,NREGIO,NBMIX,MATCOD,FLXINT(1,IGR,IW),
     >      AFLUXE(1,IGR,IW),SIGS(1,IGRC,IL),SIGMA(0),IMERGE,NMERGE)
          ENDIF
          CALL LCMLEN(KPMACR,'NJJS'//CM,ILCMLN,ITYLCM)
          IF(ILCMLN.GT.0) THEN
            CALL LCMGET(KPMACR,'SIGW'//CM,SIGMA(1))
            CALL LCMGET(KPMACR,'NJJS'//CM,INGSCT)
            CALL LCMGET(KPMACR,'IJJS'//CM,IFGSCT)
            CALL LCMGET(KPMACR,'IPOS'//CM,IPOSCT)
            CALL LCMGET(KPMACR,'SCAT'//CM,XSCAT)
            DO 480 IREGIO=1,NREGIO
              MATNUM=MATCOD(IREGIO)
              IKK=IMERGE(IREGIO)
              IF((IKK.GT.0).AND.(MATNUM.GT.0)) THEN
                NGSCAT=INGSCT(MATNUM)
                IGSCAT=IFGSCT(MATNUM)
                IPOSIT=IPOSCT(MATNUM)
                JGRFIN=0
                FAD=1.0
                IF(IADJ.EQ.1) FAD=AFLUXE(IREGIO,IGR,IW)
                DO 470 JGRC=1,NGCOND
                  JGRDEB=JGRFIN+1
                  JGRFIN=IGCOND(JGRC)
                  J2=MIN(JGRFIN,IGSCAT)
                  J1=MAX(JGRDEB,IGSCAT-NGSCAT+1)
                  IPO=IPOSIT+IGSCAT-J2
                  DO 460 JGR=J2,J1,-1
                    IF(IGR.EQ.JGR) THEN
                      SCATTD(IKK,IGRC,JGRC,IL)=SCATTD(IKK,IGRC,JGRC,IL)
     >                   +SIGMA(MATNUM)*FLXINT(IREGIO,JGR,IW)*FAD
                    ELSE
                      SCATTD(IKK,IGRC,JGRC,IL)=SCATTD(IKK,IGRC,JGRC,IL)
     >                   +XSCAT(IPO)*FLXINT(IREGIO,JGR,IW)*FAD
                    ENDIF
                    IPO=IPO+1
 460              CONTINUE
 470            CONTINUE
              ENDIF
 480        CONTINUE
          ENDIF
 490      CONTINUE
 500    CONTINUE
        IF(VFUEL*FCELL.GT.0.0) THEN
          DISFCT(IGRC)=REAL(FLFUEL*VCELL/(VFUEL*FCELL))
        ELSE
          DISFCT(IGRC)=0.0
        ENDIF
 510  CONTINUE
*----
*  UP-SCATTERING CORRECTIONS
*----
      IF(ILUPS.EQ.1) THEN
        DO 523 IKK=1,NMERGE
        DO 522 IGRC=2,NGCOND
        DO 521 JGRC=1,IGRC-1
        CSCAT=SCATTD(IKK,JGRC,IGRC,1) ! JGRC < IGRC
        RATECM(IKK,IGRC,1)=RATECM(IKK,IGRC,1)-REAL(CSCAT)
        RATECM(IKK,JGRC,1)=RATECM(IKK,JGRC,1)-REAL(CSCAT)
        IF((NW.GE.1).AND.(NL.GE.1)) THEN
          CSCAT=SCATTD(IKK,JGRC,IGRC,2)
          RATECM(IKK,IGRC,2)=RATECM(IKK,IGRC,2)-REAL(CSCAT)
          RATECM(IKK,JGRC,2)=RATECM(IKK,JGRC,2)-REAL(CSCAT)
        ENDIF
        DO 520 IL=1,NL
          CSCAT=SCATTD(IKK,JGRC,IGRC,IL)
          SIGS(IKK,IGRC,IL)=SIGS(IKK,IGRC,IL)-REAL(CSCAT)
          SIGS(IKK,JGRC,IL)=SIGS(IKK,JGRC,IL)-REAL(CSCAT)
          SCATTD(IKK,IGRC,JGRC,IL)=SCATTD(IKK,IGRC,JGRC,IL)-CSCAT
          SCATTD(IKK,JGRC,IGRC,IL)=0.0D0
 520    CONTINUE
 521    CONTINUE
 522    CONTINUE
 523    CONTINUE
      ENDIF
*----
*  SCATTERING NORMALIZATION
*----
      IF(IADJ.EQ.0) THEN
        DO 560 IGRC=1,NGCOND
          DO 550 IKK=1,NMERGE
            DO 540 IL=1,NL
              IF(ILCSCA.GT.0) THEN
                SCATW=SIGS(IKK,IGRC,IL)
                DO 530 JGRC=1,NGCOND
                  IF(JGRC.NE.IGRC) SCATW=SCATW-SCATTD(IKK,JGRC,IGRC,IL)
 530            CONTINUE
                DEN=REAL(MAX(ABS(SCATW),ABS(SCATTD(IKK,IGRC,IGRC,IL))))
                IF(DEN.GT.0.0) THEN
                  ERR=ABS(REAL(SCATW-SCATTD(IKK,IGRC,IGRC,IL)))/DEN
                  IF(ERR.GT.1.0E-3) THEN
                    WRITE(IUNOUT,6000) IL,IGRC,IKK,100.0*ERR
                  ENDIF
                  SCATTD(IKK,IGRC,IGRC,IL)=SCATW
                ENDIF
              ELSE
                SCATW=0.0D0
                DO 535 JGRC=1,NGCOND
                  SCATW=SCATW+SCATTD(IKK,JGRC,IGRC,IL)
 535            CONTINUE
                SIGS(IKK,IGRC,IL)=REAL(SCATW)
              ENDIF
 540        CONTINUE
 550      CONTINUE
 560    CONTINUE
      ENDIF
*----
*  FISSION SPECTRUM NORMALIZATION
*----
      IF((FXSOUR.EQ.0.0D0).AND.(TOTFIS.GT.0.0D0)) THEN
        FLDMC(:NMERGE,:NGCOND)=0.0
        DO 580 IGRC=1,NGCOND
          DO 570 IFIS=1,NIFISS
            CALL EDIRAT(0,NREGIO,NBMIX,MATCOD,FFUEL(1,IFIS),VOLUME(1),
     >                  FLDMC(1,IGRC),SIGMA(0),IMERGE,NMERGE)
 570      CONTINUE
 580    CONTINUE
        DO 640 IKK=1,NMERGE
          TOTAL1=0.0
          DO 590 IGRC=1,NGCOND
            IF(RATECM(IKK,IGRC,NW+4).NE.0.0) THEN
             RATECM(IKK,IGRC,NW+8)=RATECM(IKK,IGRC,NW+4)/FLDMC(IKK,IGRC)
             TOTAL1=TOTAL1+RATECM(IKK,IGRC,NW+8)
            ELSE
             RATECM(IKK,IGRC,NW+8)=0.0
            ENDIF
 590      CONTINUE
          IF((IADJ.EQ.0).AND.(TOTAL1.NE.0.0)) THEN
            DO 600 IGRC=1,NGCOND
              RATECM(IKK,IGRC,NW+8)=RATECM(IKK,IGRC,NW+8)/TOTAL1
 600        CONTINUE
          ELSE IF(IADJ.EQ.1) THEN
            DO 601 IGRC=1,NGCOND
              RATECM(IKK,IGRC,NW+8)=RATECM(IKK,IGRC,NW+8)/
     >        FADJCM(IKK,IGRC,1)
 601        CONTINUE
          ENDIF
          DO 630 IDEL=1,NDEL
            K=12+NW+NDEL+IDEL
            TOTAL1=0.0
            DO 610 IGRC=1,NGCOND
              IF(RATECM(IKK,IGRC,K).NE.0.0) THEN
                RATECM(IKK,IGRC,K)=RATECM(IKK,IGRC,K)/FLDMC(IKK,IGRC)
                TOTAL1=TOTAL1+RATECM(IKK,IGRC,K)
              ELSE
                RATECM(IKK,IGRC,K)=0.0
              ENDIF
 610        CONTINUE
            IF((IADJ.EQ.0).AND.(TOTAL1.NE.0.0)) THEN
              DO 620 IGRC=1,NGCOND
                RATECM(IKK,IGRC,K)=RATECM(IKK,IGRC,K)/TOTAL1
 620          CONTINUE
            ELSE IF(IADJ.EQ.1) THEN
              DO 621 IGRC=1,NGCOND
                RATECM(IKK,IGRC,K)=RATECM(IKK,IGRC,K)/FADJCM(IKK,IGRC,1)
 621          CONTINUE
            ENDIF
 630      CONTINUE
 640    CONTINUE
      ENDIF
      DEALLOCATE(XSCAT,SIGMA)
      DEALLOCATE(IPOSCT,IFGSCT,INGSCT)
*----
*  CONDENSATION OF PHYSICAL ALBEDOS
*----
      IF(NALBP.GT.0) THEN
        ALBP(:NALBP,:NGCOND,:NGCOND)=0.0
        CALL LCMLEN(IPMACR,'ALBEDO',ILONG,ITYLCM)
        IF(ILONG.EQ.NALBP*NGROUP) THEN
*         diagonal physical albedos
          ALLOCATE(ALBPGR(NALBP,NGROUP))
          CALL LCMGET(IPMACR,'ALBEDO',ALBPGR)
          IGRFIN=0
          DO 663 IGRC=1,NGCOND
          IGRDEB=IGRFIN+1
          IGRFIN=IGCOND(IGRC)
          DENOM=0.0
          DO 655 IGR=IGRDEB,IGRFIN
          DO 650 IREGIO=1,NREGIO
          DENOM=DENOM+FLXINT(IREGIO,IGR,1)
 650      CONTINUE
 655      CONTINUE
          DO 662 IAL=1,NALBP
          DO 661 IGR=IGRDEB,IGRFIN
          DO 660 IREGIO=1,NREGIO
          ALBP(IAL,IGRC,IGRC)=ALBP(IAL,IGRC,IGRC)+ALBPGR(IAL,IGR)*
     1                   FLXINT(IREGIO,IGR,1)/DENOM
 660      CONTINUE
 661      CONTINUE
 662      CONTINUE
 663      CONTINUE
          DEALLOCATE(ALBPGR)
        ELSE IF(ILONG.EQ.NALBP*NGROUP*NGROUP) THEN
*         matrix physical albedos
          ALLOCATE(ALBPGR2(NALBP,NGROUP,NGROUP))
          CALL LCMGET(IPMACR,'ALBEDO',ALBPGR2)
          IGRFIN=0
          DO 765 IGRC=1,NGCOND
          IGRDEB=IGRFIN+1
          IGRFIN=IGCOND(IGRC)
          DENOM=0.0
          DO 755 IGR=IGRDEB,IGRFIN
          DO 750 IREGIO=1,NREGIO
          DENOM=DENOM+FLXINT(IREGIO,IGR,1)
 750      CONTINUE
 755      CONTINUE
          DO 764 IAL=1,NALBP
          DO 763 IGR=IGRDEB,IGRFIN
          JGRFIN=0
          DO 762 JGRC=1,NGCOND
          JGRDEB=JGRFIN+1
          JGRFIN=IGCOND(JGRC)
          DO 761 JGR=JGRDEB,JGRFIN
          DO 760 IREGIO=1,NREGIO
          ALBP(IAL,JGRC,IGRC)=ALBP(IAL,JGRC,IGRC)+ALBPGR2(IAL,JGR,IGR)*
     1                   FLXINT(IREGIO,IGR,1)/DENOM
 760      CONTINUE
 761      CONTINUE
 762      CONTINUE
 763      CONTINUE
 764      CONTINUE
 765      CONTINUE
          DEALLOCATE(ALBPGR2)
        ELSE
          CALL XABORT('EDIDTX: INCONSISTENT ALBEDO INFORMATION.')
        ENDIF
      ENDIF
*----
*  PRINT REACTION RATES
*----
      ILEAKS=ILEAK2
      IF(IPRINT.GE.1) THEN
        CALL EDIPRR(IPRINT,NL,ITRANC,NGCOND,NMERGE,ILEAKS,NW,NTAUXT,
     >              B2,VOLMER,NENER,WENERG,RATECM,FLUXCM,SCATTD)
      ENDIF
*----
*  COMPUTE MERGED/CONDENSED X-S
*----
      CALL EDIPXS(IPEDIT,IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NSAVES,NGCOND,
     >            NMERGE,ILEAKS,NW,NTAUXT,EIGENK,B2,IGOVE,CUREIN,NIFISS,
     >            CURNAM,NEDMAC,VOLMER,WLETYC,WENERG,SCATTD,RATECM,
     >            FLUXCM,FADJCM,SIGS,SCATTS,DISFCT,ALBP,TAUXE,HVECT,
     >            OVERV,HFACT,HSPH,NENER,TIMEF,LH,LSPH)
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(ALBP,DECAY,HSPH,HFACT,OVERV,FLDMC,FFUEL,TAUXE,DISFCT)
      DEALLOCATE(IFUELR,HVECT)
      RETURN
*----
*  FORMAT
*----
 6000 FORMAT(/53H EDIDTX: *** WARNING *** NORMALIZATION OF THE WITHIN-,
     > 34HGROUP SCATTERING TRANSFER OF ORDER,I3,9H IN GROUP,I4,5H AND ,
     > 6HREGION,I5,3H BY,F6.2,3H %.)
      END