diff options
Diffstat (limited to 'Dragon/src/SHIDST.f')
| -rw-r--r-- | Dragon/src/SHIDST.f | 199 |
1 files changed, 199 insertions, 0 deletions
diff --git a/Dragon/src/SHIDST.f b/Dragon/src/SHIDST.f new file mode 100644 index 0000000..7dda8a2 --- /dev/null +++ b/Dragon/src/SHIDST.f @@ -0,0 +1,199 @@ +*DECK SHIDST + SUBROUTINE SHIDST (IPSYS,NPSYS,IPTRK,IFTRAK,CDOOR,IMPX,NBM,NREG, + 1 NUN,NGRO,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IRES,SIG0,SIG1,SIG2,TITR, + 2 FUNKNO,DILAV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of escape probability information. +* +*Copyright: +* Copyright (C) 2007 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. +* 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. only if leakage is present on the outer +* surface). +* IRES resonant mixture number assigned to each mixture. +* SIG0 total macroscopic cross sections of the resonant materials +* in each mixture. +* SIG1 total macroscopic cross sections of the light materials in +* each mixture. +* SIG2 transport correction in each mixture. +* TITR title. +* +*Parameters: output +* FUNKNO information used for computing escape information for the +* Nordheim method. +* DILAV average dilution. +* +*----------------------------------------------------------------------- +* + 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,NREG,NUN,NGRO,IPHASE, + 1 MAT(NREG),KEYFLX(NREG),IRES(NBM) + REAL VOL(NREG),SIG0(NBM,NGRO),SIG1(NBM,NGRO),SIG2(NBM,NGRO), + 1 FUNKNO(NUN,NGRO),DILAV(NGRO) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPSYS,KPSYS,IPMACR,IPSOU + DOUBLE PRECISION TOT1,TOT2 + LOGICAL LNORM,LEXAC,REBFLG + REAL, ALLOCATABLE, DIMENSION(:) :: SSIGT,SSIGW,SIGG + REAL, ALLOCATABLE, DIMENSION(:,:) :: SUN,FUN + INTEGER NALBP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SSIGT(0:NBM),SSIGW(0:NBM),SIGG(0:NBM)) +*---- +* INITIALIZATIONS. +*---- + NALBP=0 + ISTRM=1 + 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)=SIG0(IBM,LLL)+SIG1(IBM,LLL)-SIG2(IBM,LLL) + SSIGW(IBM)=-SIG2(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. +*---- + 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 +*---- +* ALLOCATE MEMORY. +*---- + ALLOCATE(SUN(NUN,NGRO),FUN(NUN,NGRO)) +*---- +* SOLVE FOR THE FLUX AND SET UP VECTORS DILAV AND FUNKNO. +*---- + SUN(:NUN,:NGRO)=0.0 + DO 40 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + SIGG(0:NBM)=0.0 + DO 30 IBM=1,NBM + IF(IRES(IBM).GT.0) SIGG(IBM)=SIG0(IBM,LLL) + 30 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,SIGG,SUN(1,LLL)) + ENDIF + 40 CONTINUE + CALL LCMLEN(IPSYS,'FLUX1',ILON1,ITYLCM) + IF(ILON1.EQ.NUN*NGRO) THEN + CALL LCMGET(IPSYS,'FLUX1',FUNKNO) + ELSE + FUNKNO(: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,FUNKNO(1,1),IPMACR, + 2 IPSOU,REBFLG) + CALL LCMPUT(IPSYS,'FLUX1',NUN*NGRO,2,FUNKNO) +* + SUN(:NUN,:NGRO)=0.0 + DO 60 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + SIGG(0:NBM)=0.0 + DO 50 IBM=1,NBM + IF(IRES(IBM).GT.0) SIGG(IBM)=1.0 + 50 CONTINUE + CALL DOORS(CDOOR,IPTRK,NBM,0,NUN,SIGG,SUN(1,LLL)) + ENDIF + 60 CONTINUE + CALL LCMLEN(IPSYS,'FLUX2',ILON2,ITYLCM) + IF(ILON2.EQ.NUN*NGRO) THEN + CALL LCMGET(IPSYS,'FLUX2',FUN) + ELSE + FUN(: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,FUN(1,1),IPMACR, + 2 IPSOU,REBFLG) + CALL LCMPUT(IPSYS,'FLUX2',NUN*NGRO,2,FUN) + DO 80 LLL=1,NGRO + IF(NPSYS(LLL).NE.0) THEN + TOT1=0.0D0 + TOT2=0.0D0 + DO 70 I=1,NREG + IBM=MAT(I) + IF(IBM.EQ.0) GO TO 70 + IF(IRES(IBM).GT.0) THEN + TOT2=TOT2+(1.0D0-FUNKNO(KEYFLX(I),LLL))*VOL(I) + TOT1=TOT1+FUN(KEYFLX(I),LLL)*VOL(I) + ENDIF + 70 CONTINUE + DILAV(LLL)=REAL(TOT2/TOT1) + ENDIF + 80 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SUN,FUN) + DEALLOCATE(SIGG,SSIGW,SSIGT) + RETURN + END |