path: root/Dragon/src/EDIDRV.f

*DECK EDIDRV
      SUBROUTINE EDIDRV(IPEDIT,IPTRK1,IPFLUX,IPLIB,IPSYS,NGROUP,NBMIX,
     >                  NREGIO,MATCOD,VOLUME,KEYFLX,NIFISS,NEDMAC,NL,
     >                  NDEL,NALBP,ITRANC,NGCOND,NMERGE,IADF,IDFM,NW,
     >                  ICURR,IHF,IFFAC,ILUPS,NSAVES,NSTATS,IXEDI,
     >                  ISOTXS,IGCOND,IMERGE,CURNAM,OLDNAM,NBMICR,
     >                  CARISO,NACTI,IACTI,IPRINT,LISO,LDEPL,LMACR,
     >                  IADJ,NOUT,HVOUT,BB2,IEDCUR,IGOVE)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Driver for edition operations.
*
*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.
* IPTRK1  pointer to the reference tracking object.
* IPFLUX  pointer to the flux LCM object.
* IPLIB   pointer to the internal library or macrolib LCM object.
* IPSYS   pointer to the pij LCM object (only used with Selengut
*         normalization).
* NGROUP  number of energy groups.
* NBMIX   number of mixtures.
* NREGIO  number of regions.
* MATCOD  mixture index in region.
* VOLUME  volume of region.
* KEYFLX  average flux position per region.
* NIFISS  number of fissile isotopes.
* NEDMAC  number of extra macroscopic cross section types.
* NL      number of Legendre orders of the scattering cross sections.
* NDEL    number of delayed precursor groups.
* NALBP   number of physical albedos.
* ITRANC  type of transport correction.
* NGCOND  number of condensed groups.
* NMERGE  number of regions merged.
* IADF    flag for assembly discontinuity factors (ADF) information:
*         = 0 do not compute them;
*         = 1 compute them using ALBS information;
*         = -2/2 compute them using averaged fluxes in boundary regions;
*         = 3 compute them using SYBIL/ARM or MOC interface currents;
*         = 4 recover ADF information from input macrolib.
* IDFM    flag for ADF info in input macrolib (0/1/2: absent/present).
* NW      type of weighting for P1 cross section information:
*         = 0 P0; = 1 P1.
* ICURR   type of current approximation if NW=1:
*         =1: heterogeneous leakage;
*         =2: Todorova outscatter approximation;
*         =4: use higher spherical harmonic moments of flux.
* IHF     H-factor calculation flag:
*         = 0 no; = 1 yes.
* IFFAC   four factor calculation flag:
*         = 0 no four factors (defaut);
*         = 1 four factor evaluation.
* ILUPS   flag to remove up-scattering from output.
* NSAVES  homogenized cross section computation and saving:
*         = 0  no compute no save;
*         = 1  compute, no save;
*         = 2  compute, save.
* NSTATS  statistics level:
*         = 0  no stats;
*         = 1  statistics on fluxes
*         = 2  statistics on reaction rates;
*         = 3  statistics on fluxes and reaction rates;
*         =-1  delta sigma ('MERG COMP' only).
* IXEDI   first ISOTX mixture record number.
* ISOTXS  ISOTX file enabling flag (0: off; 1: binary; 2: ascii).
* IGCOND  condensed group limits.
* IMERGE  merged region positions.
* CURNAM  name of LCM directory where the current rates are to be
*         stored.
* OLDNAM  name of LCM directory where old rates were stored.
* NBMICR  type of microlib edition:
*         =-2: process only macroscopic residue;
*         =-1: process each isotope;
*         =0: process no isotope;
*         >0 number of isotopes to process.
* CARISO  names of the isotopes to process.
* NACTI   number of activation editions.
* IACTI   activation mixtures.
* IPRINT  print index.
* LISO    =.TRUE. if we want to keep all the isotopes after 
*         homogeneization.
* LDEPL   =.TRUE. if we want to recover depletion information.
* LMACR   =.TRUE. if we want to compute a residual isotope.
* IADJ    type of flux weighting:
*         =0: direct flux weighting;
*         =1: direct-adjoint flux weighting.
* 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.
* BB2     imposed leakege used in non-regression tests.
* IEDCUR  current edition flag with MOC and SN methods:
*         =0: flux edition only;
*         =1: flux and current edition.
* IGOVE   Golfier-Vergain flag (=0/1: don't/use Golfier-Vergain equ'n).
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      LOGICAL       LISO,LDEPL,LMACR
      TYPE(C_PTR)   IPEDIT,IPTRK1,IPFLUX,IPLIB,IPSYS
      INTEGER       NGROUP,NBMIX,NREGIO,MATCOD(NREGIO),KEYFLX(NREGIO),
     >              NIFISS,NEDMAC,NL,NDEL,NALBP,ITRANC,NGCOND,NMERGE,
     >              IADF,IDFM,NW,ICURR,IHF,IFFAC,ILUPS,NSAVES,NSTATS,
     >              IXEDI,ISOTXS,IGCOND(NGCOND),IMERGE(NREGIO),NBMICR,
     >              NACTI,IACTI(NBMIX),IPRINT,IADJ,NOUT,IEDCUR,IGOVE
      REAL          VOLUME(NREGIO),BB2
      CHARACTER     CURNAM*12,OLDNAM*12,CARISO(NBMICR)*12,HVOUT(NOUT)*8
