path: root/Dragon/src/AUTONE.f

*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