Initial commit from Polytechnique Montreal

1 files changed, 205 insertions, 0 deletions

diff --git a/Dragon/src/TONDST.f b/Dragon/src/TONDST.f
new file mode 100644
index 0000000..4b75bda
--- /dev/null
+++ b/Dragon/src/TONDST.f
@@ -0,0 +1,205 @@
+*DECK TONDST
+      SUBROUTINE TONDST (IPSYS,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NBNRS,
+     1 NREG,NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,DENM,SIGT0,SIGT2,
+     2 SIGT3,TITR,DILAV,TK3,TK4)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Calculation of escape probability information.
+*
+*Copyright:
+* Copyright (C) 2017 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
+* IPSYS   pointer to the pij (L_PIJ signature).
+* NPSYS   index array pointing to the IPSYS list component corresponding
+*         to each energy group. Set to zero if a group is not to be
+*         processed. Usually, NPSYS(I)=I.
+* IPTRK   pointer to the tracking. (L_TRACK signature).
+* IFTRAK  unit number of the sequential binary tracking file.
+* CDOOR   name of the geometry/solution module.
+* IMPX    print flag (equal to zero for no print).
+* NBM     number of mixtures.
+* NBNRS   number of totaly correlated resonant regions.
+* NREG    total number of merged blocks for which specific values
+*         of the neutron flux and reactions rates are required.
+* NUN     number of unknowns in the flux or source vector in one
+*         energy group.
+* NGRO    number of energy groups.
+* IPHASE  type of flux solution (=1 use a native flux solution door;
+*         =2 use collision probabilities).
+* MAT     index-number of the mixture type assigned to each volume.
+* VOL     volumes.
+* KEYFLX  pointers of fluxes in unknown vector.
+* LEAKSW  leakage flag (=.TRUE. if leakage is present on the outer
+*         surface).
+* IRES    resonant mixture number assigned to each mixture.
+* DENM    number density of the resonant isotope in each mixture.
+* SIGT0   total macroscopic cross sections of the resonant isotope
+*         in each mixture.
+* SIGT2   total macroscopic cross sections of the light materials in
+*         each mixture.
+* SIGT3   transport correction in each mixture.
+* TITR    title.
+*
+*Parameters: output
+* DILAV   average dilution.
+*
+*Parameters: input/output
+* TK3     cpu time to compute system matrices.
+* TK4     cpu time to compute fluxes.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE DOORS_MOD
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPSYS,IPTRK
+      CHARACTER CDOOR*12,TITR*72
+      LOGICAL LEAKSW
+      INTEGER NPSYS(NGRO),IFTRAK,IMPX,NBM,NBNRS,NREG,NUN,NGRO,IPHASE,
+     1 MAT(NREG),KEYFLX(NREG),IRES(NBM)
+      REAL VOL(NREG),DENM(0:NBM),SIGT0(0:NBM,NGRO),SIGT2(0:NBM,NGRO),
+     1 SIGT3(0:NBM,NGRO),DILAV(NBNRS,NGRO),TK3,TK4
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPSYS,KPSYS,IPMACR,IPSOU
+      LOGICAL LNORM,LEXAC,REBFLG
+      REAL, ALLOCATABLE, DIMENSION(:) :: SSIGT,SSIGW
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SUN,FUN1,FUN2
+      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: TOT1,TOT2
+      INTEGER NALBP
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(SSIGT(0:NBM),SSIGW(0:NBM))
+*----
+*  INITIALIZATIONS.
+*----
+      NALBP=0
+      NANI=1
+      NW=0
+      IPIJK=1
+      ITPIJ=1
+      KNORM=1
+      LNORM=.FALSE.
+      IDIR=0
+      LEXAC=.FALSE.
+      JPSYS=LCMLID(IPSYS,'GROUP',NGRO)
+*----
+*  SELECT THE MACROSCOPIC CROSS SECTIONS.
+*----
+      SSIGT(0)=0.0
+      SSIGW(0)=0.0
+      DO 20 LLL=1,NGRO
+      IF(NPSYS(LLL).NE.0) THEN
+         DO 10 IBM=1,NBM
+         SSIGT(IBM)=SIGT0(IBM,LLL)+SIGT2(IBM,LLL)-SIGT3(IBM,LLL)
+         SSIGW(IBM)=-SIGT3(IBM,LLL)
+   10    CONTINUE
+         KPSYS=LCMDIL(JPSYS,LLL)
+         CALL LCMPUT(KPSYS,'DRAGON-TXSC',NBM+1,2,SSIGT(0))
+         CALL LCMPUT(KPSYS,'DRAGON-S0XSC',NBM+1,2,SSIGW(0))
+      ENDIF
+   20 CONTINUE
+*----
+*  ASSEMBLY MATRIX OR REDUCED COLLISION PROBABILITIES CALCULATION.
+*----
+      CALL KDRCPU(TKA)
+      ISTRM=1
+      IF(IPHASE.EQ.1) THEN
+*        USE A NATIVE DOOR.
+         CALL DOORAV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NREG,
+     1   NBM,NANI,NW,MAT,VOL,KNORM,LEAKSW,TITR,NALBP,ISTRM)
+      ELSE IF(IPHASE.EQ.2) THEN
+*        USE A COLLISION PROBABILITY DOOR.
+         CALL DOORPV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NREG,
+     1   NBM,NANI,MAT,VOL,KNORM,IPIJK,LEAKSW,ITPIJ,LNORM,TITR,NALBP)
+      ENDIF
+      CALL KDRCPU(TKB)
+      TK3=TK3+(TKB-TKA)
+*----
+*  ALLOCATE MEMORY.
+*----
+      ALLOCATE(SUN(NUN,NGRO),FUN1(NUN,NGRO),FUN2(NUN,NGRO))
+*----
+*  SOLVE FOR THE FLUX AND SET UP VECTOR DILAV.
+*----
+      CALL KDRCPU(TKA)
+      SUN(:NUN,:NGRO)=0.0
+      DO 30 LLL=1,NGRO
+      IF(NPSYS(LLL).NE.0) THEN
+         CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,SIGT2(0,LLL),SUN(1,LLL))
+      ENDIF
+   30 CONTINUE
+      CALL LCMLEN(IPSYS,'FLUX1',ILON1,ITYLCM)
+      IF(ILON1.EQ.NUN*NGRO) THEN
+         CALL LCMGET(IPSYS,'FLUX1',FUN1)
+      ELSE
+         FUN1(:NUN,:NGRO)=0.0
+      ENDIF
+      IPMACR=C_NULL_PTR
+      IPSOU=C_NULL_PTR
+      REBFLG=.FALSE.
+      CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NBM,IDIR,
+     1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN1,IPMACR,
+     2 IPSOU,REBFLG)
+      CALL LCMPUT(IPSYS,'FLUX1',NUN*NGRO,2,FUN1)
+*
+      SUN(:NUN,:NGRO)=0.0
+      DO 40 LLL=1,NGRO
+      IF(NPSYS(LLL).NE.0) THEN
+         CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,DENM,SUN(1,LLL))
+      ENDIF
+   40 CONTINUE
+      CALL LCMLEN(IPSYS,'FLUX2',ILON2,ITYLCM)
+      IF(ILON2.EQ.NUN*NGRO) THEN
+         CALL LCMGET(IPSYS,'FLUX2',FUN2)
+      ELSE 
+         FUN2(:NUN,:NGRO)=0.0
+      ENDIF
+      IPMACR=C_NULL_PTR
+      REBFLG=.FALSE.
+      CALL DOORFV(CDOOR,JPSYS,NPSYS,IPTRK,IFTRAK,IMPX,NGRO,NBM,IDIR,
+     1 NREG,NUN,IPHASE,LEXAC,MAT,VOL,KEYFLX,TITR,SUN,FUN2,IPMACR,
+     2 IPSOU,REBFLG)
+      CALL LCMPUT(IPSYS,'FLUX2',NUN*NGRO,2,FUN2)
+      ALLOCATE(TOT2(NBNRS),TOT1(NBNRS))
+      DO 70 LLL=1,NGRO
+      IF(NPSYS(LLL).NE.0) THEN
+         TOT2(:)=0.0D0
+         TOT1(:)=0.0D0
+         DO 50 I=1,NREG
+         IBM=MAT(I)
+         IF(IBM.EQ.0) GO TO 50
+         IRS=IRES(IBM)
+         IF(IRS.GT.0) THEN
+            TOT1(IRS)=TOT1(IRS)+FUN1(KEYFLX(I),LLL)*VOL(I)
+            TOT2(IRS)=TOT2(IRS)+FUN2(KEYFLX(I),LLL)*VOL(I)
+         ENDIF
+   50    CONTINUE
+         DO 60 IRS=1,NBNRS
+         DILAV(IRS,LLL)=REAL(TOT1(IRS)/TOT2(IRS))
+   60    CONTINUE
+      ENDIF
+   70 CONTINUE
+      DEALLOCATE(TOT2,TOT1)
+      CALL KDRCPU(TKB)
+      TK4=TK4+(TKB-TKA)
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(SUN,FUN2,FUN1)
+      DEALLOCATE(SSIGW,SSIGT)
+      RETURN
+      END