*----
*  LOCAL VARIABLES
*----
      PARAMETER    (IUNOUT=6,MAXED=300,NSTATE=40,IOUT=6)
      TYPE(C_PTR)   JPFLUX,JPFLUA,IPMIC2,IPMAC2,IPADF,JPLIB,KPLIB,
     >              KPEDIT,JPMAC2,KPMAC2
      CHARACTER     HSIGN*12,TEXT8*8,HVECT(MAXED)*8,NISEXT*6,NISOTX*12,
     >              CTITLE*72,NAMSBR*12,HTYPE*8,TEXT12*12,HSMG*131
      INTEGER       IFPAR(NSTATE),IPAR(NSTATE),IDIM(NSTATE)
      REAL          B2(4),B2T(3),TIMEF(3)
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPE,MIX,IDEPL,ISONA,
     > ISONR,LSISO,INADPL,KDRI,INNAM,INNRF,NMIX,KERMA
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: FIPI,FIFP
      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: KEYANI
      REAL, ALLOCATABLE, DIMENSION(:) :: WORKF,WORKA,VOLME,WLETY,WE,
     > COURI,TAUXT,SIGT,SIGS,SCATS,FLINT,SCATD,DEN,TN,EMEVF,RER,
     > DECAY,RRD,FIYI,ENERG,NAWR,NDEN,NTMP,NVOL,SNEJ,WORK1,WORK2
      REAL, ALLOCATABLE, DIMENSION(:,:) :: ADF
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: FLUXC,FADJC,FLUXES,AFLUXE,
     > COUWP1,YIELD,PYIELD
      CHARACTER*8, ALLOCATABLE, DIMENSION(:) :: HADF
      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO,JPISO
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(FLUXES(NREGIO,NGROUP,NW+1),
     >         AFLUXE(NREGIO,NGROUP,NW+1))
*----
*  FIND THE SIGNATURE OF IPLIB
*----
      CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN)
