Initial commit from Polytechnique Montreal

1 files changed, 190 insertions, 0 deletions

diff --git a/Dragon/src/USSONE.f b/Dragon/src/USSONE.f
new file mode 100644
index 0000000..89dbd9e
--- /dev/null
+++ b/Dragon/src/USSONE.f
@@ -0,0 +1,190 @@
+*DECK USSONE
+      SUBROUTINE USSONE(IPLI0,IPTRK,IPLIB,IFTRAK,CDOOR,IMPX,IGRMIN,
+     1 IGRMAX,NIRES,NBNRS,IREX,NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,
+     2 ISONAM,IHSUF,HCAL,DEN,MIX,IAPT,MAT,VOL,KEYFLX,LEAKSW,ITRANC,
+     3 IPHASE,TITR,KSPH,ICORR,ISUBG,MAXST)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Perform a resonance self-shielding calculation named HCAL and build
+* a corresponding internal library.
+*
+*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 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).
+* IGRMIN  first group where the self-shielding is applied.
+* IGRMAX  most thermal group where the self-shielding is applied.
+* NIRES   number of correlated resonant isotopes in fuel regions.
+* NBNRS   number of correlated fuel regions. Note that NBNRS=max(IREX).
+* IREX    fuel region index assigned to each mixture. Equal to zero
+*         in non-resonant mixtures or in mixtures not used.
+* 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.
+* HCAL    name of the self-shielding calculation.
+* 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.
+* 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).
+* ICORR   mutual resonance shielding flag (=1 to suppress the model
+*         in cases it is required in LIB operator).
+* ISUBG   type of self-shielding model (=1 use physical probability
+*         tables; =3 use original Ribon method; =4 use Ribon extended
+*         method; =6 use resonance spectrum expansion method).
+* MAXST   maximum number of fixed point iterations for the ST scattering
+*         source.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLI0,IPTRK,IPLIB
+      INTEGER IFTRAK,IMPX,IGRMIN,IGRMAX,NIRES,NBNRS,IREX(NBMIX),
+     1 NGRP,NBMIX,NREG,NUN,NBISO,NL,NED,NDEL,ISONAM(3,NBISO),
+     2 IHSUF(NBISO),MIX(NBISO),IAPT(NBISO),MAT(NREG),KEYFLX(NREG),
+     3 ITRANC,IPHASE,KSPH,ICORR,ISUBG,MAXST
+      REAL DEN(NBISO),VOL(NREG)
+      LOGICAL LEAKSW
+      CHARACTER CDOOR*12,HCAL*12,TITR*72
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISOBIS
+      REAL, ALLOCATABLE, DIMENSION(:) :: SIGAR,UNGAR,DELTAU
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: GOLD
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SPH,PHGAR,STGAR,SFGAR,SWGAR
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SSGAR,SAGAR,SDGAR
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:,:) :: S0GAR
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKI
+      LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: MASKG
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(ISOBIS(3,NBISO))
+      ALLOCATE(SPH(NBNRS,NIRES,NGRP),PHGAR(NBNRS,NIRES,NGRP),
+     1 STGAR(NBNRS,NIRES,NGRP),SFGAR(NBNRS,NIRES,NGRP),
+     2 SSGAR(NBNRS,NIRES,NL,NGRP),S0GAR(NBNRS,NIRES,NL,NGRP,NGRP),
+     3 SAGAR(NBNRS,NIRES,NED,NGRP),SDGAR(NBNRS,NIRES,NDEL,NGRP),
+     4 SWGAR(NBNRS,NIRES,NGRP),DELTAU(NGRP))
+      ALLOCATE(MASKI(NBISO),MASKG(NGRP,NIRES))
+*----
+*  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
+      DO 10 ISO=1,NBISO
+      IF((IAPT(ISO).GT.0).AND.(IAPT(ISO).LE.NIRES)) THEN
+         ISOBIS(3,ISO)=IHSUF(ISO)
+      ENDIF
+   10 CONTINUE
+      CALL LCMPUT(IPLI0,'ISOTOPESUSED',3*NBISO,3,ISOBIS)
+*
+      ALLOCATE(SIGAR(4*NBMIX*(NIRES+1)*NGRP),UNGAR(NUN*NIRES*NGRP),
+     1 GOLD(NIRES,NGRP))
+*----
+*  COMPUTE THE NEUTRON FLUX.
+*----
+      IF(ISUBG.EQ.6) THEN
+        ! resonance spectrum expansion method
+        CALL USSRSE(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO,
+     1  NIRES,NL,NED,NDEL,ISONAM,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR,
+     2  LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS,
+     3  IREX,TITR,ICORR,MAXST,GOLD,UNGAR,PHGAR,STGAR,SFGAR,SSGAR,
+     4  S0GAR,SAGAR,SDGAR,MASKG,SIGAR)
+      ELSE
+        ! subgroup method
+        CALL USSFLU(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO,
+     1  NIRES,NL,NED,NDEL,ISONAM,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR,
+     2  LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS,
+     3  IREX,TITR,ICORR,ISUBG,MAXST,GOLD,UNGAR,PHGAR,STGAR,SFGAR,
+     4  SSGAR,S0GAR,SAGAR,SDGAR,SWGAR,MASKG,SIGAR)
+      ENDIF
+*----
+*  COMPUTE THE SPH FACTORS.
+*----
+      SPH(:NBNRS,:NIRES,:NGRP)=1.0
+      IF(KSPH.EQ.1) THEN
+         CALL LCMGET(IPLI0,'DELTAU',DELTAU)
+         CALL USSSPH(IPLI0,IPTRK,IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,
+     1   NED,NDEL,ISONAM,HCAL,MAT,VOL,KEYFLX,CDOOR,LEAKSW,IMPX,DEN,MIX,
+     2   IAPT,ITRANC,IPHASE,NGRP,MASKG,NBNRS,IREX,TITR,ISUBG,SIGAR,
+     3   GOLD,UNGAR,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,SAGAR,SDGAR,SWGAR,
+     4   DELTAU,SPH)
+      ENDIF
+*
+      DEALLOCATE(GOLD,UNGAR,SIGAR)
+*----
+*  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 100 ISO=1,NBISO
+      MASKI(ISO)=(IAPT(ISO).GT.0).AND.(IAPT(ISO).LE.NIRES)
+  100 CONTINUE
+      DO 120 ISO=1,NBISO
+      IF(MASKI(ISO)) THEN
+         DO 110 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.
+  110    CONTINUE
+      ENDIF
+  120 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 USSONE: CPU TIME SPENT TO BUILD THE,
+     1 33H SELF-SHIELDED INTERNAL LIBRARY =,F8.1,8H SECOND.)') TK2-TK1
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(MASKG,MASKI)
+      DEALLOCATE(DELTAU,SWGAR,SDGAR,SAGAR,S0GAR,SSGAR,SFGAR,STGAR,
+     1 PHGAR,SPH)
+      DEALLOCATE(ISOBIS)
+      RETURN
+      END