*DECK EDIPXS
      SUBROUTINE EDIPXS(IPEDIT,IADJ,IPRINT,NL,NDEL,ITRANC,NSAVES,NGCOND,
     >                  NMERGE,ILEAKS,NWGTH,NTAUXT,EIGENK,B2,CUREIN,
     >                  NIFISS,CURNAM,NEDMAC,VOLMER,WLETYC,WENERG,
     >                  SCATTD,RATECM,FADJCM,SIGS,SCATTS,DISFCT,TAUXE,
     >                  NAMEAD,OVERV,HFACT,NENER,TIMEF,LH)
*
*-----------------------------------------------------------------------
*
*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.
* ITRANC  type of transport correction.
* NSAVES  homogenized cross section compute/save flag:
*         = 0  no compute, no save;
*         = 1  compute, no save;
*         = 2  compute, 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);
*         = 10 isotropic diffusion coefficients recovered from input
*           macrolib;
*         = 11 anisotropic diffusion coefficients recovered from input
*           macrolib.
* NWGTH   type of weighting for P1 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: B2(4) is homogeneous;
*         for ILEAKS=3: B2(1),B2(2),B2(3) are directional heterogeneous
*         and B2(4) is homogeneous.
* 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.
*
*Parameters: output
* RATECM  averaged region/group cross sections:
*         = RATECM(*,1) = fluxes P0;
*         = RATECM(*,2) = fluxes P1;
*         = RATECM(*,3) = total P0;
*         = RATECM(*,4) = total P1;
*         = RATECM(*,5) = absorption;
*         = RATECM(*,6) = nu-sigf;
*         = RATECM(*,7) = fixed sources / productions;
*         = RATECM(*,8) = total leakages;
*         = RATECM(*,9) = total out of group scattering;
*         = RATECM(*,10) = diagonal scattering cross sections;
*         = RATECM(*,11) = fission spectrum;
*         = RATECM(*,12) = transport correction;
*         = RATECM(*,13) = X-directed leakages;
*         = RATECM(*,14) = Y-directed leakages;
*         = RATECM(*,15) = Z-directed leakages;
*         = RATECM(*,16) = nu-sigf for delayed neutrons;
*         = RATECM(*,16+NDEL) = fission spectrum for delayed neutrons.
* 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.
* TAUXE   extra edit rates.
* NAMEAD  extra edit names.
* OVERV   1/v merge condensed.
* HFACT   H-factors condensed.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPEDIT
      INTEGER     IADJ,IPRINT,NL,NDEL,ITRANC,NSAVES,NGCOND,NMERGE,
     >            ILEAKS,NWGTH,NTAUXT,NIFISS,NEDMAC,NAMEAD(2,NEDMAC),
     >            NENER
      REAL        EIGENK,B2(4),CUREIN,VOLMER(NMERGE),WLETYC(NGCOND),
     >            WENERG(NGCOND+1),RATECM(NMERGE,NGCOND,NTAUXT),
     >            FADJCM(NMERGE,NGCOND,2),SIGS(NMERGE,NGCOND,NL),
     >            SCATTS(NMERGE,NGCOND,NGCOND,NL),DISFCT(NGCOND),
     >            TAUXE(NMERGE,NGCOND,NEDMAC),OVERV(NMERGE,NGCOND),
     >            HFACT(NMERGE,NGCOND),TIMEF(3)
      LOGICAL     LH
      CHARACTER   CURNAM*12
      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)
      DOUBLE PRECISION SCATWG,SCATTN
      INTEGER, ALLOCATABLE, DIMENSION(:) ::IJJ,NJJ,IPOS
      REAL, ALLOCATABLE, DIMENSION(:) ::SCATC,DIFF
      REAL, ALLOCATABLE, DIMENSION(:,:) :: FACT
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(IJJ(NMERGE),NJJ(NMERGE),IPOS(NMERGE))
      ALLOCATE(SCATC(NMERGE*NGCOND),FACT(NMERGE,NWGTH+1),DIFF(NGCOND))
