1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
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
|
