Initial commit from Polytechnique Montreal

1 files changed, 571 insertions, 0 deletions

diff --git a/Dragon/src/EDIPXS.f b/Dragon/src/EDIPXS.f
new file mode 100644
index 0000000..7e81b8b
--- /dev/null
+++ b/Dragon/src/EDIPXS.f
@@ -0,0 +1,571 @@
+*DECK EDIPXS
+      SUBROUTINE 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)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Save homogenized/condensed macroscopic 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): G. Marleau
+*
+*Parameters: input
+* IPEDIT  pointer to the edition 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 correction.
+* NSAVES  homogenized cross section compute/save flag:
+*         = 0  no compute, no save;
+*         = 1  compute, no save;
+*         = 2  compute and save.
+* NGCOND  number of groups condensed.
+* NMERGE  number of regions merged.
+* ILEAKS  type of leakage calculation:
+*         = 0 no leakage;
+*         = 1 homogeneous leakage (Diffon);
+*         = 2 isotropic streaming (Ecco);
+*         = 3 anisotropic streaming (Tibere);
+*         = 4 inconsistent model (1/3*strd);
+*         = 10 isotropic diffusion coefficients recovered from input
+*           macrolib;
+*         = 11 anisotropic diffusion coefficients recovered from input
+*           macrolib.
+* NW      type of weighting for PN cross section info (=0 P0; =1 P1).
+* NTAUXT  number of reaction rate edits (=15+2*NDEL).
+* EIGENK  eigenvalue for problem.
+* B2      square buckling:
+*         for ILEAKS=1,2,4: 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.
+* NIFISS  number of fissile isotopes.
+* CURNAM  name of LCM directory where the merged/condensed cross
+*         sections are stored.
+* NEDMAC  number of extra edit vectors.
+* VOLMER  volume of region merged.
+* WLETYC  lethargy width condensed.
+* WENERG  energy group limits.
+* SCATTD  double precision scattering rates.
+* NENER   number of energy groups limits.
+* TIMEF   time stamp in day/burnup/irradiation.
+* LH      flag set to true if H-factors are set.
+* LSPH    flag set to true if SPH factors are set.
+*
+*Parameters: output
+* 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 afjoint fluxes:
+*         = FADJCM(*,1) = adjoint fluxes P0;
+*         = FADJCM(*,2) = adjoint fluxes P1.
+* SIGS    Legendre dependent scattering cross sections.
+* SCATTS  homogenized scattering cross sections.
+* DISFCT  disadvantage factor.
+* ALBP    physical albedos.
+* TAUXE   extra edit rates.
+* HVECT   extra edit names.
+* OVERV   1/v merge condensed.
+* HFACT   H-factors condensed.
+* HSPH    SPH factors condensed.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPEDIT
+      INTEGER     IADJ,IPRINT,NL,NDEL,NALBP,ITRANC,NSAVES,NGCOND,NMERGE,
+     >            ILEAKS,NW,NTAUXT,NIFISS,NEDMAC,NENER,IGOVE
+      REAL        EIGENK,B2(4),CUREIN,VOLMER(NMERGE),WLETYC(NGCOND),
+     >            WENERG(NGCOND+1),RATECM(NMERGE,NGCOND,NTAUXT),
+     >            FLUXCM(NMERGE,NGCOND,NW+1),FADJCM(NMERGE,NGCOND,NW+1),
+     >            SIGS(NMERGE,NGCOND,NL),
+     >            SCATTS(NMERGE,NGCOND,NGCOND,NL),DISFCT(NGCOND),
+     >            ALBP(NALBP,NGCOND,NGCOND),TAUXE(NMERGE,NGCOND,NEDMAC),
+     >            OVERV(NMERGE,NGCOND),HFACT(NMERGE,NGCOND),
+     >            HSPH(NMERGE,NGCOND),TIMEF(3)
+      LOGICAL     LH,LSPH
+      CHARACTER   CURNAM*12,HVECT(NEDMAC)*8
+      DOUBLE PRECISION SCATTD(NMERGE,NGCOND,NGCOND,NL)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPEDIT,KPEDIT
+      CHARACTER   APG*3
+      PARAMETER  (IUNOUT=6,APG=' > ',ILCMUP=1,ILCMDN=2,NSTATE=40)
+      CHARACTER   CEDNAM*12,HSIGN*12,CM*2
+      INTEGER     IDATA(NSTATE),ISTATE(NSTATE)
+      DOUBLE PRECISION SCATWG,SCATTN,FAC1,FAC2
+      LOGICAL     LAL1D
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) ::IJJ,NJJ,IPOS
+      REAL, ALLOCATABLE, DIMENSION(:) ::SCATC,ALPHA
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: FACT,ALB1
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(IJJ(NMERGE),NJJ(NMERGE),IPOS(NMERGE))
+      ALLOCATE(SCATC(NMERGE*NGCOND),FACT(NMERGE,NW+1),ALPHA(NGCOND))
+*----
+*  COMPUTE MERGED/CONDENSED X-S
+*----
+      IF(NSAVES.GE.1) THEN
+        IDATA(4)=0
+        DO 200 IGR=1,NGCOND
+          DO 40 IKK=1,NMERGE
+            DO 5 IL=1,NW+1
+              IF(FLUXCM(IKK,IGR,1).EQ.0.0) THEN
+                FACT(IKK,IL)=0.0
+              ELSE
+                FACT(IKK,IL)=1.0/FLUXCM(IKK,IGR,IL)
+              ENDIF
+    5       CONTINUE
+            RATECM(IKK,IGR,NW+3)=RATECM(IKK,IGR,NW+3)*FACT(IKK,1)
+            IF((RATECM(IKK,IGR,NW+3).NE.0.0).OR.
+     >         (RATECM(IKK,IGR,NW+8).NE.0.0)) IDATA(4)=1
+            IF(IADJ.EQ.0) THEN
+              DO IW=1,NW+1
+                RATECM(IKK,IGR,IW)=RATECM(IKK,IGR,IW)*FACT(IKK,IW)
+              ENDDO
+              RATECM(IKK,IGR,NW+2)=RATECM(IKK,IGR,NW+2)*FACT(IKK,1)
+              RATECM(IKK,IGR,NW+4)=RATECM(IKK,IGR,NW+4)*FACT(IKK,1)
+              IF(NENER.GT.0) OVERV(IKK,IGR)=OVERV(IKK,IGR)*FACT(IKK,1)
+              IF(LH) HFACT(IKK,IGR)=HFACT(IKK,IGR)*FACT(IKK,1)
+              IF(LSPH) HSPH(IKK,IGR)=HSPH(IKK,IGR)*FACT(IKK,1)
+              IF(ITRANC.NE.0) RATECM(IKK,IGR,NW+9)=RATECM(IKK,IGR,NW+9)
+     >        *FACT(IKK,1)
+              DO 10 IL=1,NL
+                IW=MIN(IL,NW+1,2)
+                SIGS(IKK,IGR,IL)=SIGS(IKK,IGR,IL)*FACT(IKK,IW)
+  10          CONTINUE
+            ELSE IF(IADJ.EQ.1) THEN
+              DO IL=1,NW+1
+                FAD1=FADJCM(IKK,IGR,IL)
+                RATECM(IKK,IGR,IL)=RATECM(IKK,IGR,IL)*FACT(IKK,IL)/FAD1
+              ENDDO
+              FAD1=FADJCM(IKK,IGR,1)
+              RATECM(IKK,IGR,NW+2)=RATECM(IKK,IGR,NW+2)*FACT(IKK,1)/FAD1
+              RATECM(IKK,IGR,NW+4)=RATECM(IKK,IGR,NW+4)*FACT(IKK,1)/FAD1
+              IF(NENER.GT.0) OVERV(IKK,IGR)=OVERV(IKK,IGR)*FACT(IKK,1)
+     >        /FAD1
+              IF(LH) HFACT(IKK,IGR)=HFACT(IKK,IGR)*FACT(IKK,1)/FAD1
+              IF(LSPH) HSPH(IKK,IGR)=HSPH(IKK,IGR)*FACT(IKK,1)/FAD1
+              IF(ITRANC.NE.0) RATECM(IKK,IGR,NW+9)=RATECM(IKK,IGR,NW+9)
+     >        *FACT(IKK,1)/FAD1
+              DO 20 IL=1,NL
+                IW=MIN(IL,NW+1,2)
+                SIGS(IKK,IGR,IL)=SIGS(IKK,IGR,IL)*FACT(IKK,IW)/
+     >          FADJCM(IKK,IGR,IW)
+  20          CONTINUE
+            ENDIF
+            DO 30 IDEL=1,NDEL
+              K=NW+12+IDEL
+              RATECM(IKK,IGR,K)=RATECM(IKK,IGR,K)*FACT(IKK,1)
+  30        CONTINUE
+  40      CONTINUE
+          IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4)) THEN
+            IF(IADJ.EQ.0) THEN
+              DO 50 IKK=1,NMERGE
+                RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1)
+  50          CONTINUE
+            ELSE IF(IADJ.EQ.1) THEN
+              DEN2=0.0
+              DO 60 IKK=1,NMERGE
+                DEN2=DEN2+FADJCM(IKK,IGR,1)
+                RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1)/
+     >          FADJCM(IKK,IGR,1)
+  60          CONTINUE
+            ENDIF
+          ELSE IF(ILEAKS.GT.0) THEN
+            DO 70 IKK=1,NMERGE
+              RATECM(IKK,IGR,NW+5)=RATECM(IKK,IGR,NW+5)*FACT(IKK,1)
+              RATECM(IKK,IGR,NW+10)=RATECM(IKK,IGR,NW+10)*FACT(IKK,1)
+              RATECM(IKK,IGR,NW+11)=RATECM(IKK,IGR,NW+11)*FACT(IKK,1)
+              RATECM(IKK,IGR,NW+12)=RATECM(IKK,IGR,NW+12)*FACT(IKK,1)
+  70        CONTINUE
+          ENDIF
+          DO 100 JGR=1,NGCOND
+            DO 90 IKK=1,NMERGE
+              DO 80 IL=1,NL
+                IW=MIN(IL,NW+1)
+                IF(IADJ.EQ.0) THEN
+                  SCATTS(IKK,JGR,IGR,IL)=REAL(SCATTD(IKK,JGR,IGR,IL)
+     >            *FACT(IKK,IW))
+                ELSE IF(IADJ.EQ.1) THEN
+                  SCATTS(IKK,JGR,IGR,IL)=REAL(SCATTD(IKK,JGR,IGR,IL)
+     >            *FACT(IKK,IW)/FADJCM(IKK,JGR,IW))
+                ENDIF
+  80          CONTINUE
+  90        CONTINUE
+ 100      CONTINUE
+          DO 110 IKK=1,NMERGE
+            RATECM(IKK,IGR,NW+7)=SCATTS(IKK,IGR,IGR,1)
+ 110      CONTINUE
+          DO 130 IED=1,NEDMAC
+            DO 120 IKK=1,NMERGE
+              IF(IADJ.EQ.0) THEN
+                TAUXE(IKK,IGR,IED)=TAUXE(IKK,IGR,IED)*FACT(IKK,1)
+              ELSE IF(IADJ.EQ.1) THEN
+                TAUXE(IKK,IGR,IED)=TAUXE(IKK,IGR,IED)*FACT(IKK,1)/
+     >          FADJCM(IKK,IGR,1)
+              ENDIF
+ 120        CONTINUE
+ 130      CONTINUE
+ 200    CONTINUE
+        IF(NSAVES.EQ.2) THEN
+*----
+*  COMPUTE THE GOLFIER-VERGAIN FACTORS
+*----
+          IF(IGOVE.EQ.1) THEN
+            DO 205 IGR=1,NGCOND
+              FAC1=0.0D0
+              FAC2=0.0D0
+              DO 204 IKK=1,NMERGE
+                FAC1=FAC1+RATECM(IKK,IGR,NW+5)*FLUXCM(IKK,IGR,1)
+                FAC2=FAC2+FLUXCM(IKK,IGR,1)/(3.0*(RATECM(IKK,IGR,1)-
+     >          SIGS(IKK,IGR,2)))
+ 204          CONTINUE
+              ALPHA(IGR)=REAL(FAC1/FAC2)
+ 205        CONTINUE
+            IF(IPRINT.GE.3) WRITE(IUNOUT,6000) ALPHA(:)
+          ENDIF
+*----
+*  SAVE MERGED/CONDENSED X-S ON LCM
+*----
+          CALL LCMSIX(IPEDIT,CURNAM,ILCMUP)
+          CALL LCMSIX(IPEDIT,'MACROLIB',ILCMUP)
+          CALL LCMPUT(IPEDIT,'TIMESTAMP',3,2,TIMEF)
+          IDATA(1)=NGCOND
+          IDATA(2)=NMERGE
+          IDATA(3)=NL
+          IDATA(5)=NEDMAC
+          IDATA(6)=ITRANC
+          IDATA(7)=NDEL
+          IDATA(15)=IADJ
+          IF(NEDMAC.GT.0) THEN
+            CALL LCMPTC(IPEDIT,'ADDXSNAME-P0',8,NEDMAC,HVECT)
+          ENDIF
+          JPEDIT=LCMLID(IPEDIT,'GROUP',NGCOND)
+          DO 210 IGR=1,NGCOND
+            KPEDIT=LCMDIL(JPEDIT,IGR)
+            IF(NEDMAC.GT.0) THEN
+              DO 211 IED=1,NEDMAC
+                CEDNAM=HVECT(IED)
+                IF((CEDNAM(:2).EQ.'NW').OR.
+     >             (CEDNAM.EQ.'H-FACTOR')) GO TO 211
+                CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,TAUXE(1,IGR,IED))
+ 211          CONTINUE
+            ENDIF
+            IF(NENER.GT.0) CALL LCMPUT(KPEDIT,'OVERV',NMERGE,2,
+     >      OVERV(1,IGR))
+            IF(LH) CALL LCMPUT(KPEDIT,'H-FACTOR',NMERGE,2,HFACT(1,IGR))
+            IF(LSPH) CALL LCMPUT(KPEDIT,'NSPH',NMERGE,2,HSPH(1,IGR))
+            DO IW=1,MIN(NW+1,10)
+              WRITE(CEDNAM,'(4HNTOT,I1)') IW-1
+              CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,IW))
+            ENDDO
+            CALL LCMPUT(KPEDIT,'ABS',NMERGE,2,RATECM(1,IGR,NW+2))
+            CALL LCMPUT(KPEDIT,'PRODUCTION',NMERGE,2,RATECM(1,IGR,NW+4))
+            DO 212 IKK=1,NMERGE
+            RATECM(IKK,IGR,NW+6)=RATECM(IKK,IGR,1)-RATECM(IKK,IGR,NW+2)
+ 212        CONTINUE
+            IF(IDATA(4).EQ.1) THEN
+              CALL LCMPUT(KPEDIT,'NUSIGF',NMERGE,2,RATECM(1,IGR,NW+3))
+              CALL LCMPUT(KPEDIT,'CHI',NMERGE,2,RATECM(1,IGR,NW+8))
+              DO 901 IDEL=1,NDEL
+                K=NW+12+IDEL
+                WRITE(CEDNAM,'(6HNUSIGF,I2.2)') IDEL
+                CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,K))
+                WRITE(CEDNAM,'(3HCHI,I2.2)') IDEL
+                CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,RATECM(1,IGR,NDEL+K))
+ 901          CONTINUE
+            ENDIF
+            IF(ITRANC.NE.0) THEN
+              CALL LCMPUT(KPEDIT,'TRANC',NMERGE,2,RATECM(1,IGR,NW+9))
+            ENDIF
+            IF(IGOVE.EQ.1) THEN
+              ! use the Golfier-Vergain formula
+              SCATC(:NMERGE)=ALPHA(IGR)/(3.0*(RATECM(:NMERGE,IGR,1)
+     >        -SIGS(:NMERGE,IGR,2)))
+              CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,SCATC)
+            ELSE IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10))
+     >      THEN
+              CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,NW+5))
+            ELSE IF(ILEAKS.EQ.3) THEN
+              CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,NW+5))
+              CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,NW+10))
+              CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,NW+11))
+              CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,NW+12))
+            ELSE IF(ILEAKS.EQ.11) THEN
+              CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,NW+10))
+              CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,NW+11))
+              CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,NW+12))
+            ENDIF
+            CALL LCMPUT(KPEDIT,'FLUX-INTG',NMERGE,2,FLUXCM(1,IGR,1))
+            DO IL=2,MIN(NW+1,10)
+              WRITE(CEDNAM,'(11HFLUX-INTG-P,I1)') IL-1
+              CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,FLUXCM(1,IGR,IL))
+            ENDDO
+            IF(IADJ.EQ.1) THEN
+              DO IL=1,MIN(NW+1,10)
+                WRITE(CEDNAM,'(4HNWAT,I1)') IL-1
+                CALL LCMPUT(KPEDIT,CEDNAM,NMERGE,2,FADJCM(1,IGR,IL))
+              ENDDO
+            ENDIF
+            DO 350 IL=1,NL
+            WRITE (CM,'(I2.2)') IL-1
+            IPOSIT=0
+            DO 214 IKK=1,NMERGE
+              J2=IGR
+              J1=IGR
+              DO 215 JGR=1,NGCOND
+                IF(SCATTS(IKK,IGR,JGR,IL).NE.0.0) THEN
+                  J2=MAX(J2,JGR)
+                  J1=MIN(J1,JGR)
+                ENDIF
+ 215          CONTINUE
+              NJJ(IKK)=J2-J1+1
+              IJJ(IKK)=J2
+              IPOS(IKK)=IPOSIT+1
+              DO 216 JGR=J2,J1,-1
+                IPOSIT=IPOSIT+1
+                SCATC(IPOSIT)=SCATTS(IKK,IGR,JGR,IL)
+ 216          CONTINUE
+ 214        CONTINUE
+            CALL LCMPUT(KPEDIT,'SIGS'//CM,NMERGE,2,SIGS(1,IGR,IL))
+            CALL LCMPUT(KPEDIT,'SIGW'//CM,NMERGE,2,SCATTS(1,IGR,IGR,IL))
+            CALL LCMPUT(KPEDIT,'SCAT'//CM,IPOSIT,2,SCATC)
+            CALL LCMPUT(KPEDIT,'NJJS'//CM,NMERGE,1,NJJ)
+            CALL LCMPUT(KPEDIT,'IJJS'//CM,NMERGE,1,IJJ)
+            CALL LCMPUT(KPEDIT,'IPOS'//CM,NMERGE,1,IPOS)
+ 350        CONTINUE
+            IF(IPRINT.GE.4) THEN
+              WRITE(IUNOUT,'(/14H G R O U P   :,I4)') IGR
+              CALL LCMLIB(KPEDIT)
+            ENDIF
+ 210      CONTINUE
+          IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) THEN
+            CALL LCMPUT(IPEDIT,'B2  B1HOM',1,2,B2(4))
+          ELSE IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN
+            CALL LCMPUT(IPEDIT,'B2  B1HOM',1,2,B2(4))
+            CALL LCMPUT(IPEDIT,'B2  HETE',3,2,B2)
+          ENDIF
+          IDATA(8)=NALBP
+          DO 217 I=9,NSTATE
+          IDATA(I)=0
+ 217      CONTINUE
+          IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR.
+     >    (ILEAKS.EQ.10)) THEN
+             IDATA(9)=1
+          ELSE IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN
+             IDATA(9)=2
+          ENDIF
+          IDATA(10)=NW
+          IF(LSPH) THEN
+            IDATA(14)=1
+            CALL LCMSIX(IPEDIT,'SPH',1)
+            ISTATE(:)=0
+            ISTATE(1)=4
+            ISTATE(2)=1
+            ISTATE(6)=1
+            ISTATE(7)=1
+            ISTATE(8)=NGCOND
+            CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,ISTATE)
+            CALL LCMSIX(IPEDIT,' ',2)
+          ENDIF
+          CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IDATA)
+          HSIGN='L_MACROLIB'
+          CALL LCMPTC(IPEDIT,'SIGNATURE',12,HSIGN)
+          IF(NENER.GT.0) THEN
+            CALL LCMPUT(IPEDIT,'ENERGY',NGCOND+1,2,WENERG)
+            CALL LCMPUT(IPEDIT,'DELTAU',NGCOND,2,WLETYC)
+          ENDIF
+          CALL LCMPUT(IPEDIT,'VOLUME',NMERGE,2,VOLMER)
+          IF((EIGENK.NE.0.0).AND.(NIFISS.GT.0)) THEN
+            CALL LCMPUT(IPEDIT,'K-EFFECTIVE',1,2,EIGENK)
+          ENDIF
+          IF((CUREIN.NE.0.0).AND.(NIFISS.GT.0)) THEN
+            CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,CUREIN)
+          ENDIF
+          CALL LCMPUT(IPEDIT,'FLUXDISAFACT',NGCOND,2,DISFCT)
+          IF(NALBP.GT.0) THEN
+            LAL1D=.TRUE.
+            DO IAL=1,NALBP
+              DO IGR=1,NGCOND
+                DO JGR=1,NGCOND
+                  IF((IGR.NE.JGR).AND.(ALBP(IAL,IGR,JGR).NE.0.0)) THEN
+                    LAL1D=.FALSE.
+                    GO TO 218
+                  ENDIF
+                ENDDO
+              ENDDO
+            ENDDO
+ 218        IF(LAL1D) THEN
+*             diagonal physical albedos
+              ALLOCATE(ALB1(NALBP,NGCOND))
+              DO IAL=1,NALBP
+                DO IGR=1,NGCOND
+                  ALB1(IAL,IGR)=ALBP(IAL,IGR,IGR)
+                ENDDO
+              ENDDO
+              CALL LCMPUT(IPEDIT,'ALBEDO',NALBP*NGCOND,2,ALB1)
+              DEALLOCATE(ALB1)
+            ELSE
+*             matrix physical albedos
+              CALL LCMPUT(IPEDIT,'ALBEDO',NALBP*NGCOND*NGCOND,2,ALBP)
+            ENDIF
+          ENDIF
+          CALL LCMSIX(IPEDIT,' ',ILCMDN)
+          CALL LCMSIX(IPEDIT,' ',ILCMDN)
+          IF(IPRINT.GT.0) WRITE(IUNOUT,6031) CURNAM
+        ENDIF
+      ENDIF
+*----
+*  PRINT X-S
+*----
+      IF(IPRINT.GE.3) THEN
+        IF(IGOVE.EQ.1) THEN
+          WRITE(IUNOUT,'(/41H EDIPXS: USE THE GOLFIER-VERGAIN APPROXIM,
+     >    43HATION FOR DIFFUSION COEFFICIENT CALCULATION)')
+        ENDIF
+        WRITE(IUNOUT,6010)
+        DO 170 IGR=1,NGCOND
+          IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR.
+     >    (ILEAKS.EQ.10)) THEN
+            WRITE(IUNOUT,6020) IGR
+          ELSE
+            WRITE(IUNOUT,6021) IGR
+          ENDIF
+          DO 171 IKK=1,NMERGE
+*----
+*  UNCOMMENT THE 4 LINES TO PERFORM TRANSPORT CORRECTION
+*----
+            TOTAL=RATECM(IKK,IGR,1)
+            SCATWG=SCATTS(IKK,IGR,IGR,1)
+*           IF(ITRANC.NE.0) THEN
+*             TOTAL=TOTAL-RATECM(IKK,IGR,NW+9)
+*             SCATWG=SCATWG-RATECM(IKK,IGR,NW+9)
+*           ENDIF
+*
+            IF (FLUXCM(IKK,IGR,1).NE.0.0) THEN
+              FLXAVG=FLUXCM(IKK,IGR,1)/VOLMER(IKK)
+              SCATTN=0.0D0
+              DO 172 JGR=1,NGCOND
+                 IF(JGR.NE.IGR) SCATTN=SCATTN+SCATTS(IKK,JGR,IGR,1)
+ 172          CONTINUE
+              IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.4).OR.
+     >        (ILEAKS.EQ.10)) THEN
+                WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL,
+     >          RATECM(IKK,IGR,NW+5),RATECM(IKK,IGR,NW+2),
+     >          RATECM(IKK,IGR,NW+3),RATECM(IKK,IGR,NW+8),SCATWG,SCATTN
+              ELSE
+                WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL,
+     >          RATECM(IKK,IGR,NW+2),RATECM(IKK,IGR,NW+3),
+     >          RATECM(IKK,IGR,NW+8),SCATWG,SCATTN
+              ENDIF
+            ENDIF
+ 171      CONTINUE
+          IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN
+            WRITE(IUNOUT,6024)
+            DO 173 IKK=1,NMERGE
+              WRITE(IUNOUT,6025) IKK,RATECM(IKK,IGR,NW+10),
+     >        RATECM(IKK,IGR,NW+11),RATECM(IKK,IGR,NW+12),
+     >        RATECM(IKK,IGR,NW+5)
+ 173        CONTINUE
+          ENDIF
+          WRITE(IUNOUT,6026) DISFCT(IGR)
+ 170    CONTINUE
+      ENDIF
+      IF(IPRINT.GE.4) THEN
+        DO 190 IKK=1,NMERGE
+          WRITE(IUNOUT,6027) IKK,(JGR,JGR=1,NGCOND)
+          DO 180 IGR=1,NGCOND
+*----
+*  UNCOMMENT THE FOLLOWING LINE TO PERFORM TRANSPORT CORRECTION
+*----
+            SCATWG=SCATTS(IKK,IGR,IGR,1)
+*           IF(ITRANC.NE.0) SCATWG=SCATWG-RATECM(IKK,IGR,NW+9)
+*
+            WRITE(IUNOUT,6028) IGR,(SCATTS(IKK,JGR,IGR,1),JGR=1,IGR-1),
+     >      SCATWG,(SCATTS(IKK,JGR,IGR,1),JGR=IGR+1,NGCOND)
+ 180      CONTINUE
+          WRITE (IUNOUT,'(//)')
+ 190    CONTINUE
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(ALPHA,FACT,SCATC)
+      DEALLOCATE(IPOS,NJJ,IJJ)
+      RETURN
+*----
+*  FORMAT
+*----
+ 6000 FORMAT(/33H EDIPXS: Golfier-Vergain factors=,1P,10E12.4/(33X,
+     > 10E12.4))
+ 6010 FORMAT(/' F L U X E S   A N D   H O M O G E N I Z E D   X - S'/
+     > 1X,51(1H-))
+ 6020 FORMAT(/' G R O U P   :',I4/
+     >1X,'REGION',3X,'AVERAGE',9X,'NTOT0',7X,'DIFFUSION',5X,
+     >'ABSORPTION',5X,'NUSIGF',8X,'FISSION',10X,'SCATTERING X-S'/11X,
+     >'FLUX',12X,'X-S',7X,'COEFFICIENT',7X,'X-S',10X,'X-S',10X,
+     >'SPECTRUM',2X,'WITHIN GROUP',2X,'OUT OF GROUP')
+ 6021 FORMAT(/' G R O U P   :',I4/
+     >1X,'REGION',3X,'AVERAGE',9X,'NTOT0',7X,
+     >'ABSORPTION',5X,'NUSIGF',8X,'FISSION',10X,'SCATTERING X-S'/11X,
+     >'FLUX',12X,'X-S',11X,'X-S',10X,'X-S',10X,'SPECTRUM',2X,
+     >'WITHIN GROUP',2X,'OUT OF GROUP')
+ 6022 FORMAT(1X,I4,1P,8E14.5)
+ 6024 FORMAT(/' REGION     X-LEAKAGE     Y-LEAKAGE     Z-LEAKAGE',
+     >'    HOM-LEAKAGE'/'           COEFFICIENT   COEFFICIENT   ',
+     >'COEFFICIENT   COEFFICIENT')
+ 6025 FORMAT(1X,I6,1X,1P,5E14.5)
+ 6026 FORMAT(/' FLUX DISADVANTAGE FACTOR =',1P,E14.5)
+ 6027 FORMAT(/47H SCATTERING TRANSFER X-S (I TOWARD J) IN REGION,I5,1H:
+     > //(11X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,
+     > I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,2HJ=,I4,:,6X,
+     > 2HJ=,I4))
+ 6028 FORMAT(3H I=,I4,2H: ,1P,10E12.4/(9X,10E12.4))
+ 6031 FORMAT(/53H MERGED/CONDENSED SET OF X-S SAVED IN LCM DIRECTORY ',
+     > A12,2H'./)
+      END