*----
*  RECOVER NEUTRON FLUXES AND CURRENTS (IF ILEAKC.GE.6)
*----
      CALL LCMGET(IPFLUX,'STATE-VECTOR',IFPAR)
      IF(IFPAR(1).NE.NGROUP) CALL XABORT('EDIDRV: INVALID VALUE OF NGR'
     > //'OUP.')
      ITYPEC=IFPAR(6)
      ILEAKC=IFPAR(7)
      NMLEAK=IFPAR(18)
      IF(ILEAKC.EQ.0) THEN
*       NO LEAKAGE
        ILEAKS=0
      ELSE IF(ILEAKC.LE.5) THEN
*       DIFFON-TYPE LEAKAGE
        ILEAKS=1
      ELSE IF(ILEAKC.EQ.6) THEN
*       ECCO-TYPE LEAKAGE (WITH ISOTROPIC STREAMING EFFECTS)
        ILEAKS=2
      ELSE IF(ILEAKC.GE.7) THEN
*       TIBERE-TYPE LEAKAGE (WITH ANISOTROPIC STREAMING EFFECTS)
        ILEAKS=3
      ENDIF
      CUREIN=0.0
      IF(ITYPEC.GT.0) CALL LCMGET(IPFLUX,'K-INFINITY',CUREIN)
      B2(:4)=0.0
      IF(ITYPEC.GT.2) THEN
        CALL LCMGET(IPFLUX,'B2  B1HOM',B2(4))
        IF(ILEAKS.EQ.3) THEN
          CALL LCMGET(IPFLUX,'B2  HETE',B2)
          IF(B2(4).EQ.0.0) THEN
            B2T(1)=1.0/3.0
            B2T(2)=B2T(1)
            B2T(3)=B2T(1)
          ELSE
            B2T(1)=B2(1)/B2(4)
            B2T(2)=B2(2)/B2(4)
            B2T(3)=B2(3)/B2(4)
          ENDIF
        ENDIF
      ENDIF
      IF((NW.GE.1).AND.(ILEAKC.LE.5).AND.(ICURR.EQ.1)) THEN
        CALL XABORT('EDIDRV: CURRENT WEIHTING OF P1 XS INFO (NW=1) '
     >  //'IS ONLY AVAILABLE WITH A STREAMING-ENABLED LEAKAGE MODEL.')
      ENDIF
      IF(ILEAKC.EQ.4) THEN
        B2(:4)=0.0
        B2T(:3)=0.0
      ENDIF
      IF(IADJ.EQ.0) THEN
        CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM)
        IF(ILON.EQ.0) CALL XABORT('EDIDRV: MISSING FLUX INFO.')
        JPFLUX=LCMGID(IPFLUX,'FLUX')
        CALL LCMLEL(JPFLUX,1,NUN,ITYLCM)
      ELSE IF(IADJ.EQ.1) THEN
        CALL LCMLEN(IPFLUX,'FLUX',ILON,ITYLCM)
        IF(ILON.EQ.0) CALL XABORT('EDIDRV: MISSING FLUX INFO.')
        JPFLUX=LCMGID(IPFLUX,'FLUX')
        CALL LCMLEN(IPFLUX,'AFLUX',ILON,ITYLCM)
        IF(ILON.EQ.0) CALL XABORT('EDIDRV: MISSING ADJOINT FLUX INFO.')
        JPFLUA=LCMGID(IPFLUX,'AFLUX')
        CALL LCMLEL(JPFLUX,1,NUN,ITYLCM)
        ALLOCATE(WORKA(NUN))
      ELSE
        CALL XABORT('EDIDRV: INVALID VALUE OF IADJ.')
      ENDIF
      ALLOCATE(WORKF(NUN))
      DO IGR=1,NGROUP
        IF(IADJ.EQ.0) THEN
          CALL LCMGDL(JPFLUX,IGR,WORKF)
          DO IREG=1,NREGIO
            FLUXES(IREG,IGR,1)=WORKF(KEYFLX(IREG))
            AFLUXE(IREG,IGR,1)=1.0
          ENDDO
        ELSE IF(IADJ.EQ.1) THEN
          CALL LCMGDL(JPFLUX,IGR,WORKF)
          CALL LCMGDL(JPFLUA,IGR,WORKA)
          DO IREG=1,NREGIO
            FLUXES(IREG,IGR,1)=WORKF(KEYFLX(IREG))
            AFLUXE(IREG,IGR,1)=WORKA(KEYFLX(IREG))
          ENDDO
        ENDIF
        IF((ICURR.EQ.1).AND.(ILEAKS.EQ.2)) THEN
*         ISOTROPIC STREAMING (ECCO)
          IF(NW.NE.1) CALL XABORT('EDIDRV: NW=1 EXPECTED(1).')
          DO IREG=1,NREGIO
            FLUXES(IREG,IGR,2)=WORKF(NUN/2+KEYFLX(IREG))
          ENDDO
        ELSE IF((ICURR.EQ.1).AND.(ILEAKS.EQ.3)) THEN
*         ANISOTROPIC STREAMING
          IF(NW.NE.1) CALL XABORT('EDIDRV: NW=1 EXPECTED(2).')
          DO IREG=1,NREGIO
            CURN=0.0
            DO IDIR=1,3
              CURN=CURN+B2T(IDIR)*WORKF(IDIR*NUN/4+KEYFLX(IREG))
            ENDDO
            FLUXES(IREG,IGR,2)=CURN
          ENDDO
        ENDIF
      ENDDO
      DEALLOCATE(WORKF)
      IF(IADJ.EQ.1) DEALLOCATE(WORKA)
*----
*  COMPUTE HIGHER MOMENT FLUXES IF NW=1
*----
      IF(ICURR.EQ.2) THEN
*        Outscatter Todorova approximation
         IF(NW.NE.1) CALL XABORT('EDIDRV: NW=1 EXPECTED(3).')
         IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,'MACROLIB',1)
         JPLIB=LCMGID(IPLIB,'GROUP')
         ALLOCATE(SIGT(0:NBMIX),SIGS(0:NBMIX))
         DO IGR=1,NGROUP
            KPLIB=LCMGIL(JPLIB,IGR)
            SIGT(0)=0.0
            SIGS(0)=0.0
            CALL LCMGET(KPLIB,'NTOT0',SIGT(1))
            CALL LCMGET(KPLIB,'SIGS01',SIGS(1))
            DO IREG=1,NREGIO
              IBM=MATCOD(IREG)
              IF(IBM.GT.0) THEN
                FACT=3.0*(SIGT(IBM)-SIGS(IBM))
                IF(FACT.EQ.0.0) CALL XABORT('EDIDRV: DIVIDE CHECK.')
                FLUXES(IREG,IGR,2)=FLUXES(IREG,IGR,1)/FACT
                IF(IADJ.EQ.1) AFLUXE(IREG,IGR,2)=AFLUXE(IREG,IGR,1)/FACT
              ELSE
                FLUXES(IREG,IGR,2)=FLUXES(IREG,IGR,1)
                IF(IADJ.EQ.1) AFLUXE(IREG,IGR,2)=AFLUXE(IREG,IGR,1)
              ENDIF
            ENDDO
         ENDDO
         DEALLOCATE(SIGS,SIGT)
         IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,' ',2)
      ELSE IF(ICURR.EQ.4) THEN
