*DECK USSSPH
      SUBROUTINE USSSPH(IPLI0,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,
     1 NL,NED,NDEL,ISONAM,HCAL,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,
     2 IAPT,ITRANC,IPHASE,NGRP,MASKG,NBNRS,IREX,TITR,ISUBG,SIGGAR,ISMIN,
     3 ISMAX,UNGAR,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,SAGAR,SDGAR,SWGAR,SPH)
*
*-----------------------------------------------------------------------
*
*Purpose:
* SPH equivalence procedure over the self-shielded cross sections. Use
* all the standard solution doors of Dragon.
*
*Copyright:
* Copyright (C) 2003 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): A. Hebert
*
*Parameters: input
* IPLI0   pointer to the LCM object containing subgroup-related
*         information.
* IPTRK   pointer to the tracking (L_TRACK signature).
* IFTRAK  file unit number used to store the tracks.
* NREG    number of regions.
* NUN     number of unknowns per energy group.
* NBMIX   number of mixtures in the internal library.
* NBISO   number of isotopes.
* NIRES   number of resonant isotopes.
* NL      number of Legendre orders required in the calculation
*         (NL=1 or higher).
* NED     number of extra vector edits.
* NDEL    number of delayed neutron precursor groups.
* ISONAM  alias name of isotopes in IPLIB.
* HCAL    name of the self-shielding calculation.
* MAT     index-number of the mixture type assigned to each volume.
* VOL     volumes.
* KEYFLX  pointers of fluxes in unknown vector.
* CDOOR   name of the geometry/solution operator.
* LEAKSW  leakage flag (LEAKSW=.true. if neutron leakage through
*         external boundary is present).
* IMPX    print flag (equal to zero for no print).
* DEN     density of each isotope.
* MIX     mix number of each isotope (can be zero).
* IAPT    resonant isotope index associated with isotope I. Mixed
*         moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if
*         IAPT(I)=0.
* ITRANC  type of transport correction.
* IPHASE  type of flux solution (=1: use a native flux solution door;
*         =2: use collision probabilities).
* NGRP    number of energy groups.
* MASKG   energy group mask pointing on self-shielded groups.
* NBNRS   number of totally correlated fuel regions. NBNRS=max(IREX).
* IREX    fuel region index assigned to each mixture. Equal to zero
*         in non-resonant mixtures or in mixtures not used.
* TITR    title.
* ISUBG   type of self-shielding model (=1: use physical probability
*         tables; =3: use original Ribon method; =4: use Ribon extended
*         method).
* SIGGAR  macroscopic x-s of the non-resonant isotopes in each mixture.
*         1- total; 2- transport correction; 3- P0 scattering;
*         4- flux times P0 scattering.
* ISMIN   first secondary group indices.
* ISMAX   last secondary group indices.
* UNGAR   averaged fluxes per volume.
* PHGAR   averaged fluxes.
* STGAR   microscopic self-shielded total x-s.
* SFGAR   microscopic self-shielded fission x-s.
* SSGAR   microscopic self-shielded scattering x-s.
* S0GAR   microscopic transfer scattering x-s (isotope,secondary,
*         primary).
* SAGAR   microscopic self-shielded additional x-s.
* SDGAR   microscopic self-shielded delayed nu-sigf x-s.
* SWGAR   microscopic secondary slowing-down cross sections (ISUBG=4).
*
*Parameters: output
* PHGAR   SPH-corrected averaged fluxes.
* STGAR   SPH-corrected microscopic self-shielded total x-s.
* SFGAR   SPH-corrected microscopic self-shielded fission x-s.
* SSGAR   SPH-corrected microscopic self-shielded scattering x-s.
* S0GAR   SPH-corrected microscopic transfer scattering x-s
*         (isotope,secondary,primary).
* SAGAR   SPH-corrected microscopic additional x-s.
* SDGAR   SPH-corrected microscopic self-shielded delayed nu-sigf x-s.
* SWGAR   SPH-corrected microscopic secondary slowing-down cross
*         sections (ISUBG=4).
* SPH     SPH factors.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPLI0,IPTRK
      INTEGER IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,NED,NDEL,
     1 ISONAM(3,NBISO),MAT(NREG),KEYFLX(NREG),IMPX,MIX(NBISO),
     2 IAPT(NBISO),ITRANC,IPHASE,NGRP,NBNRS,IREX(NBMIX),ISUBG,
     3 ISMIN(NL,NGRP),ISMAX(NL,NGRP)
      REAL VOL(NREG),DEN(NBISO),SIGGAR(NBMIX,0:NIRES,NGRP,4),
     1 UNGAR(NREG,NIRES,NGRP),PHGAR(NBNRS,NIRES,NGRP),
     2 STGAR(NBNRS,NIRES,NGRP),SFGAR(NBNRS,NIRES,NGRP),
     3 SSGAR(NBNRS,NIRES,NL,NGRP),S0GAR(NBNRS,NIRES,NL,NGRP,NGRP),
     4 SAGAR(NBNRS,NIRES,NED,NGRP),SDGAR(NBNRS,NIRES,NDEL,NGRP),
     5 SWGAR(NBNRS,NIRES,NGRP),SPH(NBNRS,NIRES,NGRP)
      LOGICAL LEAKSW,MASKG(NGRP)
      CHARACTER CDOOR*12,HCAL*12,TITR*72
