From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/TONDST.f | 205 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 205 insertions(+) create mode 100644 Dragon/src/TONDST.f (limited to 'Dragon/src/TONDST.f') 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 -- cgit v1.2.3