*        Use higher spherical harmonic moments
         IF(NW.EQ.0) CALL XABORT('EDIDRV: NW>0 EXPECTED(5).')
         CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12)
         IF(TEXT12.EQ.'MCCG') THEN
           CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR)
           NDIM=IPAR(16)
           CALL LCMGET(IPTRK1,'MCCG-STATE',IPAR)
           NFUNL=IPAR(19)
           NLIN=IPAR(20)
         ELSE IF(TEXT12.EQ.'SN') THEN
           CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR)
           NFUNL=IPAR(7)
           NLIN=IPAR(8)
           NDIM=IPAR(9)
           NLIN=NLIN**NDIM
         ELSE
           CALL XABORT('EDIDRV: MCCG OR SN TRACKING EXPECTED WITH '
     >     //'P1W_SP OPTION')
         ENDIF
         ALLOCATE(KEYANI(NREGIO,NLIN,NFUNL))
         CALL LCMGET(IPTRK1,'KEYFLX$ANIS',KEYANI)
         CALL EDIWP1(IPFLUX,NW,NGROUP,NUN,NREGIO,NDIM,IADJ,NLIN,
     >   NFUNL,NGCOND,NMERGE,KEYANI,VOLUME,IGCOND,IMERGE,FLUXES(1,1,2),
     >   AFLUXE(1,1,2))
         DEALLOCATE(KEYANI)
      ENDIF
*----
*  CURRENT EDITION
*----
      IF(IEDCUR.EQ.1) THEN
*        Use higher spherical harmonic moments
         CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12)
         IF(TEXT12.EQ.'MCCG') THEN
           CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR)
           NDIM=IPAR(16)
           CALL LCMGET(IPTRK1,'MCCG-STATE',IPAR)
           NFUNL=IPAR(19)
           NLIN=IPAR(20)
         ELSE IF(TEXT12.EQ.'SN') THEN
           CALL LCMGET(IPTRK1,'STATE-VECTOR',IPAR)
           NFUNL=IPAR(7)
           NLIN=IPAR(8)
           NDIM=IPAR(9)
           NLIN=NLIN**NDIM
         ELSE
           CALL XABORT('EDIDRV: MCCG OR SN TRACKING EXPECTED WITH '
     >     //'EDI_CURR OPTION')
         ENDIF
         ALLOCATE(COUWP1(NMERGE,NGCOND,NDIM),KEYANI(NREGIO,NLIN,NFUNL))
         CALL LCMGET(IPTRK1,'KEYFLX$ANIS',KEYANI)
         CALL EDIWCU(IPFLUX,IPRINT,NGROUP,NUN,NREGIO,NDIM,NLIN,NFUNL,
     >   NGCOND,NMERGE,KEYANI,VOLUME,IGCOND,IMERGE,COUWP1)
         DEALLOCATE(KEYANI)
         IPMIC2=LCMDID(IPEDIT,CURNAM)
         IPMAC2=LCMDID(IPMIC2,'MACROLIB')
         JPMAC2=LCMLID(IPMAC2,'GROUP',NGCOND)
         DO IGR=1,NGCOND
           KPMAC2=LCMDIL(JPMAC2,IGR)
           CALL LCMPUT(KPMAC2,'COURX-INTG',NMERGE,2,COUWP1(1,IGR,1))
           IF(NDIM.GE.2) CALL LCMPUT(KPMAC2,'COURY-INTG',NMERGE,2,
     >     COUWP1(1,IGR,2))
           IF(NDIM.EQ.3) CALL LCMPUT(KPMAC2,'COURZ-INTG',NMERGE,2,
     >     COUWP1(1,IGR,3))
         ENDDO
         DEALLOCATE(COUWP1)
      ENDIF
*----
*  ALLOCATE MEMORY FOR GROUP CONDENSATION AND MERGE
*----
      ALLOCATE(VOLME(NMERGE),WLETY(NGCOND),WE(NGCOND+1))
      NELEMT=NMERGE*NGCOND
*----
*  COMPUTE REACTION RATES FOR THE EDITION MACROLIB
*----
      NTAUXT=12+NW+2*NDEL
      ALLOCATE(FLUXC(NMERGE,NGCOND,NW+1),FADJC(NMERGE,NGCOND,NW+1),
     > TAUXT(NTAUXT*NELEMT),SIGS(NL*NELEMT),SCATS(NELEMT*NGCOND*NL),
     > FLINT(NREGIO*NGROUP*(NW+1)),SCATD(2*NELEMT*NGCOND*NL))
      NBISO=0
      CALL LCMLEN(IPFLUX,'K-EFFECTIVE',ILCMLN,ITYLCM)
      IF(ILCMLN.EQ.1) THEN
        CALL LCMGET(IPFLUX,'K-EFFECTIVE',EIGENK)
      ELSE
        EIGENK=0.0
      ENDIF
      CALL LCMLEN(IPFLUX,'K-INFINITY',ILCMLN,ITYLCM)
      IF(ILCMLN.EQ.1) THEN
        CALL LCMGET(IPFLUX,'K-INFINITY',EIGINF)
      ELSE
        EIGINF=EIGENK
      ENDIF
      TIMEF(1)=0.0
      TIMEF(2)=0.0
      TIMEF(3)=0.0
      IF(HSIGN.EQ.'L_LIBRARY') THEN
        CALL LCMSIX(IPLIB,'MACROLIB',1)
        CALL LCMLEN(IPLIB,'TIMESTAMP',ILCMLN,ILCMTY)
        IF((ILCMLN.GE.1).AND.(ILCMLN.LE.3)) THEN
           CALL LCMGET(IPLIB,'TIMESTAMP',TIMEF)
        ENDIF
      ENDIF
      CALL EDIDTX(IPEDIT,IPFLUX,IPLIB,IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,
     >            NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,ILEAKS,ILUPS,NW,
     >            MATCOD,VOLUME,KEYFLX,IGCOND,IMERGE,FLUXES,AFLUXE,
     >            EIGENK,VOLME,WLETY,WE,TAUXT,FLUXC,FADJC,FLINT,SCATD,
     >            SCATS,NIFISS,NSAVES,CURNAM,NEDMAC,SIGS,B2,IGOVE,
     >            CUREIN,TIMEF,NTAUXT,NMLEAK)
      IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,' ',2)
      DEALLOCATE(SCATD,FLINT)
*----
*  COMPUTE BOUNDARY EDITIONS FOR ADF OR SPH WITH SELENGUT
*----
      IF(CURNAM.NE.' ') THEN
         IF(IPRINT.GT.0) WRITE(IOUT,'(30H EDIDRV: EDITION DIRECTORY IS ,
     >   A)') CURNAM
         IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,'MACROLIB',1)
         IPMAC2=LCMDID(IPEDIT,CURNAM)
         IPMAC2=LCMDID(IPMAC2,'MACROLIB')
         IF(IADF.EQ.1) THEN