*----
*  LOCAL VARIABLES
*----
      PARAMETER (MAXIT=99,EPS=5.0E-5)
      TYPE(C_PTR) JPLI0,KPLI0
      LOGICAL LHOMOG,LPROB,LWARN,LTIT,LCONV,LEXAC
      CHARACTER HSMG*131,TEX8*8,CBDPNM*12
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS,ITT
      REAL, ALLOCATABLE, DIMENSION(:) :: VOLMER,SIGTXS,SIGS0X,FLNEW
      REAL, ALLOCATABLE, DIMENSION(:,:) :: SUNKNO,FUNKNO
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SIGTI
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(NPSYS(NGRP),ITT(NGRP))
      ALLOCATE(SIGTI(NBMIX,5,NGRP),VOLMER(NBNRS),SIGTXS(0:NBMIX),
     1 SIGS0X(0:NBMIX),FLNEW(NBNRS),SUNKNO(NUN,NGRP),FUNKNO(NUN,NGRP))
*----
*  COMPUTE THE MERGED VOLUMES.
*----
      LHOMOG=.TRUE.
      CALL XDRSET(VOLMER,NBNRS,0.0)
      DO 10 I=1,NREG
      IBM=MAT(I)
      IF(IBM.EQ.0) GO TO 10
      IND=IREX(IBM)
      IF(IND.EQ.0) THEN
         LHOMOG=.FALSE.
      ELSE
         VOLMER(IND)=VOLMER(IND)+VOL(I)
      ENDIF
   10 CONTINUE
      CALL XDRSET(SPH,NGRP*NIRES*NBNRS,1.0)
      IF(LHOMOG.AND.(NBNRS.EQ.1).AND.(NIRES.EQ.1)) GO TO 260
*----
*  ITERATIVE EVALUATION OF THE SPH FACTOR IN THE RESONANT REGION.
*----
      ICPIJ=0
      CALL KDRCPU(TK1)
      CALL LCMSIX(IPLI0,'SHIBA_SG',1)
      CALL LCMSIX(IPLI0,HCAL,1)
      LTIT=.TRUE.
      JPLI0=LCMLID(IPLI0,'GROUP',NGRP)
*----
*  LOOP OVER THE RESONANT ISOTOPES.
*----
      DO 250 IRES=1,NIRES
      CALL XDRSET(FUNKNO,NUN*NGRP,0.0)
      CALL XDRSET(SUNKNO,NUN*NGRP,0.0)
      CALL XDRSET(SIGTI,NBMIX*5*NGRP,0.0)
      CALL XDISET(NPSYS,NGRP,0)
      WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES
      CALL LCMSIX(IPLI0,CBDPNM,1)
      KPLI0=LCMGID(IPLI0,'GROUP_INFO')
      DO 50 IGRP=1,NGRP
      ITT(IGRP)=0
      IF(.NOT.MASKG(IGRP)) GO TO 50
      CALL LCMLEL(KPLI0,IGRP,ILONG,ITYLCM)
      IF(ILONG.EQ.0) GO TO 50
      NPSYS(IGRP)=IGRP