*----
*  COMPUTE MERGED/CONDENSED X-S
*----
      IF(NSAVES.GE.1) THEN
        IDATA(4)=0
        DO 200 IGR=1,NGCOND
          DO 40 IKK=1,NMERGE
            IF(RATECM(IKK,IGR,1).EQ.0.0) THEN
              FACT(IKK,1)=0.0
            ELSE
              FACT(IKK,1)=1.0/RATECM(IKK,IGR,1)
            ENDIF
            IF(NWGTH.GE.1) THEN
              IF(RATECM(IKK,IGR,2).EQ.0.0) THEN
                FACT(IKK,2)=0.0
              ELSE
                FACT(IKK,2)=1.0/RATECM(IKK,IGR,2)
              ENDIF
            ENDIF
            RATECM(IKK,IGR,6)=RATECM(IKK,IGR,6)*FACT(IKK,1)
            IF((RATECM(IKK,IGR,6).NE.0.0).OR.
     >         (RATECM(IKK,IGR,11).NE.0.0)) IDATA(4)=1
            IF(IADJ.EQ.0) THEN
              RATECM(IKK,IGR,3)=RATECM(IKK,IGR,3)*FACT(IKK,1)
              IF(NWGTH.GE.1) THEN
                RATECM(IKK,IGR,4)=RATECM(IKK,IGR,4)*FACT(IKK,2)
              ENDIF
              RATECM(IKK,IGR,5)=RATECM(IKK,IGR,5)*FACT(IKK,1)
              RATECM(IKK,IGR,7)=RATECM(IKK,IGR,7)*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(ITRANC.NE.0) RATECM(IKK,IGR,12)=RATECM(IKK,IGR,12)
     >        *FACT(IKK,1)
              DO 10 IL=1,NL
                IW=MIN(IL,NWGTH+1,2)
                SIGS(IKK,IGR,IL)=SIGS(IKK,IGR,IL)*FACT(IKK,IW)
  10          CONTINUE
            ELSE IF(IADJ.EQ.1) THEN
              FAD1=FADJCM(IKK,IGR,1)
              FAD2=FADJCM(IKK,IGR,2)
              RATECM(IKK,IGR,3)=RATECM(IKK,IGR,3)*FACT(IKK,1)/FAD1
              IF(NWGTH.GE.1) THEN
                RATECM(IKK,IGR,4)=RATECM(IKK,IGR,4)*FACT(IKK,2)/FAD2
              ENDIF
              RATECM(IKK,IGR,5)=RATECM(IKK,IGR,5)*FACT(IKK,1)/FAD1
              RATECM(IKK,IGR,7)=RATECM(IKK,IGR,7)*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(ITRANC.NE.0) RATECM(IKK,IGR,12)=RATECM(IKK,IGR,12)
     >        *FACT(IKK,1)/FAD1
              DO 20 IL=1,NL
                IW=MIN(IL,NWGTH+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=15+IDEL
              RATECM(IKK,IGR,K)=RATECM(IKK,IGR,K)*FACT(IKK,1)
  30        CONTINUE
  40      CONTINUE
          IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2)) THEN
            ZNU=0.0
            DEN=0.0
            IF(IADJ.EQ.0) THEN
              DO 50 IKK=1,NMERGE
                ZNU=ZNU+RATECM(IKK,IGR,8)
                DEN=DEN+RATECM(IKK,IGR,1)
                RATECM(IKK,IGR,8)=RATECM(IKK,IGR,8)*FACT(IKK,1)
  50          CONTINUE
              DIFF(IGR)=ZNU/DEN
            ELSE IF(IADJ.EQ.1) THEN
              DEN2=0.0
              DO 60 IKK=1,NMERGE
                ZNU=ZNU+RATECM(IKK,IGR,8)
                DEN=DEN+RATECM(IKK,IGR,1)
                DEN2=DEN2+FADJCM(IKK,IGR,1)
                RATECM(IKK,IGR,8)=RATECM(IKK,IGR,8)*FACT(IKK,1)/
     >          FADJCM(IKK,IGR,1)
  60          CONTINUE
              DIFF(IGR)=ZNU/(DEN*DEN2)
            ENDIF
          ELSE IF(ILEAKS.GT.0) THEN
            DO 70 IKK=1,NMERGE
              RATECM(IKK,IGR,8)=RATECM(IKK,IGR,8)*FACT(IKK,1)
              RATECM(IKK,IGR,13)=RATECM(IKK,IGR,13)*FACT(IKK,1)
              RATECM(IKK,IGR,14)=RATECM(IKK,IGR,14)*FACT(IKK,1)
              RATECM(IKK,IGR,15)=RATECM(IKK,IGR,15)*FACT(IKK,1)
  70        CONTINUE
          ENDIF
          DO 100 JGR=1,NGCOND
            DO 90 IKK=1,NMERGE
              DO 80 IL=1,NL
                IW=MIN(IL,NWGTH+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,10)=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