*           recover outgoing current from escape probabilities
            CALL EDIALB(IPMAC2,IPFLUX,IPLIB,IPSYS,IPRINT,NBMIX,NW,
     >      B2,NGROUP,NIFISS,NGCOND,ITRANC,ILEAKS,NREGIO,MATCOD,
     >      VOLUME,KEYFLX,IGCOND,FLUXES,NMLEAK)
         ELSE IF((IADF.EQ.2).OR.(IADF.EQ.-2)) THEN
*           use averaged fluxes obtained over gap boundary regions
            IPADF=LCMGID(IPEDIT,'REF:ADF')
            CALL LCMGET(IPADF,'NTYPE',NTYPE)
            IF(NTYPE.EQ.0) CALL XABORT('EDIADF: NTYPE=0.')
            CALL LCMSIX(IPMAC2,'ADF',1)
            ALLOCATE(HADF(NTYPE),COURI(NGCOND))
            CALL LCMGTC(IPADF,'HADF',8,NTYPE,HADF)
            DO IT=1,NTYPE
              HTYPE=HADF(IT)
              CALL EDIGAP(IPADF,HTYPE,NGROUP,NGCOND,NREGIO,VOLUME,
     >        IGCOND,FLUXES,IPRINT,COURI)
              ALLOCATE(ADF(NMERGE,NGCOND))
              DO IGR=1,NGCOND
                ZCOUR=COURI(IGR)
                IF(IADF.EQ.-2) THEN
*                 recover averaged fluxes used to compute ADF
                  DO IMRG=1,NMERGE
                    ADF(IMRG,IGR)=ZCOUR*VOLME(IMRG)/FLUXC(IMRG,IGR,1)
                  ENDDO
                ELSE
                  ADF(:NMERGE,IGR)=ZCOUR
                ENDIF
              ENDDO
              CALL LCMPUT(IPMAC2,HTYPE,NMERGE*NGCOND,2,ADF)
              IF(IADF.EQ.2) THEN
                DO IGR=1,NGCOND
                  DO IMRG=1,NMERGE
                    ADF(IMRG,IGR)=FLUXC(IMRG,IGR,1)/VOLME(IMRG)
                  ENDDO
                ENDDO
                CALL LCMPUT(IPMAC2,'AVG_FLUX',NMERGE*NGCOND,2,ADF)
              ENDIF
              DEALLOCATE(ADF)
            ENDDO
            CALL LCMPUT(IPMAC2,'NTYPE',1,1,NTYPE)
            CALL LCMPTC(IPMAC2,'HADF',8,NTYPE,HADF)
            DEALLOCATE(COURI,HADF)
            CALL LCMSIX(IPMAC2,' ',2)
         ELSE IF(IADF.EQ.3) THEN
*           recover outgoing current from interface currents
            CALL LCMGTC(IPTRK1,'TRACK-TYPE',12,TEXT12)
            IF(TEXT12.EQ.'SYBIL') THEN
              CALL EDIJO1(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND)
            ELSE IF(TEXT12.EQ.'MCCG') THEN
              CALL EDIJO2(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND)
            ELSE IF(TEXT12.EQ.'EXCELL') THEN
              CALL EDIJO3(IPMAC2,IPTRK1,IPFLUX,IPRINT,NGCOND,IGCOND)
            ELSE
              WRITE(HSMG,'(40HEDIDRV: INCOMPATIBLE SOLUTION TYPE. SYBI,
     >        28HL, EXCELL OR MCCG EXPECTED. ,A12,6HFOUND.)') TEXT12
              CALL XABORT(HSMG)
            ENDIF
         ELSE IF(IADF.EQ.4) THEN
*           recover ADF information from input macrolib
            CALL LCMLEN(IPLIB,'GROUP',ILCMLN,ITYLCM)
            IF(ILCMLN.NE.NGCOND) CALL XABORT('EDIDRV: UNABLE TO RECOVE'
     >      //'R ADF INFORMATION FROM INPUT MACROLIB.')
            CALL LCMLEN(IPLIB,'ADF',ILCMLN,ITYLCM)
            IF(ILCMLN.EQ.0) CALL XABORT('EDIDRV: NO ADF INFORMATION IN'
     >      //' INPUT MACROLIB (REMOVE KEYWORD ADFM).')
            CALL LCMSIX(IPMAC2,'ADF',1)
            CALL LCMSIX(IPLIB,'ADF',1)
            CALL LCMEQU(IPLIB,IPMAC2)
            CALL LCMSIX(IPLIB,' ',2)
            CALL LCMSIX(IPMAC2,' ',2)
         ENDIF
         IF(HSIGN.EQ.'L_LIBRARY') CALL LCMSIX(IPLIB,' ',2)
      ENDIF
*----
*  RECOVER ISOTOPIC INFORMATION FROM THE MICROLIB
*----
      IF(HSIGN.EQ.'L_LIBRARY') THEN
        CALL LCMGET(IPLIB,'STATE-VECTOR',IPAR)
        NBISO=IPAR(2)
        NED=IPAR(13)
        NBESP=IPAR(16)
        IF(NBISO.EQ.0) CALL XABORT('EDIDRV: NO ISOTOPES FOUND.')
        ALLOCATE(DEN(NBISO),ITYPE(NBISO),MIX(NBISO),TN(NBISO),
     >  IDEPL(NBISO),ISONA(3*NBISO),ISONR(3*NBISO),LSISO(NBISO),
     >  IPISO(NBISO))
        CALL LCMGET(IPLIB,'ISOTOPESDENS',DEN)
        CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYPE)
        CALL LCMGET(IPLIB,'ISOTOPESMIX',MIX)
        CALL LCMGET(IPLIB,'ISOTOPESTEMP',TN)
        CALL LCMGET(IPLIB,'ISOTOPESTODO',IDEPL)
        IF(NED.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT)
        CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA)
        CALL LCMGET(IPLIB,'ISOTOPERNAME',ISONR)
        LSISO(:NBISO)=0
        IF(NBMICR.EQ.-2) THEN
          LSISO(:NBISO)=0
        ELSE IF(NBMICR.EQ.-1) THEN
          LSISO(:NBISO)=1
        ELSE IF(NBMICR.GT.0) THEN
          DO IISO=1,NBISO
            WRITE(TEXT8,'(2A4)') (ISONA((IISO-1)*3+I0),I0=1,2)
            DO IIII=1,NBMICR
              IF(CARISO(IIII)(1:8).EQ.TEXT8) LSISO(IISO)=1
            ENDDO
          ENDDO
        ENDIF
