Initial commit from Polytechnique Montreal

1 files changed, 509 insertions, 0 deletions

diff --git a/Dragon/src/AUTONE.f b/Dragon/src/AUTONE.f
new file mode 100644
index 0000000..3a95006
--- /dev/null
+++ b/Dragon/src/AUTONE.f
@@ -0,0 +1,509 @@
+*DECK AUTONE
+      SUBROUTINE AUTONE(IPLI0,IPTRK,IPLIB,IFTRAK,CDOOR,IMPX,INRS,
+     1 IGRMIN,IGRRES,IGRMAX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,
+     2 ISONAM,IHSUF,DEN,LSHI,DIL,MIX,MAT,VOL,KEYFLX,LEAKSW,ITRANC,
+     3 IPHASE,TITR,KSPH,IALTER,DELI,LBIN,NBIN,EBIN,MAXTRA,ISEED)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Perform a resonance self-shielding calculation in resonant region
+* INRS and build a corresponding internal library for the Autosecol
+* method.
+*
+*Copyright:
+* Copyright (C) 2023 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 internal microscopic cross section library
+*         builded by the self-shielding module (L_LIBRARY signature).
+* IPTRK   pointer to the tracking. (L_TRACK signature).
+* IPLIB   pointer to the internal microscopic cross section library
+*         with subgroups (L_LIBRARY signature).
+* IFTRAK  unit number of the sequential binary tracking file.
+* CDOOR   name of the geometry/solution operator.
+* IMPX    print flag (equal to zero for no print).
+* INRS    resonant region index.
+* IGRMIN  first group where the self-shielding is applied.
+* IGRRES  first resolved energy group.
+* IGRMAX  most thermal group where the self-shielding is applied.
+* NGRP    number of energy groups.
+* NBMIX   number of mixtures in the internal library.
+* NREG    number of regions.
+* NUN     number of unknowns per energy group.
+* NBISO   number of isotopes specifications in the internal library.
+* 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.
+* IHSUF   suffix name of isotopes.
+* DEN     density of each isotope.
+* LSHI    resonant region index assigned to each isotope.
+* DIL     microscopic dilution cross section of each isotope.
+* MIX     mix number of each isotope (can be zero).
+* MAT     index-number of the mixture type assigned to each volume.
+* VOL     volumes.
+* KEYFLX  pointers of fluxes in unknown vector.
+* LEAKSW  leakage flag (LEAKSW=.TRUE. if neutron leakage through
+*         external boundary is present).
+* ITRANC  type of transport correction.
+* IPHASE  type of flux solution (=1 use a native flux solution door;
+*         =2 use collision probabilities).
+* TITR    title.
+* KSPH    SPH equivalence flag (=0 no SPH correction; =1 SPH correction
+*         in the fuel).
+* IALTER  type of elastic slowing-down kernel (=0: use exact kernel;
+*         =1: use an approximate kernel for the resonant isotopes).
+* DELI    elementary lethargy width used by the elastic kernel.
+* LBIN    total number of fine energy groups in the Autolib.
+* NBIN    number of fine energy groups in each coarse energy group.
+* EBIN    energy limits of the Autolib fine groups.
+* MAXTRA  maximum number of down-scattering terms.
+* ISEED   the seed for the generation of random numbers in the
+*         unresolved energy domain.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLI0,IPTRK,IPLIB
+      INTEGER IFTRAK,IMPX,INRS,IGRMIN,IGRRES,IGRMAX,NGRP,NBMIX,NREG,
+     1 NUN,NBISO,NL,NED,NDEL,ISONAM(3,NBISO),IHSUF(NBISO),LSHI(NBISO),
+     2 MIX(NBISO),MAT(NREG),KEYFLX(NREG),ITRANC,IPHASE,KSPH,IALTER,
+     3 LBIN,NBIN(NGRP),MAXTRA,ISEED
+      REAL DEN(NBISO),DIL(NBISO),VOL(NREG),DELI,EBIN(LBIN+1)
+      LOGICAL LEAKSW
+      CHARACTER CDOOR*12,TITR*72
+*----
+*  LOCAL VARIABLES
+*----
+      DOUBLE PRECISION VOLTOT,GAR0,GAR1,GAR2,GAR3,GAR4
+      CHARACTER TEXT4*4,HCAL*12,NAME*12,TEXT12*12,HSMG*131
+      LOGICAL LABS
+      TYPE(C_PTR) KPLIB
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IREX,IAPT
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISOBIS
+      REAL, ALLOCATABLE, DIMENSION(:) :: STIS,GAS,UUU,DELBIN,DELTAU
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: GA2,PRI,SPH,FIXE,PHGAR,STGAR,
+     1 SFGAR,FUNKNO,SIGT,SIGS,SIGS1,SIGF,UNGAR
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SSGAR,SAGAR,SDGAR
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SIGGAR,S0GAR
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: WSIG
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI
+      LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: MASKG
+      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HVECT
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO1
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(ISOBIS(3,NBISO),IREX(NBMIX),IAPT(NBISO))
+      ALLOCATE(MASKI(NBISO),HVECT(NED))
+*----
+*  FIND THE NEW ISOTOPE NAMES IN IPLI0.
+*----
+      CALL LCMLEN(IPLI0,'ISOTOPESUSED',ILONG,ITYLCM)
+      IF(ILONG.NE.0) THEN
+         CALL LCMGET(IPLI0,'ISOTOPESUSED',ISOBIS)
+      ELSE
+         CALL LCMGET(IPLIB,'ISOTOPESUSED',ISOBIS)
+      ENDIF
+      CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT)
+      DO 10 ISO=1,NBISO
+      WRITE(TEXT4,'(A4)') IHSUF(ISO)
+      IF(TEXT4.NE.' ') ISOBIS(3,ISO)=IHSUF(ISO)
+   10 CONTINUE
+      CALL LCMPUT(IPLI0,'ISOTOPESUSED',3*NBISO,3,ISOBIS)
+*----
+*  COMPUTE THE NUMBER OF RESONANT ISOTOPES IN REGION INRS AND THE
+*  RESONANT ISOTOPE INDEX ASSOCIATED TO EACH ISOTOPE SPECIFICATION.
+*----
+      NIRES=0
+      DO 50 ISO=1,NBISO
+      IAPT(ISO)=0
+      IF((LSHI(ISO).EQ.INRS).AND.(DEN(ISO).NE.0.0)) THEN
+         DO 20 NRE=1,NREG
+         IF(MAT(NRE).EQ.MIX(ISO)) GO TO 30
+   20    CONTINUE
+         GO TO 50
+   30    DO 40 JSO=1,ISO-1
+         IF((ISOBIS(1,ISO).EQ.ISOBIS(1,JSO)).AND.
+     1      (ISOBIS(2,ISO).EQ.ISOBIS(2,JSO)).AND.
+     2      (ISOBIS(3,ISO).EQ.ISOBIS(3,JSO)).AND.
+     3      (LSHI(JSO).EQ.INRS).AND.
+     4      (DEN(JSO).NE.0.0).AND.(IAPT(JSO).NE.0)) THEN
+              IAPT(ISO)=IAPT(JSO)
+              GO TO 50
+         ENDIF
+   40    CONTINUE
+         NIRES=NIRES+1
+         IAPT(ISO)=NIRES
+      ENDIF
+   50 CONTINUE
+      WRITE(HCAL,'(1HC,I5.5)') INRS
+      IF(NIRES.EQ.0) THEN
+         WRITE(HSMG,'(45HAUTONE: NO RESONANT ISOTOPES IN RESONANT REGI,
+     1   9HON NUMBER,I4,7H (HCAL=,A12,2H).)') INRS,HCAL
+         CALL XABORT(HSMG)
+      ENDIF
+      IF(IMPX.GT.0) WRITE(6,'(/35H AUTONE: PERFORMING SELF-SHIELDING ,
+     1 18HCALCULATION NAMED ,A12,1H.)') HCAL
+*----
+*  FIND THE NUMBER OF FUEL REGIONS AND THE FUEL REGION INDICES ASSIGNED
+*  TO EACH RESONANT MIXTURE.
+*----
+      ALLOCATE(MASKG(NGRP,NIRES))
+      IREX(:NBMIX)=0
+      DO 60 ISO=1,NBISO
+      IBM=MIX(ISO)
+      IF((IBM.GT.0).AND.(IAPT(ISO).NE.0)) IREX(IBM)=1
+   60 CONTINUE
+      NBNRS=MAXVAL(IREX(:NBMIX))
+      IF(NBNRS.NE.1) CALL XABORT('AUTONE: NBNRS=1 EXPECTED.')
+      IF(IMPX.GE.1) WRITE(6,410) NIRES,NBNRS,INRS
+*----
+*  DETERMINE WHICH MODERATOR ISOTOPES ARE MIXED WITH RESONANT ONES.
+*----
+      DO 70 ISO=1,NBISO
+      IF((IAPT(ISO).EQ.0).AND.(IREX(MIX(ISO)).GT.0)) IAPT(ISO)=NIRES+1
+   70 CONTINUE
+      IF(IMPX.GT.1) THEN
+        WRITE(6,'(/48H AUTONE: IDENTIFICATION OF SELF-SHIELDED ISOTOPE,
+     1  14HS (0 < IAPT <=,I4,20H) IN RESONANT REGION,I4,1H:)') NIRES,
+     2  INRS
+        WRITE(6,'(33H ISOTOPE     IAPT    USED NAME...)')
+        DO ISO=1,NBISO
+          WRITE(NAME,'(3A4)') ISOBIS(:3,ISO)
+          WRITE(6,'(1X,I7,5X,I4,2X,A14)') ISO,IAPT(ISO),NAME
+        ENDDO
+      ENDIF
+*
+      ALLOCATE(SPH(NIRES,NGRP),FIXE(NIRES,NGRP),PHGAR(NIRES,NGRP),
+     1 STGAR(NIRES,NGRP),SFGAR(NIRES,NGRP),SSGAR(NIRES,NL,NGRP),
+     2 S0GAR(NIRES,NL,NGRP,NGRP),SAGAR(NIRES,NED,NGRP),
+     3 SDGAR(NIRES,NDEL,NGRP),DELTAU(NGRP))
+      ALLOCATE(SIGGAR(NBMIX,0:NIRES,NGRP,3),UNGAR(NUN,NGRP))
+      ALLOCATE(UUU(LBIN+1),DELBIN(LBIN),STAT=IER_OK)
+      IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(1).')
+      ALLOCATE(FUNKNO(NUN,LBIN),STAT=IER_OK)
+      IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(2).')
+      ALLOCATE(SIGT(LBIN,NBISO),STAT=IER_OK)
+      IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(3).')
+      ALLOCATE(SIGS(LBIN,NBISO),STAT=IER_OK)
+      IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(4).')
+      ALLOCATE(SIGS1(LBIN,NBISO),STAT=IER_OK)
+      IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(5).')
+      ALLOCATE(SIGF(LBIN,NBISO),STAT=IER_OK)
+      IF(IER_OK /= 0) CALL XABORT('AUTONE: ALLOCATION PROBLEM(6).')
+*----
+*  COMPUTE THE NEUTRON FLUX.
+*----
+      CALL AUTFLU(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,
+     1 MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,
+     2 IGRRES,IGRMAX,DIL,TITR,IALTER,DELI,LBIN,NBIN,EBIN,MAXTRA,ISEED,
+     3 ITRANC,UUU,FUNKNO,SIGT,SIGS,SIGS1,SIGF,SIGGAR,MASKG)
+*----
+*  COMPUTE UNGAR.
+*----
+      UNGAR(:NUN,:NGRP)=0.0
+      LLL=0
+      DO 110 IG=1,NGRP
+      GAR0=0.0D0
+      DO 90 LI=1,NBIN(IG)
+      LLL=LLL+1
+      IF(LLL.GT.LBIN) CALL XABORT('AUTONE: LBIN OVERFLOW.')
+      DELBIN(LLL)=UUU(LLL+1)-UUU(LLL)
+      GAR0=GAR0+DELBIN(LLL)
+      DO 80 IUN=1,NUN
+      UNGAR(IUN,IG)=UNGAR(IUN,IG)+FUNKNO(IUN,LLL)*DELBIN(LLL)
+   80 CONTINUE
+   90 CONTINUE
+      DO 100 IUN=1,NUN
+      UNGAR(IUN,IG)=UNGAR(IUN,IG)/REAL(GAR0)
+  100 CONTINUE
+  110 CONTINUE
+*----
+*  CONDENSATION OF AUTOLIB FLUX AND OF RESONANT REACTION RATES.
+*----
+      ALLOCATE(IPISO1(NBISO),GAS(NGRP),GA2(NGRP,NGRP),PRI(MAXTRA,NL))
+      CALL LIBIPS(IPLIB,NBISO,IPISO1)
+      DELTAU(:NGRP)=0.0
+      FIXE(:NIRES,:NGRP)=0.0
+      PHGAR(:NIRES,:NGRP)=0.0
+      STGAR(:NIRES,:NGRP)=0.0
+      SFGAR(:NIRES,:NGRP)=0.0
+      SSGAR(:NIRES,:NL,:NGRP)=0.0
+      S0GAR(:NIRES,:NL,:NGRP,:NGRP)=0.0
+      SAGAR(:NIRES,:NED,:NGRP)=0.0
+      SDGAR(:NIRES,:NDEL,:NGRP)=0.0
+      DO 260 ISO=1,NBISO
+      IBM=MIX(ISO)
+      IF(IBM.LE.0) GO TO 260
+      IRES=IAPT(ISO)
+      IF((IRES.GT.0).AND.(IRES.LE.NIRES)) THEN
+        ! recover infinite dilution values
+        KPLIB=IPISO1(ISO) ! set ISO-th isotope
+        CALL LCMGET(KPLIB,'AWR',AWR)
+        CALL LCMGET(KPLIB,'NTOT0',GAS)
+        STGAR(IRES,:NGRP)=GAS(:NGRP)
+        CALL LCMLEN(KPLIB,'NUSIGF',ILENGT,ITYLCM)
+        IF(ILENGT.GT.0) THEN
+          CALL LCMGET(KPLIB,'NUSIGF',GAS)
+          SFGAR(IRES,:NGRP)=GAS(:NGRP)
+        ENDIF
+        DO 120 IL=1,NL
+        CALL XDRLGS(KPLIB,-1,IMPX,IL-1,IL-1,1,NGRP,GAS,GA2,ITYPRO)
+        S0GAR(IRES,IL,:NGRP,:NGRP)=GA2(:NGRP,:NGRP)
+        SSGAR(IRES,IL,:NGRP)=GAS(:NGRP)
+  120   CONTINUE
+        DO 125 IED=1,NED
+        CALL LCMLEN(KPLIB,HVECT(IED),ILENGT,ITYLCM)
+        IF(ILENGT.GT.0) THEN
+          CALL LCMGET(KPLIB,HVECT(IED),GAS)
+          SAGAR(IRES,IED,:NGRP)=GAS(:NGRP)
+        ENDIF
+  125   CONTINUE
+        DO 130 IDEL=1,NDEL
+        WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
+        CALL LCMLEN(KPLIB,TEXT12,ILENGT,ITYLCM)
+        IF(ILENGT.GT.0) THEN
+          CALL LCMGET(KPLIB,TEXT12,GAS)
+          SDGAR(IRES,IDEL,:NGRP)=GAS(:NGRP)
+        ENDIF
+  130   CONTINUE
+        ! set elastic scattering information.
+        DO 135 IL=1,NL
+          CALL LIBPRI(MAXTRA,DELI,AWR,IALTER,IL-1,NEXT0,PRI(1,IL))
+  135   ENDDO
+        ! include self-shielded values
+        LLL=0
+        DO 140 IG=1,IGRMIN-1
+        LLL=LLL+NBIN(IG)
+  140   CONTINUE
+        ALLOCATE(STIS(LBIN),WSCAT(NGRP,NGRP,NL),WSIG(NGRP,NL))
+        WSCAT(:NGRP,:NGRP,:NL)=0.0D0
+        WSIG(:NGRP,:NL)=0.0D0
+        DO 210 IG=IGRMIN,IGRMAX
+        SSGAR1=SSGAR(IRES,1,IG)
+        ABGAR1=STGAR(IRES,IG)-SSGAR(IRES,1,IG)
+        SFGAR1=SFGAR(IRES,IG)
+        LABS=ABS(ABGAR1).GT.1.0E-5*ABS(STGAR(IRES,IG))
+        VOLTOT=0.0D0
+        GAR0=0.0D0
+        GAR1=0.0D0
+        GAR2=0.0D0
+        GAR3=0.0D0
+        GAR4=0.0D0
+        DO 150 NRE=1,NREG
+        IF(MAT(NRE).EQ.IBM) VOLTOT=VOLTOT+VOL(NRE)
+  150   CONTINUE
+        DO 190 LI=1,NBIN(IG)
+        LLL=LLL+1
+        IF(LLL.GT.LBIN) CALL XABORT('AUTONE: LBIN OVERFLOW.')
+        GAR0=GAR0+DELBIN(LLL)
+        DO 180 NRE=1,NREG
+        IF(MAT(NRE).NE.IBM) GO TO 180
+        IUN=KEYFLX(NRE)
+        IF(IUN.EQ.0) GO TO 180
+        FLUXL=FUNKNO(IUN,LLL)*VOL(NRE)*DELBIN(LLL)
+        GAR1=GAR1+FLUXL
+        GAR2=GAR2+SIGT(LLL,ISO)*FLUXL
+        GAR3=GAR3+SIGS(LLL,ISO)*FLUXL
+        GAR4=GAR4+SIGF(LLL,ISO)*FLUXL
+        DO 175 IL=1,NL
+        STIS(:LBIN)=0.0
+        CALL LIBECT(MAXTRA,LLL,PRI(1,IL),UUU(2),DELI,DELBIN,NEXT0,1,MML,
+     1  STIS)
+        LLJ=0
+        DO 170 JG=1,NGRP
+        DO 160 LJ=1,NBIN(JG)
+        I=LLL-LLJ
+        IF(I.LE.0) GO TO 175
+        LLJ=LLJ+1
+        WSCAT(JG,IG,IL)=WSCAT(JG,IG,IL)+SIGS(LLJ,ISO)*STIS(I)*
+     1  FUNKNO(IUN,LLJ)*VOL(NRE)*DELBIN(LLJ) ! JG --> IG
+  160   CONTINUE
+  170   CONTINUE
+  175   CONTINUE
+  180   CONTINUE
+  190   CONTINUE
+        DELTAU(IG)=REAL(GAR0)
+        STGAR(IRES,IG)=REAL(GAR2/GAR1)
+        SSGAR(IRES,1,IG)=REAL(GAR3/GAR1)
+        SFGAR(IRES,IG)=REAL(GAR4/GAR1)
+        FIXE(IRES,IG)=DIL(ISO)*DELTAU(IG)
+        PHGAR(IRES,IG)=REAL(GAR1/(VOLTOT*GAR0))
+        DO 205 IL=1,NL
+        DO 200 JG=1,IG
+        IF(NBIN(JG).GT.0) THEN
+          IF(PHGAR(IRES,JG).NE.0.0) THEN
+            WSCAT(JG,IG,IL)=WSCAT(JG,IG,IL)/(PHGAR(IRES,JG)*VOLTOT*
+     1      DELTAU(JG))
+            WSIG(JG,IL)=WSIG(JG,IL)+WSCAT(JG,IG,IL)
+          ELSE
+            WSCAT(JG,IG,IL)=0.0D0
+          ENDIF
+        ENDIF
+  200   CONTINUE
+  205   CONTINUE
+        SSGAR2=SSGAR(IRES,1,IG)
+        ABGAR2=STGAR(IRES,IG)-SSGAR(IRES,1,IG)
+        SFGAR2=SFGAR(IRES,IG)
+        DO IED=1,NED
+          IF((HVECT(IED).EQ.'NINEL').OR.(HVECT(IED).EQ.'NELAS').OR.
+     1       (HVECT(IED).EQ.'N2N').OR.(HVECT(IED).EQ.'N3N').OR.
+     2       (HVECT(IED).EQ.'N4N').OR.(HVECT(IED).EQ.'NX').OR.
+     3       (HVECT(IED).EQ.'STRD')) THEN
+            SAGAR(IRES,IED,IG)=SAGAR(IRES,IED,IG)*SSGAR2/SSGAR1
+          ELSE
+            IF(LABS) SAGAR(IRES,IED,IG)=SAGAR(IRES,IED,IG)*ABGAR2/ABGAR1
+          ENDIF
+        ENDDO
+        DO IDEL=1,NDEL
+          SDGAR(IRES,IDEL,IG)=SDGAR(IRES,IDEL,IG)*SFGAR2/SFGAR1
+        ENDDO
+  210   CONTINUE
+        DO 240 IL=1,NL
+        DO 230 IG=IGRMIN,IGRMAX
+        IF(IL.GT.1) SSGAR(IRES,IL,IG)=REAL(WSIG(IG,IL))
+        DO 220 JG=IGRMIN,IGRMAX
+        S0GAR(IRES,IL,JG,IG)=REAL(WSCAT(IG,JG,IL))
+  220   CONTINUE
+  230   CONTINUE
+  240   CONTINUE
+        IF(IMPX.GT.3) THEN
+          WRITE(6,'(//18H AUTONE: ISOTOPE='',3A4,1H''/9X,10HMICROSCOPI,
+     1    28HC XS BEFORE SELF-SHIELDING (,I5,9H <= IG <=,I5,1H))')
+     2    ISOBIS(:3,ISO),IGRMIN,IGRMAX
+          WRITE(6,'(/27H CONDENSED LETHARGY WIDTHS:/(1X,1P,10E12.4))')
+     1    (DELTAU(IG),IG=1,NGRP)
+          WRITE(6,'(/25H CONDENSED FIXED SOURCES:/(1X,1P,10E12.4))')
+     1    (FIXE(IRES,IG),IG=1,NGRP)
+          WRITE(6,'(/24H CONDENSED NEUTRON FLUX:/(1X,1P,10E12.4))')
+     1    (PHGAR(IRES,IG),IG=1,NGRP)
+          WRITE(6,'(/46H CONDENSED P0 MICROSCOPIC DIFFUSION CROSS-SECT,
+     1    5HIONS:/(1X,1P,10E12.4))') (SSGAR(IRES,1,IG),IG=1,NGRP)
+          WRITE(6,'(/46H CONDENSED P0 MICROSCOPIC DIFFUSION CROSS-SECT,
+     1    13HIONS (CHECK):/(1X,1P,10E12.4))') (WSIG(IG,1),IG=1,NGRP)
+          WRITE(6,'(/44H CONDENSED MICROSCOPIC TOTAL CROSS-SECTIONS:/
+     1    (1X,1P,10E12.4))') (STGAR(IRES,IG),IG=1,NGRP)
+          WRITE(6,'(/46H CONDENSED MICROSCOPIC FISSION CROSS-SECTIONS:/
+     1    (1X,1P,10E12.4))') (SFGAR(IRES,IG),IG=1,NGRP)
+        ENDIF
+        DEALLOCATE(WSIG,WSCAT,STIS)
+      ENDIF
+  260 CONTINUE
+      DEALLOCATE(PRI,GA2,GAS,IPISO1)
+*----
+*  COMPUTE THE SPH FACTORS.
+*----
+      SPH(:NIRES,:NGRP)=1.0
+      IF(KSPH.GT.0) THEN
+        CALL LCMGET(IPLI0,'DELTAU',DELTAU)
+        CALL AUTSPH(IPLI0,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,
+     1  NED,NDEL,HCAL,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,IAPT,
+     2  ITRANC,IPHASE,NGRP,MASKG,IREX,TITR,SIGGAR,UNGAR,PHGAR,STGAR,
+     3  SFGAR,SSGAR,S0GAR,SAGAR,SDGAR,DELTAU,SPH)
+      ENDIF
+*----
+*  PRINT SELF-SHIELDED MICROSCOPIC CROSS SECTIONS.
+*----
+      IF(IMPX.GT.1) THEN
+        DO 300 ISO=1,NBISO
+        IBM=MIX(ISO)
+        IF(IBM.LE.0) GO TO 300
+        IRES=IAPT(ISO)
+        IF((IRES.GT.0).AND.(IRES.LE.NIRES)) THEN
+          WRITE(6,'(//18H AUTONE: ISOTOPE='',3A4,1H''/9X,10HMICROSCOPI,
+     1    20HC SELF-SHIELDED XS (,I5,9H <= IG <=,I5,1H))')
+     2    ISOBIS(:3,ISO),IGRMIN,IGRMAX
+          IF(KSPH.GT.0) THEN
+            WRITE(6,'(/13H SPH FACTORS:/(1X,1P,10E12.4))')
+     1      (SPH(IRES,IG),IG=IGRMIN,IGRMAX)
+          ENDIF
+          WRITE(6,'(/27H CONDENSED FINE STRUCTURES:/(1X,1P,10E12.4))')
+     1    (PHGAR(IRES,IG),IG=IGRMIN,IGRMAX)
+          WRITE(6,'(/46H CONDENSED P0 MICROSCOPIC DIFFUSION CROSS-SECT,
+     1    5HIONS:/(1X,1P,10E12.4))') (SSGAR(IRES,1,IG),IG=IGRMIN,IGRMAX)
+          WRITE(6,'(/44H CONDENSED MICROSCOPIC TOTAL CROSS-SECTIONS:/
+     1    (1X,1P,10E12.4))') (STGAR(IRES,IG),IG=IGRMIN,IGRMAX)
+          WRITE(6,'(/46H CONDENSED MICROSCOPIC FISSION CROSS-SECTIONS:/
+     1    (1X,1P,10E12.4))') (SFGAR(IRES,IG),IG=IGRMIN,IGRMAX)
+          IF(NL.GT.1) THEN
+            WRITE(6,'(/44H CONDENSED P1 MICROSCOPIC DIFFUSION CROSS-SE,
+     1      7HCTIONS:/(1X,1P,10E12.4))') (SSGAR(IRES,2,IG),IG=IGRMIN,
+     2      IGRMAX)
+          ENDIF
+          IF(IMPX.GT.2) THEN
+          DO 290 IL=1,NL
+            WRITE(6,'(/12H CONDENSED P,I2.2,23H MICROSCOPIC TRANSFER C,
+     1      14HROSS-SECTIONS:)') IL-1
+            DO 280 IG=IGRMIN,IGRMAX
+            JGRMIN=NGRP+1
+            JGRMAX=0
+            DO 270 JG=1,NGRP
+            IF(S0GAR(IRES,IL,JG,IG).NE.0.0) THEN
+              JGRMIN=MIN(JGRMIN,JG)
+              JGRMAX=MAX(JGRMAX,JG)
+            ENDIF
+  270       CONTINUE
+            WRITE(6,420) (IG,JG,S0GAR(IRES,IL,JG,IG),JG=JGRMIN,JGRMAX)
+  280       CONTINUE
+  290       CONTINUE
+          ENDIF
+        ENDIF
+  300   CONTINUE
+      ENDIF
+      DEALLOCATE(SIGF,SIGS1,SIGS,SIGT,FUNKNO,DELBIN,UUU)
+      DEALLOCATE(UNGAR,SIGGAR)
+*----
+*  CREATE THE SELF-SHIELDED INTERNAL LIBRARY USING A SIMPLE
+*  TRANSCRIPTION OF THE SELF-SHIELDED CROSS SECTIONS.
+*----
+      CALL KDRCPU(TK1)
+*     SIMPLE TRANSCRIPTION OF THE SELF-SHIELDED CROSS SECTIONS.
+      DO 310 ISO=1,NBISO
+      MASKI(ISO)=(IAPT(ISO).GT.0).AND.(IAPT(ISO).LE.NIRES)
+  310 CONTINUE
+      DO 330 ISO=1,NBISO
+      IF(MASKI(ISO)) THEN
+         DO 320 JSO=ISO+1,NBISO
+         IF((ISOBIS(1,ISO).EQ.ISOBIS(1,JSO)).AND.
+     1      (ISOBIS(2,ISO).EQ.ISOBIS(2,JSO)).AND.
+     2      (ISOBIS(3,ISO).EQ.ISOBIS(3,JSO))) MASKI(JSO)=.FALSE.
+  320    CONTINUE
+      ENDIF
+  330 CONTINUE
+      CALL USSIN1(IPLI0,IPLIB,NGRP,NBMIX,NBISO,NIRES,NBNRS,NL,NED,NDEL,
+     1 IREX,IMPX,ISONAM,ISOBIS,MIX,IAPT,MASKI,SPH,PHGAR,STGAR,SFGAR,
+     2 SSGAR,S0GAR,SAGAR,SDGAR)
+      CALL KDRCPU(TK2)
+      IF(IMPX.GT.1) WRITE(6,'(/36H AUTONE: CPU TIME SPENT TO BUILD THE,
+     1 33H SELF-SHIELDED INTERNAL LIBRARY =,F8.1,8H SECOND.)') TK2-TK1
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(DELTAU,SDGAR,SAGAR,S0GAR,SSGAR,SFGAR,STGAR,PHGAR,SPH)
+      DEALLOCATE(MASKG,HVECT,MASKI)
+      DEALLOCATE(IAPT,IREX,ISOBIS)
+      RETURN
+*
+  410 FORMAT(/48H AUTONE: NUMBER OF CORRELATED RESONANT ISOTOPES=,I4/9X,
+     1 35HNUMBER OF CORRELATED FUEL MIXTURES=,I4,19H IN RESONANT REGION,
+     2 I3)
+  420 FORMAT(1P,3X,I4,4H -->,I4,2H :,E12.4,3X,I4,4H -->,I4,2H :,E12.4,
+     1 3X,I4,4H -->,I4,2H :,E12.4,3X,I4,4H -->,I4,2H :,E12.4,
+     2 3X,I4,4H -->,I4,2H :,E12.4,3X,I4,4H -->,I4,2H :,E12.4)
+      END