*----
*  SET THE MIXTURE-DEPENDENT MACROSCOPIC XS.
*----
      DO 30 IBM=1,NBMIX
      DENN=0.0
      DO 20 ISO=1,NBISO
      IF((IAPT(ISO).EQ.IRES).AND.(MIX(ISO).EQ.IBM)) DENN=DEN(ISO)
   20 CONTINUE
      IND=IREX(IBM)
      DO 30 JRES=0,NIRES
      IF(JRES.EQ.0) THEN
         SIGTI(IBM,1,IGRP)=SIGTI(IBM,1,IGRP)+SIGGAR(IBM,0,IGRP,1)
         SIGTI(IBM,3,IGRP)=SIGTI(IBM,3,IGRP)+SIGGAR(IBM,0,IGRP,3)
         IF(ITRANC.NE.0) SIGTI(IBM,2,IGRP)=SIGTI(IBM,2,IGRP)+
     1   SIGGAR(IBM,0,IGRP,2)
      ELSE IF((JRES.EQ.IRES).AND.(IND.NE.0)) THEN
         IF(IND.EQ.0) CALL XABORT('USSSPH: BUG1.')
         SIGTI(IBM,5,IGRP)=SIGTI(IBM,5,IGRP)+STGAR(IND,IRES,IGRP)*DENN
         IF(ISUBG.EQ.4) THEN
            SIGTI(IBM,4,IGRP)=SIGTI(IBM,4,IGRP)+SWGAR(IND,IRES,IGRP)*
     1      DENN*PHGAR(IND,IRES,IGRP)
         ELSE
            SIGTI(IBM,4,IGRP)=SIGTI(IBM,4,IGRP)+SSGAR(IND,IRES,1,IGRP)*
     1      DENN*PHGAR(IND,IRES,IGRP)
         ENDIF
      ELSE IF((JRES.GT.0).AND.(IND.NE.0)) THEN
         IF(IND.EQ.0) CALL XABORT('USSSPH: BUG2.')
         SIGTI(IBM,1,IGRP)=SIGTI(IBM,1,IGRP)+SIGGAR(IBM,JRES,IGRP,1)
         SIGTI(IBM,3,IGRP)=SIGTI(IBM,3,IGRP)+SIGGAR(IBM,JRES,IGRP,4)
      ENDIF
   30 CONTINUE
*----
*  COMPUTE THE SOURCES.
*----
      DO 40 I=1,NREG
      IBM=MAT(I)
      IF(IBM.EQ.0) GO TO 40
      SUNKNO(KEYFLX(I),IGRP)=SIGTI(IBM,3,IGRP)
      IF(IREX(IBM).GT.0) THEN
         SUNKNO(KEYFLX(I),IGRP)=SUNKNO(KEYFLX(I),IGRP)+SIGTI(IBM,4,IGRP)
     1   -UNGAR(I,IRES,IGRP)*SIGTI(IBM,5,IGRP)
         IF(.NOT.LHOMOG) SUNKNO(KEYFLX(I),IGRP)=SUNKNO(KEYFLX(I),IGRP)-
     1   UNGAR(I,IRES,IGRP)*SIGTI(IBM,1,IGRP)
      ENDIF
   40 CONTINUE
   50 CONTINUE
      CALL LCMSIX(IPLI0,' ',2)
*
      LWARN=.FALSE.
      ITER=0
      ERR=1.0E10
   60 ITER=ITER+1
      IF(ITER.GT.MAXIT) THEN
         IF(ERR.LT.100.0*EPS) THEN
            LWARN=.TRUE.
            GO TO 160
         ENDIF
         WRITE(HSMG,'(40HUSSSPH: TOO MANY SPH ITERATIONS IN GROUP,I6,1P,
     1   7H ERROR=,E10.2)') IGRMAX,ERRMAX
         CALL XABORT(HSMG)
      ENDIF
      LCONV=.TRUE.
      DO 90 IGRP=1,NGRP
      IF(NPSYS(IGRP).NE.0) THEN
        LCONV=.FALSE.
        ITT(IGRP)=ITT(IGRP)+1
        ICPIJ=ICPIJ+1
        SIGTXS(0)=0.0
        SIGS0X(0)=0.0
        DO 80 IBM=1,NBMIX
        SIGTXS(IBM)=SIGTI(IBM,1,IGRP)-SIGTI(IBM,2,IGRP)
        IND=IREX(IBM)
        IF(IND.EQ.0) THEN