*----
*  SET THE LCM MICROLIB ISOTOPEWISE DIRECTORIES.
*----
        CALL LIBIPS(IPLIB,NBISO,IPISO)
      ENDIF
*----
*  EVALUATE H-FACTOR IF REQUIRED FOR THE EDITION MACROLIB
*----
      ALLOCATE(EMEVF(NBISO))
      EMEVF(:NBISO)=0.0
      IF((NSAVES.GE.2).AND.(IHF.NE.0)) THEN
        CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILLCM,ITLCM)
        IF(ILLCM.NE.0) THEN
          CALL LCMSIX(IPEDIT,CURNAM,1)
          CALL LCMSIX(IPLIB,'DEPL-CHAIN',1)
          CALL LCMGET(IPLIB,'STATE-VECTOR',IDIM)
          NDEPL=IDIM(1)
          NREAC=IDIM(8)
*
          ALLOCATE(INADPL(3*NDEPL),RER(NREAC*NDEPL))
          CALL LCMGET(IPLIB,'ISOTOPESDEPL',INADPL)
          CALL LCMGET(IPLIB,'DEPLETE-ENER',RER)
          CALL LCMSIX(IPLIB,' ',2)
*
          CALL EDIHFC(IPEDIT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO,
     >                MATCOD,VOLUME,ISONA,IPISO,MIX,FLUXES(1,1,1),
     >                DEN,IGCOND,IMERGE,VOLME,IPRINT,EMEVF)
*
          DEALLOCATE(RER,INADPL)
          CALL LCMSIX(IPEDIT,' ',2)
        ENDIF
      ENDIF
*----
*  LUMP THE DEPLETION CHAIN
*----
      ALLOCATE(DECAY(NBISO))
      DECAY(:NBISO)=0.0
      NDEPL=0
      NDFI=0
      IF((NBMICR.NE.0).AND.(NBISO.NE.0)) THEN
        IF(LDEPL) THEN
          ALLOCATE(KERMA(NBISO))
          KERMA(:NBISO)=1
          CALL LCMSIX(IPEDIT,CURNAM,1)
          CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILCMLN,ITYLCM)
          IF((ILCMLN.NE.0).AND.(CURNAM.NE.' ')) THEN
            CALL LCMSIX(IPLIB,'DEPL-CHAIN',1)
            CALL EDIDEP(IPRINT,IPLIB,IPEDIT,NBISO,ISONR,LSISO,IDEPL,
     >      LISO,KERMA,NBCH)
            CALL LCMSIX(IPLIB,' ',2)
          ENDIF
          DEALLOCATE(KERMA)
*----
*  RECOVER DEPLETION INFORMATION FROM THE INTERNAL LIBRARY
*----
          CALL LCMLEN(IPEDIT,'DEPL-CHAIN',ILLCM,ITLCM)
          IF(ILLCM.NE.0) THEN
            CALL LCMSIX(IPEDIT,'DEPL-CHAIN',1)
            CALL LCMGET(IPEDIT,'STATE-VECTOR',IDIM)
            NDEPL=IDIM(1)
            NDFI=IDIM(2)
            NDFP=IDIM(3)
            NREAC=IDIM(8)
            ALLOCATE(FIPI(NBISO,NMERGE),FIFP(NBISO,NMERGE),
     >      YIELD(NGCOND+1,NDFP,NMERGE),PYIELD(NDFI,NDFP,NMERGE))
*
            ALLOCATE(INADPL(3*NDEPL),KDRI(NREAC*NDEPL),RRD(NDEPL),
     >      FIYI(NDFI*NDFP))
            CALL LCMGET(IPEDIT,'ISOTOPESDEPL',INADPL)
            CALL LCMGET(IPEDIT,'DEPLETE-REAC',KDRI)
            CALL LCMGET(IPEDIT,'DEPLETE-DECA',RRD)
            IF(NDFI*NDFP.GT.0) THEN
              CALL LCMGET(IPEDIT,'FISSIONYIELD',FIYI)
            ENDIF
            CALL LCMSIX(IPEDIT,' ',2)
*
            CALL EDIHFD(IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NBISO,NDEPL,
     >                  NDFI,NDFP,NREAC,MATCOD,VOLUME,INADPL,ISONA,
     >                  ISONR,IPISO,MIX,FLUXES(1,1,1),DEN,IDEPL,IGCOND,
     >                  IMERGE,KDRI,RRD,FIYI,DECAY,YIELD,FIPI,FIFP,
     >                  PYIELD)
