Initial commit from Polytechnique Montreal

1 files changed, 509 insertions, 0 deletions

diff --git a/Dragon/src/USSIST.f b/Dragon/src/USSIST.f
new file mode 100644
index 0000000..be654e0
--- /dev/null
+++ b/Dragon/src/USSIST.f
@@ -0,0 +1,509 @@
+*DECK USSIST
+      SUBROUTINE USSIST(MAXNOR,NGRP,MASKG,IRES,IPLI0,IPTRK,IFTRAK,
+     1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW,
+     2 IREX,SIGGAR,TITR,ICORR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,
+     3 STGAR,SSGAR,VOLMER,UNGAR)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute the multiband fluxes as required by the subgroup method using
+* the subgroup projection method (SPM):
+* a) assume a single resonant isotope;
+* b) use the standard solution doors of Dragon.
+*
+*Copyright:
+* Copyright (C) 2007 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
+* MAXNOR  maximum order of the probability tables (PT).
+* NGRP    number of energy group.
+* MASKG   energy group mask pointing on self-shielded groups.
+* IRES    index of the resonant isotope.
+* IPLI0   pointer to the internal microscopic cross section library
+*         builded by the self-shielding module.
+* IPTRK   pointer to the tracking (L_TRACK signature).
+* IFTRAK  file unit number used to store the tracks.
+* CDOOR   name of the geometry/solution operator.
+* IMPX    print flag (equal to zero for no print).
+* NBMIX   number of mixtures in the internal library.
+* NREG    number of regions.
+* NUN     number of unknowns in the flux or source vector in one
+*         energy group and one band.
+* NL      number of Legendre orders required in the calculation
+*         (NL=1 or higher).
+* IPHASE  type of flux solution (=1 use a native flux solution door;
+*         =2 use collision probabilities).
+* MAXST   maximum number of fixed point iterations for the ST scattering
+*         source.
+* MAT     index-number of the mixture type assigned to each volume.
+* VOL     volumes.
+* KEYFLX  pointers of fluxes in unknown vector.
+* LEAKSW  leakage switch (LEAKSW=.TRUE. if neutron leakage through
+*         external boundary is present).
+* IREX    fuel region index assigned to each mixture. Equal to zero
+*         in non-resonant mixtures or in mixtures not used.
+* 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.
+* TITR    title.
+* ICORR   mutual resonance shielding flag (=1 to suppress the model
+*         in cases it is required in LIB operator).
+* NIRES   exact number of correlated resonant isotopes.
+* NBNRS   number of correlated fuel regions.
+* NOR     exact order of the probability table.
+* CONR    number density of the resonant isotopes.
+* GOLD    type of self-shielding model (=1.0 physical probability
+*         tables; =-998.0/-1000.0 subgroup projection method).
+* IPPT1   pointer to LCM directory of each resonant isotope.
+* IPPT2   information related to each resonant isotope:
+*         IPPT2(:,1) index of a resonant region (used with infinite
+*         dilution case);
+*         IPPT2(:,2:4) alias name of resonant isotope.
+* STGAR   averaged microscopic total xs in resonant region.
+* SSGAR   averaged microscopic scattering xs in resonant region.
+* VOLMER  volumes of the resonant regions.
+*
+*Parameters: output
+* UNGAR   averaged flux unknowns.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE DOORS_MOD
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLI0,IPTRK,IPPT1(NIRES)
+      INTEGER MAXNOR,NGRP,IRES,IFTRAK,IMPX,NBMIX,NREG,NUN,NL,IPHASE,
+     1 MAXST,MAT(NREG),KEYFLX(NREG),IREX(NBMIX),ICORR,NIRES,NBNRS,
+     2 NOR(NIRES,NGRP),IPPT2(NIRES,4)
+      REAL VOL(NREG),SIGGAR(NBMIX,0:NIRES,NGRP,4),
+     1 CONR(NBNRS,NIRES),GOLD(NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP),
+     2 SSGAR(NBNRS,NIRES,NL,NGRP),VOLMER(0:NBNRS),
+     3 UNGAR(NUN,NIRES,NGRP)
+      CHARACTER CDOOR*12,TITR*72
+      LOGICAL LEAKSW,MASKG(NGRP)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) IPSYS,JPLIB,KPLIB,KPSYS,JPLI0,JPLI01,IPMACR,IPSOU
+      CHARACTER CBDPNM*12,TEXT12*12,TEXX12*12,HSMG*131
+      DOUBLE PRECISION ZNUM,ZDEN
+      LOGICAL EMPTY,LCM,LEXAC,LSPM,REBFLG
+      INTEGER NALBP
+*----
+*  ALLOCATABLE STATEMENTS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: NPSYS
+      REAL, ALLOCATABLE, DIMENSION(:) :: SIGTXS,SIGS0X,SIGG,FLNEW,WCOR,
+     1 FUN,SUN
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: WEIGH,TOTPT,SIGWS
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XFLUX
+      TYPE(C_PTR) SIGP_PTR
+      REAL, POINTER, DIMENSION(:) :: SIGP
+*----
+*  FIND THE NUMBER OF COMPONENTS REQUIRED AND ALLOCATE THE LIST OF
+*  ASSEMBLY MATRICES.
+*----
+      NASM=0
+      DO 10 IGRP=1,NGRP
+      LSPM=(MASKG(IGRP).AND.((GOLD(IRES,IGRP).EQ.-998.).OR.
+     1 (GOLD(IRES,IGRP).EQ.-1000.)))
+      IF(LSPM) NASM=NASM+NOR(IRES,IGRP)
+   10 CONTINUE
+      IF(NASM.EQ.0) RETURN
+      IF(NGRP.LT.250) CALL XABORT('USSIST: THIS SIMPLIFIED SELF-SHIELD'
+     1 //'ING MODEL REQUIRES MORE THAN 250 ENERGY GROUPS.')
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(NPSYS(MAXNOR*NGRP))
+      ALLOCATE(XFLUX(NBNRS,MAXNOR,NIRES),SIGTXS(0:NBMIX),
+     1 SIGS0X(0:NBMIX),SIGG(0:NBMIX),WEIGH(MAXNOR,NIRES),
+     2 TOTPT(MAXNOR,NIRES),SIGWS(MAXNOR,NIRES),FLNEW(NBNRS),
+     3 WCOR(MAXNOR**2))
+*----
+*  CREATE A SPECIFIC DIRECTORY FOR IRES-TH RESONANT ISOTOPE.
+*----
+      WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES
+      CALL LCMSIX(IPLI0,CBDPNM,1)
+      JPLI0=LCMGID(IPLI0,'NWT0-PT')
+      IPSYS=LCMLID(IPLI0,'ASSEMB-RIBON',NASM)
+      CALL LCMSIX(IPLI0,' ',2)
+*----
+*  LOOP OVER THE ENERGY GROUPS.
+*----
+      IASM=0
+      DO 100 IGRP=1,NGRP
+      LSPM=(MASKG(IGRP).AND.((GOLD(IRES,IGRP).EQ.-998.).OR.
+     1 (GOLD(IRES,IGRP).EQ.-1000.)))
+      IF(LSPM) THEN
+         IF(IMPX.GT.2) THEN
+            WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4)
+            WRITE(6,'(36H USSIST: PROCESS CORRELATED ISOTOPE ,A12,
+     1      11H WITH INDEX,I3,9H IN GROUP,I4,22H (SUBGROUP PROJECTION ,
+     2      8HMETHOD).)') TEXT12,IRES,IGRP
+         ENDIF
+         DO 20 JRES=1,NIRES
+         IF(GOLD(JRES,IGRP).NE.GOLD(IRES,IGRP)) THEN
+            WRITE(HSMG,'(32HUSSIST: PT NOT SET FOR ISOTOPE '',3A4,
+     1      10H'' IN GROUP,I5,1H.)') (IPPT2(JRES,J0),J0=2,4),IGRP
+            CALL XABORT(HSMG)
+         ELSE IF(NOR(JRES,IGRP).GT.MAXNOR) THEN
+            CALL XABORT('USSIST: MAXNOR OVERFLOW.')
+         ENDIF
+   20    CONTINUE
+         NORI=NOR(IRES,IGRP)
+         DO 40 JRES=1,NIRES
+*----
+*  RECOVER THE PREVIOUS FLUXES.
+*----
+         IF(NOR(JRES,IGRP).EQ.1) THEN
+            XFLUX(:NBNRS,:MAXNOR,JRES)=1.0
+         ELSE
+            WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') JRES,NIRES
+            CALL LCMSIX(IPLI0,CBDPNM,1)
+            JPLI01=LCMGID(IPLI0,'NWT0-PT')
+            CALL LCMLEL(JPLI01,IGRP,ILON,ITYLCM)
+            IF(ILON.GT.NBNRS*MAXNOR) THEN
+               WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4)
+               WRITE(HSMG,'(34HUSSIST: FLUX OVERFLOW FOR ISOTOPE ,A12)')
+     1         TEXT12
+               CALL XABORT(HSMG)
+            ENDIF
+            CALL LCMGDL(JPLI01,IGRP,XFLUX(1,1,JRES))
+            CALL LCMSIX(IPLI0,' ',2)
+         ENDIF
+*----
+*  COLLECT THE BASE POINTS IN TOTAL CROSS SECTION.
+*----
+         JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT')
+         CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM)
+         IF(ILONG.NE.0) THEN
+            KPLIB=LCMGIL(JPLIB,IGRP)
+            CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM)
+            CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM)
+            NPART=LENG/MAXNOR
+            IF(LCM) THEN
+               CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR)
+               CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /))
+            ELSE
+               ALLOCATE(SIGP(MAXNOR*NPART))
+               CALL LCMGET(KPLIB,'PROB-TABLE',SIGP)
+            ENDIF
+            DO 30 INOR=1,NOR(JRES,IGRP)
+            WEIGH(INOR,JRES)=SIGP(INOR)
+            TOTPT(INOR,JRES)=SIGP(MAXNOR+INOR)
+            SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR)
+   30       CONTINUE
+            IF(.NOT.LCM) DEALLOCATE(SIGP)
+         ELSE
+            WEIGH(1,JRES)=1.0
+            TOTPT(1,JRES)=STGAR(IPPT2(JRES,1),JRES,IGRP)
+            SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP)
+         ENDIF
+   40    CONTINUE
+*----
+*  SET THE MIXTURE-DEPENDENT CROSS SECTIONS.
+*----
+         JPLIB=LCMGID(IPPT1(IRES),'GROUP-PT')
+         KPLIB=LCMGIL(JPLIB,IGRP)
+         DO 90 INOR=1,NORI
+         SIGTXS(0:NBMIX)=0.0
+         SIGS0X(0:NBMIX)=0.0
+         DO 80 IBM=1,NBMIX
+         IND=IREX(IBM)
+         DO 70 JRES=0,NIRES
+         IF(JRES.EQ.0) THEN
+*           ADMIXED NON-RESONANT ISOTOPES.
+            SIGTXS(IBM)=SIGTXS(IBM)+(SIGGAR(IBM,0,IGRP,1)-
+     1      SIGGAR(IBM,0,IGRP,2))
+            SIGS0X(IBM)=SIGS0X(IBM)-SIGGAR(IBM,0,IGRP,2)
+         ELSE IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN
+*           MUTUAL SHIELDING MODEL FROM CORRELATED RESONANT ISOTOPES.
+            WRITE(TEXT12,'(3A4)') (IPPT2(JRES,I0),I0=2,4)
+            IF((NOR(JRES,IGRP).GT.1).AND.(ICORR.NE.1)) THEN
+               CALL LCMLEN(KPLIB,TEXT12,ILEN,ITYLCM)
+               IF(ILEN.EQ.0) THEN
+                  CALL LCMLIB(KPLIB)
+                  CALL XABORT('USSIST: UNABLE TO FIND CORRELATED ISOTO'
+     1            //'PE '//TEXT12//'.')
+               ENDIF
+               CALL LCMGET(KPLIB,TEXT12,WCOR)
+            ENDIF
+            IF((ICORR.EQ.1).AND.
+*             ECCO CORRELATION MODEL.
+     1        (IPPT2(IRES,2).EQ.IPPT2(JRES,2)).AND.
+     1        (IPPT2(IRES,3).EQ.IPPT2(JRES,3))) THEN
+              SIGTXS(IBM)=SIGTXS(IBM)+CONR(IND,JRES)*TOTPT(INOR,IRES)
+            ELSE
+              ZNUM=0.0D0
+              ZDEN=0.0D0
+              DO 60 I2=1,NOR(JRES,IGRP)
+              IF((ICORR.EQ.1).OR.(NOR(JRES,IGRP).EQ.1)) THEN
+                WWW=WEIGH(INOR,IRES)*WEIGH(I2,JRES)*XFLUX(IND,I2,JRES)
+              ELSE
+                WWW=WCOR((I2-1)*NORI+INOR)*XFLUX(IND,I2,JRES)
+              ENDIF
+              ZNUM=ZNUM+WWW*CONR(IND,JRES)*TOTPT(I2,JRES)
+              ZDEN=ZDEN+WWW
+   60         CONTINUE
+              IF(ZNUM/ZDEN.LT.0.0) THEN
+*               BADLY BEHAVED CORRELATED WEIGHT MATRIX.
+                ZNUM=0.0D0
+                ZDEN=0.0D0
+                DO 65 I2=1,NOR(JRES,IGRP)
+                WWW=WEIGH(INOR,IRES)*WEIGH(I2,JRES)*XFLUX(IND,I2,JRES)
+                ZNUM=ZNUM+WWW*CONR(IND,JRES)*TOTPT(I2,JRES)
+                ZDEN=ZDEN+WWW
+   65           CONTINUE
+              ENDIF
+              SIGTXS(IBM)=SIGTXS(IBM)+REAL(ZNUM/ZDEN)
+            ENDIF
+         ENDIF
+   70    CONTINUE
+         IF(IND.GT.0) THEN
+            SIGTXS(IBM)=SIGTXS(IBM)+CONR(IND,IRES)*TOTPT(INOR,IRES)
+            SIGS0X(IBM)=SIGS0X(IBM)+WEIGH(INOR,IRES)*CONR(IND,IRES)*
+     1      SIGWS(INOR,IRES)
+         ENDIF
+   80    CONTINUE
+         IASM=IASM+1
+         NPSYS(IASM)=IASM
+         KPSYS=LCMDIL(IPSYS,IASM)
+         CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBMIX+1,2,SIGTXS(0))
+         CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBMIX+1,2,SIGS0X(0))
+   90    CONTINUE
+      ELSE IF(GOLD(IRES,IGRP).EQ.-998.) THEN
+         CALL LCMLEL(JPLI0,IGRP,LENG0,ITYLCM)
+         IF(LENG0.NE.0) THEN
+            WRITE(HSMG,'(42HUSSIST: UNEXPECTED SELF-SHIELDING DATA FOU,
+     1      11HND IN GROUP,I5,1H.)') IGRP
+            CALL XABORT(HSMG)
+         ENDIF
+      ELSE IF(GOLD(IRES,IGRP).EQ.-1000.) THEN
+         CALL LCMLEL(JPLI0,IGRP,LENG0,ITYLCM)
+         IF(LENG0.NE.0) THEN
+            WRITE(HSMG,'(42HUSSIST: UNEXPECTED SELF-SHIELDING DATA FOU,
+     1      11HND IN GROUP,I5,1H.)') IGRP
+            CALL XABORT(HSMG)
+         ENDIF
+      ENDIF
+  100 CONTINUE
+*----
+*  ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION.
+*----
+      NANI=1
+      KNORM=1
+      NALBP=0
+      IMPY=MAX(0,IMPX-3)
+      IF(IPHASE.EQ.1) THEN
+*        USE A NATIVE DOOR.
+         ISTRM=1
+         NW=0
+         CALL DOORAV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG,
+     1   NBMIX,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM)
+      ELSE IF(IPHASE.EQ.2) THEN
+*        USE A COLLISION PROBABILITY DOOR.
+         IPIJK=1
+         ITPIJ=1
+         CALL DOORPV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPY,NASM,NREG,
+     1   NBMIX,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,.FALSE.,TITR,
+     2   NALBP)
+      ENDIF
+*----
+*  LOOP OVER THE ENERGY GROUPS.
+*----
+      IASM=0
+      DO 280 IGRP=1,NGRP
+      LSPM=(MASKG(IGRP).AND.((GOLD(IRES,IGRP).EQ.-998.).OR.
+     1 (GOLD(IRES,IGRP).EQ.-1000.)))
+      IF(LSPM) THEN
+         NORI=NOR(IRES,IGRP)
+*----
+*  COLLECT THE BASE POINTS IN PARTIAL CROSS SECTION.
+*----
+         DO 120 JRES=1,NIRES
+         JPLIB=LCMGID(IPPT1(JRES),'GROUP-PT')
+         CALL LCMLEL(JPLIB,IGRP,ILONG,ITYLCM)
+         IF(ILONG.NE.0) THEN
+            KPLIB=LCMGIL(JPLIB,IGRP)
+            CALL LCMINF(KPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM)
+            CALL LCMLEN(KPLIB,'PROB-TABLE',LENG,ITYLCM)
+            NPART=LENG/MAXNOR
+            IF(LCM) THEN
+               CALL LCMGPD(KPLIB,'PROB-TABLE',SIGP_PTR)
+               CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /))
+            ELSE
+               ALLOCATE(SIGP(MAXNOR*NPART))
+               CALL LCMGET(KPLIB,'PROB-TABLE',SIGP)
+            ENDIF
+            DO 110 INOR=1,NOR(JRES,IGRP)
+            WEIGH(INOR,JRES)=SIGP(INOR)
+            SIGWS(INOR,JRES)=SIGP(3*MAXNOR+INOR)
+  110       CONTINUE
+            IF(.NOT.LCM) DEALLOCATE(SIGP)
+         ELSE
+            WEIGH(1,JRES)=1.0
+            SIGWS(1,JRES)=SSGAR(IPPT2(JRES,1),JRES,1,IGRP)
+         ENDIF
+  120    CONTINUE
+*----
+*  RECOVER THE PREVIOUS FLUXES.
+*----
+         WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES
+         CALL LCMSIX(IPLI0,CBDPNM,1)
+         JPLI01=LCMGID(IPLI0,'NWT0-PT')
+         CALL LCMLEL(JPLI01,IGRP,ILON,ITYLCM)
+         IF(ILON.GT.NBNRS*MAXNOR) THEN
+            WRITE(TEXT12,'(3A4)') (IPPT2(IRES,J0),J0=2,4)
+            WRITE(HSMG,'(34HUSSIST: FLUX OVERFLOW FOR ISOTOPE ,A12)')
+     1      TEXT12
+            CALL XABORT(HSMG)
+         ENDIF
+         CALL LCMGDL(JPLI01,IGRP,XFLUX(1,1,IRES))
+         CALL LCMSIX(IPLI0,' ',2)
+*----
+*  ITERATIVE PROCEDURE.
+*----
+        ITER=0
+  140   ITER=ITER+1
+        IF(ITER.GT.MAXST) GO TO 240
+        ERR1=0.0
+        ERR2=0.0
+*----
+*  COMPUTE THE AVERAGED SOURCE.
+*----
+        ALLOCATE(FUN(NUN*NORI),SUN(NUN*NORI))
+        SUN(:NUN*NORI)=0.0
+        DO 195 INOR=1,NORI
+        KPSYS=LCMGIL(IPSYS,IASM+INOR)
+        CALL LCMLEN(KPSYS,'FUNKNO$USS',ILENG,ITYLCM)
+        IF(ILENG.EQ.NUN) THEN
+           CALL LCMGET(KPSYS,'FUNKNO$USS',FUN((INOR-1)*NUN+1))
+        ELSE
+           FUN((INOR-1)*NUN+1:INOR*NUN)=0.0
+        ENDIF
+        NPSYS(INOR)=IASM+INOR
+        SIGG(0)=0.0
+        DO 190 IBM=1,NBMIX
+        SIGG(IBM)=SIGGAR(IBM,0,IGRP,3)
+        IND=IREX(IBM)
+        DO 150 JRES=1,NIRES
+        IF((JRES.NE.IRES).AND.(IND.GT.0)) THEN
+           SIGG(IBM)=SIGG(IBM)+SIGGAR(IBM,JRES,IGRP,4)
+        ENDIF
+  150   CONTINUE
+        IF(IND.GT.0) THEN
+           DO 160 JNOR=1,NORI
+           IF(JNOR.NE.INOR) THEN
+              SIGG(IBM)=SIGG(IBM)+WEIGH(JNOR,IRES)*CONR(IND,IRES)*
+     1        SIGWS(JNOR,IRES)*XFLUX(IND,JNOR,IRES)
+           ENDIF
+  160      CONTINUE
+        ENDIF
+  190   CONTINUE
+        IOF=(INOR-1)*NUN
+        CALL DOORS(CDOOR,IPTRK,NBMIX,0,NUN,SIGG,SUN(IOF+1))
+  195   CONTINUE
+*----
+*  SOLVE FOR THE MULTIBAND FLUX.
+*----
+        IDIR=0
+        LEXAC=.FALSE.
+        IPMACR=C_NULL_PTR
+        IPSOU=C_NULL_PTR
+        REBFLG=.FALSE.
+        CALL DOORFV(CDOOR,IPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NORI,NBMIX,
+     1  IDIR,NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN,IPMACR,
+     2  IPSOU,REBFLG)
+*----
+*  HOMOGENIZE THE FLUX AT ITERATION ITER.
+*----
+        UNGAR(:NUN,IRES,IGRP)=0.0
+        DO 235 INOR=1,NORI
+        KPSYS=LCMGIL(IPSYS,IASM+INOR)
+        CALL LCMPUT(KPSYS,'FUNKNO$USS',NUN,2,FUN((INOR-1)*NUN+1))
+        FLNEW(:NBNRS)=0.0
+        DO 200 I=1,NREG
+        IF(MAT(I).EQ.0) GO TO 200
+        IOF=(INOR-1)*NUN+KEYFLX(I)
+        IND=IREX(MAT(I))
+        IF(IND.GT.0) FLNEW(IND)=FLNEW(IND)+FUN(IOF)*VOL(I)
+  200   CONTINUE
+        DO 210 IND=1,NBNRS
+        FLNEW(IND)=FLNEW(IND)/VOLMER(IND)
+  210   CONTINUE
+*
+        DO 220 I=1,NUN
+        IOF=(INOR-1)*NUN+I
+        UNGAR(I,IRES,IGRP)=UNGAR(I,IRES,IGRP)+FUN(IOF)*WEIGH(INOR,IRES)
+  220   CONTINUE
+*----
+*  CONVERGENCE CONTROL.
+*----
+        DO 230 IND=1,NBNRS
+        ERR1=MAX(ERR1,ABS(FLNEW(IND)-XFLUX(IND,INOR,IRES)))
+        ERR2=MAX(ERR2,ABS(FLNEW(IND)))
+        XFLUX(IND,INOR,IRES)=FLNEW(IND)
+  230   CONTINUE
+  235   CONTINUE
+        DEALLOCATE(SUN,FUN)
+        IF(IMPX.GT.2) THEN
+           WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4)
+           WRITE(6,'(15H USSIST: GROUP=,I5,20H. SUBGROUP ITERATION,I4,
+     1     11H. ISOTOPE='',A12,9H''. ERROR=,1P,E11.4,1H.)')
+     2     IGRP,ITER,TEXT12,ERR1
+        ENDIF
+        IF(ERR2.GT.1.0E10) GO TO 240
+        IF(ERR1.GT.1.0E-4*ERR2) GO TO 140
+        IF(IMPX.GT.1) THEN
+           WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4)
+           WRITE(6,'(15H USSIST: GROUP=,I5,24H. SUBGROUP ITERATION CON,
+     1     11HVERGENCE IN,I4,22H ITERATIONS. ISOTOPE='',A12,2H''.)')
+     2     IGRP,ITER,TEXT12
+        ENDIF
+        GO TO 250
+*----
+*  ALTERNATIVE TREATMENT IN CASE OF FAILURE OF FIXED POINT ITERATIONS.
+*  USE A NON-ITERATIVE RESPONSE MATRIX APPROACH.
+*----
+  240   IF(IMPX.GT.0) THEN
+           WRITE(TEXT12,'(3A4)') (IPPT2(IRES,I),I=2,4)
+           WRITE(6,'(15H USSIST: GROUP=,I5,24H. SUBGROUP ITERATION FAI,
+     1     16HLED FOR ISOTOPE ,A12,32H. USE AN ALTERNATIVE RESPONSE MA,
+     2     14HTRIX APPROACH.)') IGRP,TEXT12
+        ENDIF
+        CALL USSEXC(MAXNOR,CDOOR,IPLI0,IPTRK,IFTRAK,IMPX,NGRP,IGRP,
+     1  IASM,NBMIX,NREG,NUN,NL,IPHASE,MAT,VOL,KEYFLX,IREX,SIGGAR,TITR,
+     2  NIRES,IRES,NBNRS,NOR,CONR,IPPT1,IPPT2,STGAR,SSGAR,VOLMER,
+     3  XFLUX(1,1,IRES),UNGAR)
+  250   IF(IMPX.GT.2) THEN
+           DO 270 IND=1,NBNRS
+           T1=0.0
+           DO 260 INOR=1,NORI
+           T1=T1+WEIGH(INOR,IRES)*XFLUX(IND,INOR,IRES)
+  260      CONTINUE
+           WRITE(6,'(31H USSIST: AVERAGED FLUX IN GROUP,I4,9H AND RESO,
+     1     11HNANT REGION,I4,21H FOR RESONANT ISOTOPE,I4,2H =,F9.5)')
+     2     IGRP,IND,IRES,T1
+  270      CONTINUE
+        ENDIF
+        CALL LCMPDL(JPLI0,IGRP,NBNRS*NORI,2,XFLUX(1,1,IRES))
+        IASM=IASM+NORI
+      ENDIF
+  280 CONTINUE
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(WCOR,FLNEW,SIGWS,TOTPT,WEIGH,SIGG,SIGS0X,SIGTXS,XFLUX)
+      DEALLOCATE(NPSYS)
+      RETURN
+      END