*          REMOVE TRANSPORT CORRECTION.
           SIGS0X(IBM)=-SIGTI(IBM,2,IGRP)
        ELSE
*          BELL ACCELERATION.
           SIGTXS(IBM)=SIGTXS(IBM)+SIGTI(IBM,5,IGRP)*SPH(IND,IRES,IGRP)
           SIGS0X(IBM)=SIGTXS(IBM)
           IF(LHOMOG) SIGS0X(IBM)=SIGS0X(IBM)-SIGTI(IBM,1,IGRP)
        ENDIF
   80   CONTINUE
        KPLI0=LCMDIL(JPLI0,IGRP)
        CALL LCMPUT(KPLI0,'DRAGON-TXSC',NBMIX+1,2,SIGTXS)
        CALL LCMPUT(KPLI0,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X)
      ENDIF
   90 CONTINUE
      IF(LCONV) GO TO 160
*----
*  SOLVE FOR THE FLUX AT ITERATION ITER.
*----
      NANI=1
      KNORM=1
      IMPY=MAX(0,IMPX-3)
      IF(IPHASE.EQ.1) THEN
*        USE A NATIVE DOOR.
         CALL DOORAV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPY,NGRP,NREG,
     1   NBMIX,NANI,MAT,VOL,KNORM,LEAKSW,TITR)
      ELSE IF(IPHASE.EQ.2) THEN
*        USE A COLLISION PROBABILITY DOOR.
         IPIJK=1
         CALL DOORPV(CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPY,NGRP,NREG,
     1   NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,.FALSE.,TITR)
      ENDIF
      IDIR=0
      LEXAC=.FALSE.
      CALL DOORFV (CDOOR,JPLI0,NPSYS,IPTRK,IFTRAK,IMPX,NGRP,NBMIX,IDIR,
     1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUNKNO,FUNKNO)
*----
*  HOMOGENIZE THE FLUX AT ITERATION ITER.
*----
      ERRMAX=0.0
      IGRMAX=0
      DO 130 IGRP=1,NGRP
      IF(NPSYS(IGRP).NE.0) THEN
        CALL XDRSET(FLNEW,NBNRS,0.0)
        DO 100 I=1,NREG
        IF(MAT(I).EQ.0) GO TO 100
        IND=IREX(MAT(I))
        IF(IND.GT.0) FLNEW(IND)=FLNEW(IND)+FUNKNO(KEYFLX(I),IGRP)*VOL(I)
  100   CONTINUE
        DO 110 IND=1,NBNRS
  110   FLNEW(IND)=FLNEW(IND)/VOLMER(IND)
*----
*  SPH CONVERGENCE CONTROL.
*----
        ERR=0.0
        DO 120 IND=1,NBNRS
        SPHNEW=PHGAR(IND,IRES,IGRP)/FLNEW(IND)
        LPROB=(SPHNEW.LE.0.0).OR.
     1        ((SPHNEW.GT.2.0).AND.(FLNEW(IND).LT.0.01)).OR.
     2        (LWARN.AND.(SPH(IND,IRES,IGRP).EQ.1.0).AND.(ITER.GT.1))
        IF(LPROB) THEN
           SPHNEW=1.0
           IGRERR=IGRP
           LWARN=.TRUE.
        ELSE
           ERR=MAX(ERR,ABS(SPHNEW-SPH(IND,IRES,IGRP)))
        ENDIF
  120   SPH(IND,IRES,IGRP)=SPHNEW
        IF((ERRMAX.EQ.0.0).OR.(ERR.GT.ERRMAX)) THEN
           ERRMAX=ERR
           IGRMAX=IGRP
        ENDIF
        IF(ERR.LT.EPS) NPSYS(IGRP)=0
      ENDIF
  130 CONTINUE
      GO TO 60