*
            DEALLOCATE(FIYI,RRD,KDRI,INADPL)
          ENDIF
          CALL LCMSIX(IPEDIT,' ',2)
        ENDIF
*----
*  COMPUTE MICROSCOPIC CROSS SECTIONS
*----
        CALL EDIMIC(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO,NDEPL,
     >              ISONA,ISONR,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,
     >              IPRINT,NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,
     >              NDFP,ILEAKS,ILUPS,NW,MATCOD,VOLUME,KEYFLX,CURNAM,
     >              IGCOND,IMERGE,FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN,
     >              ITYPE,IDEPL,LSISO,EMEVF,DECAY,YIELD,FIPI,FIFP,
     >              PYIELD,ITRANC,LISO,NMLEAK)
*----
*  ISOTX FILE PROCESSING
*----
        IF(ISOTXS.GE.1) THEN
          CALL LCMSIX(IPEDIT,CURNAM,1)
          CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR)
          NBNISO=IPAR(2)
          NAMSBR='EDIDRV'
          IF(IPRINT.GE.1) WRITE(IOUT,6000) NAMSBR
          ALLOCATE(INNAM(3*NBNISO),INNRF(3*NBNISO),NMIX(NBNISO))
          ALLOCATE(ENERG(NGCOND+1),NAWR(NBNISO),NDEN(NBNISO),
     >    NTMP(NBNISO),NVOL(NBNISO),SNEJ(NBNISO),JPISO(NBNISO))
          CALL LCMGET(IPEDIT,'ENERGY',ENERG)
          CALL LCMGET(IPEDIT,'ISOTOPESUSED',INNAM)
          CALL LCMGET(IPEDIT,'ISOTOPERNAME',INNRF)
          CALL LCMGET(IPEDIT,'ISOTOPESMIX',NMIX)
          CALL LCMGET(IPEDIT,'ISOTOPESDENS',NDEN)
          CALL LCMGET(IPEDIT,'ISOTOPESTEMP',NTMP)
          CALL LCMGET(IPEDIT,'ISOTOPESVOL',NVOL)
          CALL LIBIPS(IPEDIT,NBNISO,JPISO)
          DO ISO=1,NBNISO
            KPEDIT=JPISO(ISO)
            CALL LCMGET(KPEDIT,'AWR',AWR)
            EMEVF2=0.0
            CALL LCMLEN(KPEDIT,'MEVF',ILENF,ITYLCM)
            IF(ILENF.EQ.1) CALL LCMGET(KPEDIT,'MEVF',EMEVF2)
            NAWR(ISO)=AWR
            SNEJ(ISO)=EMEVF2
          ENDDO
*
          NBIXS=IXEDI
          DO IMRG=1,NMERGE
            NBIXS=NBIXS+1
            WRITE(NISEXT,'(I6)') NBIXS
            DO ICAR=1,6
              IF(NISEXT(ICAR:ICAR) .EQ. ' ' .OR.
     >           NISEXT(ICAR:ICAR) .EQ. '*') THEN
                 NISEXT(ICAR:ICAR)='0'
              ENDIF
            ENDDO
            NISOTX='ISOTXS'//NISEXT
*----
*  GENERATE ONE ISOTXS FILE FOR EACH MERGED REGION IN EACH MIXTURE
*----
            WRITE(CTITLE,9000) NAMSBR,CURNAM,
     >                        'MICR        ','MIX',IMRG,NISOTX
            IF(IPRINT.GE.1) WRITE(IOUT,6002) IMRG,NISOTX
            IUTYPE=ISOTXS+1
            IWGOXS=KDROPN(NISOTX,0,IUTYPE,0)
            CALL EDITXS(IWGOXS,IUTYPE,IPRINT,NGCOND,NL,NBNISO,CTITLE,
     >                  IMRG,ENERG,INNAM,INNRF,JPISO,NMIX,NAWR,NDEN,
     >                  NTMP,SNEJ)
            IRETRN=KDRCLS(IWGOXS,1)
          ENDDO
*
          DEALLOCATE(JPISO,SNEJ,NVOL,NTMP,NDEN,NAWR,ENERG)
          DEALLOCATE(NMIX,INNRF,INNAM)
          CALL LCMSIX(IPEDIT,' ',2)
        ENDIF
      ENDIF
*----
*  COMPUTE MACROSCOPIC RESIDUAL CROSS SECTIONS
*----
      IF(LMACR.AND.(NBMICR.NE.0).AND.(NBMICR.NE.-1).AND.(NBISO.NE.0)
     >   .AND.(CURNAM.NE.' ')) THEN
        IPRIN2=IPRINT-1
        CALL EDIRES(IPEDIT,IPFLUX,IPLIB,IADJ,NL,NDEL,NBESP,NBISO,NDEPL,
     >             ISONA,ISONR,IPISO,MIX,TN,NED,HVECT,NOUT,HVOUT,IPRIN2,
     >             NGROUP,NGCOND,NBMIX,NREGIO,NMERGE,NDFI,NDFP,ILEAKS,
     >             ILUPS,NW,MATCOD,VOLUME,KEYFLX,CURNAM,IGCOND,IMERGE,
     >             FLUXES,AFLUXE,EIGENK,EIGINF,B2,DEN,ITYPE,LSISO,EMEVF,
     >             DECAY,YIELD,FIPI,FIFP,PYIELD,ITRANC,LISO,NMLEAK)
      ENDIF
