Initial commit from Polytechnique Montreal

1 files changed, 187 insertions, 0 deletions

diff --git a/Dragon/src/LIBTAB.f b/Dragon/src/LIBTAB.f
new file mode 100644
index 0000000..c218979
--- /dev/null
+++ b/Dragon/src/LIBTAB.f
@@ -0,0 +1,187 @@
+*DECK LIBTAB
+      SUBROUTINE LIBTAB (IGRP,NGRO,NL,NDIL,NPART,NED,NDEL,HNAMIS,IMPX,
+     1 LSCAT,LSIGF,LADD,DILUT,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,GOLD,ISMIN,
+     2 ISMAX,NOR,SIGP)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transform dilution dependent information into probability tables.
+*
+*Copyright:
+* Copyright (C) 2002 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
+* IGRP    energy group index where the transformation occurs.
+* NGRO    number of energy groups.
+* NL      number of Legendre orders required in the calculation
+*         (NL=1 or higher).
+* NDIL    number of finite dilutions.
+* NPART   2 + number of partial cross sections.
+* NED     number of extra vector edits.
+* NDEL    number of delayed neutron precursor groups.
+* HNAMIS  local name of the isotope:
+*         HNAMIS(1:8)  the local isotope name;
+*         HNAMIS(9:12) suffix function of the mix number.
+* IMPX    print flag.
+* LSCAT   Legendre flag (=.true. if a given Legendre order of the
+*         scattering cross section exists).
+* LSIGF   fission flag (=.true. if the isotope can fission).
+* LADD    additional xs flag (=.true. if a given additional cross
+*         section exists).
+* DILUT   dilutions.
+* TOTAL   total cross sections.
+* SIGF    nu*fission cross sections.
+* SIGS    scattering cross sections.
+* SCAT    scattering transfer matrices (sec,prim,Legendre,dilution).
+* SADD    additional cross sections.
+* ZDEL    delayed nu-sigf cross sections.
+* GOLD    Goldstein-Cohen parameter.
+* ISMIN   minimum secondary group corresponding to each primary group.
+* ISMAX   maximum secondary group corresponding to each primary group.
+*
+*Parameters: output
+* NOR     order of the probability table.
+* SIGP    partial cross sections.
+*
+*-----------------------------------------------------------------------
+*
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      PARAMETER (MAXNOR=12)
+      INTEGER IGRP,NGRO,NL,NDIL,NPART,NED,NDEL,IMPX,ISMIN(NL,NGRO),
+     1 ISMAX(NL,NGRO),NOR
+      REAL DILUT(NDIL+1),TOTAL(NGRO,NDIL+1),SIGF(NGRO,NDIL+1),
+     1 SIGS(NGRO,NL,NDIL+1),SCAT(NGRO,NGRO,NL,NDIL+1),
+     2 SADD(NGRO,NED,NDIL+1),ZDEL(NGRO,NDEL,NDIL+1),GOLD,
+     3 SIGP(MAXNOR,NPART)
+      LOGICAL LSIGF,LSCAT(NL),LADD(NED)
+      CHARACTER HNAMIS*12
+*----
+*  LOCAL VARIABLES
+*----
+      REAL, ALLOCATABLE, DIMENSION(:) :: DILUT2,XSDIL
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LDIL
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(LDIL(NDIL+1),DILUT2(NDIL+1))
+*----
+*  REMOVE BADLY BEHAVED COLLOCATIONS POINTS.
+*----
+      MDIL=NDIL
+      DO 10 IDIL=1,NDIL+1
+      LDIL(IDIL)=.TRUE.
+   10 CONTINUE
+      TEST=TOTAL(IGRP,NDIL+1)
+      DO 20 IDIL=NDIL,1,-1
+      IF(ABS(TOTAL(IGRP,IDIL)-TEST).LE.2.0E-4*ABS(TEST)) THEN
+         MDIL=MDIL-1
+         LDIL(IDIL)=.FALSE.
+      ELSE IF(DILUT(IDIL).LT.1.0) THEN
+         MDIL=MDIL-1
+         LDIL(IDIL)=.FALSE.
+      ELSE IF((DILUT(IDIL).GT.1.0E5).AND.(DILUT(IDIL).LT.1.0E10)) THEN
+         MDIL=MDIL-1
+         LDIL(IDIL)=.FALSE.
+      ELSE IF(TOTAL(IGRP,IDIL).LE.0.0) THEN
+         MDIL=MDIL-1
+         LDIL(IDIL)=.FALSE.
+      ELSE IF(TOTAL(IGRP,IDIL)-(1.0-GOLD)*SIGS(IGRP,1,IDIL).LE.0.0) THEN
+         MDIL=MDIL-1
+         LDIL(IDIL)=.FALSE.
+      ELSE
+         TEST=TOTAL(IGRP,IDIL)
+      ENDIF
+   20 CONTINUE
+*
+      ALLOCATE(XSDIL((MDIL+1)*(NPART-1)))
+      IOFSET=-1
+      IDD=0
+      DO 30 IDIL=1,NDIL+1
+      IF(LDIL(IDIL)) THEN
+         IDD=IDD+1
+         DILUT2(IDD)=DILUT(IDIL)
+         IOFSET=IOFSET+1
+         XSDIL(IOFSET+1)=TOTAL(IGRP,IDIL)
+      ENDIF
+   30 CONTINUE
+      IF(IDD.NE.MDIL+1) CALL XABORT('LIBTAB: INTERNAL ERROR.')
+      DO 40 IDIL=1,NDIL+1
+      IF(LDIL(IDIL)) THEN
+         IOFSET=IOFSET+1
+         IF(LSIGF) THEN
+            XSDIL(IOFSET+1)=SIGF(IGRP,IDIL)
+         ELSE
+            XSDIL(IOFSET+1)=0.0
+         ENDIF
+      ENDIF
+   40 CONTINUE
+      DO 55 IL=1,NL
+      DO 50 IDIL=1,NDIL+1
+      IF(LDIL(IDIL)) THEN
+         IOFSET=IOFSET+1
+         IF(LSCAT(IL)) THEN
+            XSDIL(IOFSET+1)=SIGS(IGRP,IL,IDIL)
+         ELSE
+            XSDIL(IOFSET+1)=0.0
+         ENDIF
+      ENDIF
+   50 CONTINUE
+   55 CONTINUE
+      IF(NPART.EQ.3+NL) GO TO 100
+      DO 70 IL=1,NL
+      IF(LSCAT(IL)) THEN
+         DO 65 IG2=ISMIN(IL,IGRP),ISMAX(IL,IGRP)
+         DO 60 IDIL=1,NDIL+1
+         IF(LDIL(IDIL)) THEN
+            IOFSET=IOFSET+1
+            XSDIL(IOFSET+1)=SCAT(IG2,IGRP,IL,IDIL)
+         ENDIF
+   60    CONTINUE
+   65    CONTINUE
+      ENDIF
+   70 CONTINUE
+      DO 85 IED=1,NED
+      DO 80 IDIL=1,NDIL+1
+      IF(LDIL(IDIL)) THEN
+         IOFSET=IOFSET+1
+         IF(LADD(IED)) THEN
+            XSDIL(IOFSET+1)=SADD(IGRP,IED,IDIL)
+         ELSE
+            XSDIL(IOFSET+1)=0.0
+         ENDIF
+      ENDIF
+   80 CONTINUE
+   85 CONTINUE
+      DO 95 IDEL=1,NDEL
+      DO 90 IDIL=1,NDIL+1
+      IF(LDIL(IDIL)) THEN
+         IOFSET=IOFSET+1
+         XSDIL(IOFSET+1)=ZDEL(IGRP,IDEL,IDIL)
+      ENDIF
+   90 CONTINUE
+   95 CONTINUE
+*
+  100 DO 115 IPART=1,NPART
+      DO 110 INOR=1,MAXNOR
+      SIGP(INOR,IPART)=0.0
+  110 CONTINUE
+  115 CONTINUE
+      CALL LIBPTT(IGRP,MDIL,NPART-2,DILUT2,XSDIL,GOLD,HNAMIS,
+     1 IMPX,NOR,SIGP(1,1),SIGP(1,2),SIGP(1,3))
+*
+      DEALLOCATE(XSDIL)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(DILUT2,LDIL)
+      RETURN
+      END