*
  160 IF(LWARN) THEN
         WRITE(6,'(/47H USSSPH: *** WARNING *** SPH ITERATIONS HAVE PR,
     1   27HOBLEMS TO CONVERGE IN GROUP,I6,1H.)') IGRERR
      ENDIF
*
      DO 250 IGRP=1,NGRP
      IF(MASKG(IGRP)) THEN
        SPHNEW=1.0
        DO 180 IND=1,NBNRS
        SPHNEW=SPH(IND,IRES,IGRP)
        PHGAR(IND,IRES,IGRP)=PHGAR(IND,IRES,IGRP)/SPHNEW
        STGAR(IND,IRES,IGRP)=STGAR(IND,IRES,IGRP)*SPHNEW
        SFGAR(IND,IRES,IGRP)=SFGAR(IND,IRES,IGRP)*SPHNEW
        IF(ISUBG.EQ.4) SWGAR(IND,IRES,IGRP)=SWGAR(IND,IRES,IGRP)*SPHNEW
        DO 170 IL=1,NL
        SSGAR(IND,IRES,IL,IGRP)=SSGAR(IND,IRES,IL,IGRP)*SPHNEW
        DO 170 JGRP=ISMIN(IL,IGRP),ISMAX(IL,IGRP)
  170   S0GAR(IND,IRES,IL,JGRP,IGRP)=S0GAR(IND,IRES,IL,JGRP,IGRP)*SPHNEW
        DO 180 IED=1,NED
  180   SAGAR(IND,IRES,IED,IGRP)=SAGAR(IND,IRES,IED,IGRP)*SPHNEW
        DO 190 IDEL=1,NDEL
  190   SDGAR(IND,IRES,IDEL,IGRP)=SDGAR(IND,IRES,IDEL,IGRP)*SPHNEW
*
        IF(IMPX.GT.1) THEN
           IF(LTIT) THEN
              WRITE(6,'(/42H USSSPH: SPH CORRECTED SELF-SHIELDED MICRO,
     1        23HSCOPIC CROSS SECTIONS (,A12,2H)./6H GROUP,5H FUEL,9X,
     2        4HFLUX,2X,25HSPH FACTOR.... ISOTOPE...,8X,5HTOTAL,3X,
     3        10HSCATTERING,3X,10HNU*FISSION,13H WITHIN-GROUP)') HCAL
              LTIT=.FALSE.
           ENDIF
           DO 240 IND=1,NBNRS
           DO 220 ISO=1,NBISO
           IF(IAPT(ISO).EQ.IRES) THEN
              WRITE(TEX8,'(2A4)') (ISONAM(J,ISO),J=1,2)
           ENDIF
  220      CONTINUE
           WRITE(6,'(1X,2I5,1P,E13.4,E12.4,1H(,I2,3H) '',A8,1H'',
     1     4E13.4)') IGRP,IND,PHGAR(IND,IRES,IGRP),SPH(IND,IRES,IGRP),
     2     ITT(IGRP),TEX8,STGAR(IND,IRES,IGRP),SSGAR(IND,IRES,1,IGRP),
     3     SFGAR(IND,IRES,IGRP),S0GAR(IND,IRES,1,IGRP,IGRP)
  240      CONTINUE
        ENDIF
      ENDIF
  250 CONTINUE
*     ***************************************************************
      CALL LCMSIX(IPLI0,' ',2)
      CALL LCMSIX(IPLI0,' ',2)
      CALL KDRCPU(TK2)
      IF(IMPX.GT.1) WRITE(6,'(/34H USSSPH: CPU TIME SPENT TO COMPUTE,
     1 18H THE SPH FACTORS =,F8.1,8H SECOND./9X,17HNUMBER OF ASSEMBL,
     2 15HY DOORS CALLS =,I5,1H.)') TK2-TK1,ICPIJ
*----
*  SCRATCH STORAGE DEALLOCATION
*----
  260 DEALLOCATE(FUNKNO,SUNKNO,FLNEW,SIGS0X,SIGTXS,VOLMER,SIGTI)
      DEALLOCATE(ITT,NPSYS)
      RETURN
      END