*----
*  EDIT MICROSCOPIC ACTIVATION XS
*----
      IF(NACTI.GT.0) THEN
        CALL EDIACT(IPEDIT,IPRINT,NGROUP,NGCOND,NREGIO,NMERGE,NL,NBISO,
     >              NED,VOLUME,MIX,IGCOND,IMERGE,FLUXES(1,1,1),ITRANC,
     >              ISONA,IPISO,HVECT,CURNAM,NACTI,IACTI,EMEVF)
      ENDIF
*----
*  STATISTICS AND DELTA SIGMAS
*----
      IF(NSTATS.NE.0) THEN
        CALL EDIDST(IPEDIT,IPRINT,NL,NGCOND,NMERGE,NSTATS,ILEAKS,
     >              EIGENK,B2,VOLME,WLETY,TAUXT,FLUXC,SCATS,OLDNAM,
     >              NW,NTAUXT)
      ENDIF
*----
*  FOUR FACTORS
*----
      IF(IFFAC.NE.0) THEN
        CALL EDIBAL(IPEDIT,IPFLUX,IPRINT,NL,IFFAC,NGCOND,NMERGE,EIGENK,
     >              TAUXT,FLUXC,SCATS,ILEAKS,B2,NW,NTAUXT)
      ENDIF
*
      IF(ALLOCATED(PYIELD)) DEALLOCATE(PYIELD,YIELD,FIFP,FIPI)
      DEALLOCATE(DECAY,EMEVF)
      DEALLOCATE(SCATS,SIGS,FADJC,FLUXC,TAUXT)
      DEALLOCATE(WE,WLETY,VOLME)
      IF(HSIGN.EQ.'L_LIBRARY') THEN
         DEALLOCATE(IPISO,ISONR,ISONA,IDEPL,TN,MIX,ITYPE,DEN,LSISO)
      ENDIF
*----
*  RESET IADF IN MACROLIB AND MICROLIB STATE VECTORS
*----
      IF((CURNAM.NE.' ').AND.(IADF.NE.0)) THEN
         IPMIC2=LCMDID(IPEDIT,CURNAM)
         IPMAC2=LCMDID(IPMIC2,'MACROLIB')
         CALL LCMLEN(IPMAC2,'ADF',ILCMLN,ITYLCM)
         IF(ILCMLN.NE.0) THEN
            IF(IADF.EQ.4) THEN
              JADF=IDFM
            ELSE
              JADF=0
              CALL LCMSIX(IPMAC2,'ADF',1)
              CALL LCMLEN(IPMAC2,'ALBS00',ILCMLN,ITYLCM)
              IF(ILCMLN.NE.0) JADF=1
              CALL LCMLEN(IPMAC2,'HADF',ILCMLN,ITYLCM)
              IF((IADF.EQ.2).AND.(ILCMLN.NE.0)) JADF=2
              IF((IADF.EQ.-2).AND.(ILCMLN.NE.0)) JADF=3
              CALL LCMSIX(IPMAC2,' ',2)
            ENDIF
            CALL LCMGET(IPMAC2,'STATE-VECTOR',IPAR)
            IPAR(12)=JADF
            CALL LCMPUT(IPMAC2,'STATE-VECTOR',NSTATE,1,IPAR)
            IF((NBMICR.NE.0).AND.(HSIGN.EQ.'L_LIBRARY')) THEN
               CALL LCMGET(IPMIC2,'STATE-VECTOR',IPAR)
               IPAR(24)=JADF
               CALL LCMPUT(IPMIC2,'STATE-VECTOR',NSTATE,1,IPAR)
            ENDIF
         ENDIF
      ENDIF
*----
*  INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS)
*----
      IF(BB2.NE.0.0) THEN
        IF(IPRINT.GT.0) WRITE(6,'(/32H EDIDRV: INCLUDE LEAKAGE IN THE ,
     >  13HMACROLIB (B2=,1P,E12.5,2H).)') BB2
        IPMIC2=LCMGID(IPEDIT,CURNAM)
        IPMAC2=LCMGID(IPMIC2,'MACROLIB')
        JPMAC2=LCMGID(IPMAC2,'GROUP')
        ALLOCATE(WORK1(NMERGE),WORK2(NMERGE))
        DO IGR=1,NGCOND
          KPMAC2=LCMGIL(JPMAC2,IGR)
          CALL LCMGET(KPMAC2,'DIFF',WORK1)
          CALL LCMGET(KPMAC2,'NTOT0',WORK2)
          WORK2(:NMERGE)=WORK2(:NMERGE)+BB2*WORK1(:NMERGE)
          CALL LCMPUT(KPMAC2,'NTOT0',NMERGE,2,WORK2)
        ENDDO
        DEALLOCATE(WORK2,WORK1)
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(AFLUXE,FLUXES)
      RETURN
*----
*  FORMAT
*----
 6000 FORMAT(1X,A6,': GENERATING ISOTXS FILE ')
 6002 FORMAT(8X,' FOR EDITING MIXTURE    = ',I6,
     >          ' INFORMATION STORED ON FILE = ',A12)
 9000 FORMAT(1X,A6,3X,A12,3X,A12,3X,A4,I6,5X,A12)
      END