*----
*  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 LCMPUT(IPEDIT,'ADDXSNAME-P0',2*NEDMAC,3,NAMEAD)
          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
                WRITE(CEDNAM,'(2A4)') (NAMEAD(I1,IED),I1=1,2)
                IF(CEDNAM(:2).EQ.'NW') 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))
            CALL LCMPUT(KPEDIT,'NTOT0',NMERGE,2,RATECM(1,IGR,3))
            IF(NWGTH.GE.1) THEN
              CALL LCMPUT(KPEDIT,'NTOT1',NMERGE,2,RATECM(1,IGR,4))
            ENDIF
            CALL LCMPUT(KPEDIT,'ABS',NMERGE,2,RATECM(1,IGR,5))
            CALL LCMPUT(KPEDIT,'PRODUCTION',NMERGE,2,RATECM(1,IGR,7))
            DO 212 IKK=1,NMERGE
              RATECM(IKK,IGR,9)=RATECM(IKK,IGR,3)-RATECM(IKK,IGR,5)
 212        CONTINUE
            IF(IDATA(4).EQ.1) THEN
              CALL LCMPUT(KPEDIT,'NUSIGF',NMERGE,2,RATECM(1,IGR,6))
              CALL LCMPUT(KPEDIT,'CHI',NMERGE,2,RATECM(1,IGR,11))
              DO 901 IDEL=1,NDEL
                K=15+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,12))
            ENDIF
            IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) THEN
              CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,8))
            ELSE IF(ILEAKS.EQ.3) THEN
              CALL LCMPUT(KPEDIT,'DIFF',NMERGE,2,RATECM(1,IGR,8))
              CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,13))
              CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,14))
              CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,15))
            ELSE IF(ILEAKS.EQ.11) THEN
              CALL LCMPUT(KPEDIT,'DIFFX',NMERGE,2,RATECM(1,IGR,13))
              CALL LCMPUT(KPEDIT,'DIFFY',NMERGE,2,RATECM(1,IGR,14))
              CALL LCMPUT(KPEDIT,'DIFFZ',NMERGE,2,RATECM(1,IGR,15))
            ENDIF
            CALL LCMPUT(KPEDIT,'FLUX-INTG',NMERGE,2,RATECM(1,IGR,1))
            IF(NWGTH.GE.1) THEN
             CALL LCMPUT(KPEDIT,'FLUX-INTG-P1',NMERGE,2,RATECM(1,IGR,2))
            ENDIF
            IF(IADJ.EQ.1) THEN
              CALL LCMPUT(KPEDIT,'NWAT0',NMERGE,2,FADJCM(1,IGR,1))
              IF(NWGTH.GE.1) CALL LCMPUT(KPEDIT,'NWAT1',NMERGE,2,
     >        FADJCM(1,IGR,2))
            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
 210      CONTINUE
          IF(ILEAKS.EQ.1) THEN
            CALL LCMPUT(IPEDIT,'DIFFB1HOM',NGCOND,2,DIFF)
            CALL LCMPUT(IPEDIT,'B2  B1HOM',1,2,B2(4))
            CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,CUREIN)
          ELSE IF(ILEAKS.EQ.2) THEN
            CALL LCMPUT(IPEDIT,'B2  B1HOM',1,2,B2(4))
            CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,CUREIN)
          ELSE IF(ILEAKS.EQ.3) THEN
            CALL LCMPUT(IPEDIT,'B2  B1HOM',1,2,B2(4))
            CALL LCMPUT(IPEDIT,'B2  HETE',3,2,B2)
            CALL LCMPUT(IPEDIT,'K-INFINITY',1,2,CUREIN)
          ENDIF
          DO 217 I=8,NSTATE
 217      IDATA(I)=0
          IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).OR.(ILEAKS.EQ.10)) THEN
             IDATA(9)=1
          ELSE IF((ILEAKS.EQ.3).OR.(ILEAKS.EQ.11)) THEN
             IDATA(9)=2
          ENDIF
          IDATA(10)=NWGTH
          CALL LCMPUT(IPEDIT,'STATE-VECTOR',NSTATE,1,IDATA)
          HSIGN='L_MACROLIB'
          CALL LCMPTC(IPEDIT,'SIGNATURE',12,1,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
          CALL LCMPUT(IPEDIT,'FLUXDISAFACT',NGCOND,2,DISFCT)
          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
        WRITE(IUNOUT,6000)
        DO 170 IGR=1,NGCOND
          IF((ILEAKS.EQ.1).OR.(ILEAKS.EQ.2).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,3)
            SCATWG=SCATTS(IKK,IGR,IGR,1)
*           IF(ITRANC.NE.0) THEN
*             TOTAL=TOTAL-RATECM(IKK,IGR,12)
*             SCATWG=SCATWG-RATECM(IKK,IGR,12)
*           ENDIF
*
            IF (RATECM(IKK,IGR,1).NE.0.0) THEN
              FLXAVG=RATECM(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.10)) THEN
                 WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL,RATECM(IKK,IGR,8),
     >           RATECM(IKK,IGR,5),RATECM(IKK,IGR,6),RATECM(IKK,IGR,11),
     >           SCATWG,SCATTN
              ELSE
                 WRITE(IUNOUT,6022) IKK,FLXAVG,TOTAL,RATECM(IKK,IGR,5),
     >           RATECM(IKK,IGR,6),RATECM(IKK,IGR,11),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,13),
     >         RATECM(IKK,IGR,14),RATECM(IKK,IGR,15),RATECM(IKK,IGR,8)
 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,12)
*
            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(DIFF,FACT,SCATC)
      DEALLOCATE(IPOS,NJJ,IJJ)
      RETURN
*----
*  FORMAT
*----
 6000 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   : ',I3/
     >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   : ',I3/
     >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
