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
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
|
*DECK SYBUP1
SUBROUTINE SYBUP1(ZZR,ZZI,NSURF,NREG,SIGT,TRONC,A,B,IMPX,VOL,PIJ,
1 PIS,PSS)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Compute the one-group collision, DP-1 leakage and DP-1 transmission
* probabilities in a Cartesian or hexagonal non-sectorized cell.
*
*Copyright:
* Copyright (C) 2008 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
* ZZR real tracking elements.
* ZZI integer tracking elements.
* NSURF number of surfaces (4 or 6).
* NREG number of regions.
* SIGT total macroscopic cross section.
* TRONC voided block criterion.
* A Cartesian dimension of the cell along the X axis or side of
* the hexagon.
* B Cartesian dimension of the cell along the Y axis.
* IMPX print flag.
*
*Parameters: output
* VOL volumes.
* PIJ cellwise reduced collision probability matrices.
* PIS cellwise reduced escape probability matrices.
* PSS cellwise reduced transmission probability matrices.
* PSS(i,j) is the probability from surface i to surface j.
*
*-----------------------------------------------------------------------
*
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER ZZI(*),NSURF,NREG,IMPX
REAL ZZR(*),SIGT(NREG),TRONC,A,B,VOL(NREG),PIJ(NREG,NREG),
1 PIS(NREG,3*NSURF),PSS(3*NSURF,3*NSURF)
*----
* LOCAL VARIABLES
*----
PARAMETER (SIGVID=1.0E-10,NCURR=3)
REAL SURF(6)
REAL, ALLOCATABLE, DIMENSION(:) :: G,PIJS
LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGFULL
*----
* INLINE FUNCTIONS
*----
INDPOS(I,J)=MAX(I,J)*(MAX(I,J)-1)/2+MIN(I,J)
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(G(NREG+6),LGFULL(NREG))
*----
* CHECK FOR VOIDED REGIONS
*----
DO 10 IR=1,NREG
VOL(IR)=ZZR(IR)
IF(VOL(IR).GT.0.) THEN
DR=SQRT(VOL(IR))
ELSE
DR=0.0
ENDIF
LGFULL(IR)=(SIGT(IR)*DR).GT.TRONC
IF(SIGT(IR).LE.SIGVID) SIGT(IR)=SIGVID
10 CONTINUE
*----
* COMPUTE SYMMETRIZED CP MATRIX
*----
IOFI=ZZI(1)
IOFR=ZZI(2)
ICARE=ZZI(3)
MNA=ZZI(4)
ALLOCATE(PIJS((NREG+NSURF)*(NREG+NSURF+1)/2))
CALL SYBUQV(ZZR(IOFR),ZZI(IOFI),NSURF,NREG,SIGT,MNA,LGFULL,PIJS)
*----
* APPLY SYMMETRIES
*----
IF(NSURF.EQ.4) THEN
SURF(1)=0.25*B
SURF(2)=0.25*B
SURF(3)=0.25*A
SURF(4)=0.25*A
ELSE
DO 20 JC=1,6
SURF(JC)=0.25*A
20 CONTINUE
ENDIF
DO 30 I=1,NSURF
G(I)=SURF(I)
30 CONTINUE
IF(ICARE.EQ.1) THEN
* RECTANGULAR CELL.
PIJS(2)=2.0*PIJS(2)
PIJS(5)=0.5*PIJS(5)
PIJS(9)=2.0*PIJS(9)
PIJS(4)=PIJS(5)
PIJS(7)=PIJS(5)
PIJS(8)=PIJS(5)
IOF=11
DO 50 I=1,NREG
G(4+I)=SIGT(I)*VOL(I)
SUM1=PIJS(IOF)+PIJS(IOF+1)
SUM2=PIJS(IOF+2)+PIJS(IOF+3)
PIJS(IOF)=SUM1
PIJS(IOF+1)=SUM1
PIJS(IOF+2)=SUM2
PIJS(IOF+3)=SUM2
DO 40 J=4,3+I
PIJS(IOF+J)=2.0*PIJS(IOF+J)
40 CONTINUE
IOF=IOF+4+I
50 CONTINUE
ELSE IF(ICARE.EQ.2) THEN
* SQUARE CELL.
PIJS(9)=2.0*PIJS(9)
PIJS(2)=PIJS(9)
PIJS(4)=PIJS(5)
PIJS(7)=PIJS(5)
PIJS(8)=PIJS(5)
IOF=11
DO 80 I=1,NREG
G(4+I)=SIGT(I)*VOL(I)
SUM=PIJS(IOF)+PIJS(IOF+1)+PIJS(IOF+2)+PIJS(IOF+3)
DO 60 J=0,3
PIJS(IOF+J)=SUM
60 CONTINUE
DO 70 J=4,3+I
PIJS(IOF+J)=4.0*PIJS(IOF+J)
70 CONTINUE
IOF=IOF+4+I
80 CONTINUE
ELSE IF(ICARE.EQ.3) THEN
* HEXAGONAL CELL.
PIJS(12)=2.0*PIJS(12)
PIJS(7)=PIJS(12)
PIJS(18)=PIJS(12)
PIJS(2)=PIJS(20)
PIJS(5)=PIJS(20)
PIJS(9)=PIJS(20)
PIJS(14)=PIJS(20)
PIJS(16)=PIJS(20)
PIJS(4)=PIJS(11)
PIJS(8)=PIJS(11)
PIJS(13)=PIJS(11)
PIJS(17)=PIJS(11)
PIJS(19)=PIJS(11)
IOF=22
DO 120 I=1,NREG
G(6+I)=SIGT(I)*VOL(I)
SUM=0.0
DO 90 J=0,5
SUM=SUM+PIJS(IOF+J)
90 CONTINUE
DO 100 J=0,5
PIJS(IOF+J)=SUM
100 CONTINUE
DO 110 J=6,5+I
PIJS(IOF+J)=6.0*PIJS(IOF+J)
110 CONTINUE
IOF=IOF+6+I
120 CONTINUE
ENDIF
*----
* FIRST APPLY THE ORTHONORMALIZATION FACTOR
*----
DO 130 I=1,(NSURF+NREG)*(NSURF+NREG+1)/2
PIJS(I)=PIJS(I)*ZZR(IOFR)*ZZR(IOFR)
130 CONTINUE
*----
* PERFORM A DP-1 PIS AND PSS CALCULATION USING THE TRACKING
*----
IF(NSURF.EQ.4) THEN
CALL SYBRN2(NREG,NSURF,A,B,ZZR(IOFR),ZZI(3),ZZR(1),SIGT,TRONC,
1 PIS,PSS)
ELSE IF(NSURF.EQ.6) THEN
CALL SYBHN2(NREG,NSURF,A,ZZR(IOFR),ZZI(3),ZZR(1),SIGT,TRONC,
1 PIS,PSS)
ENDIF
*----
* VILLARINO-STAMM'LER NORMALIZATION
*----
CALL SYBRHL(IMPX,NSURF,NREG,G,PIJS)
DO 160 IR=1,NREG
DO 150 IS=1,NSURF
ZNOR=G(IS)+G(NSURF+IR)
DO 140 IH=1,3
ISS=(IS-1)*3+IH
PIS(IR,ISS)=ZNOR*PIS(IR,ISS)
140 CONTINUE
150 CONTINUE
160 CONTINUE
DO 200 IS=1,NSURF
DO 190 JS=1,NSURF
ZNOR=G(IS)+G(JS)
DO 180 IH=1,3
ISS=(IS-1)*3+IH
DO 170 JH=1,3
JSS=(JS-1)*3+JH
PSS(ISS,JSS)=ZNOR*PSS(ISS,JSS)
170 CONTINUE
180 CONTINUE
190 CONTINUE
200 CONTINUE
*----
* LOAD THE EURYDICE CP ARRAY
*----
DO 220 I=1,NREG
DO 210 J=1,NREG
PIJ(I,J)=PIJS(INDPOS(NSURF+I,NSURF+J))/(VOL(I)*SIGT(I)*SIGT(J))
210 CONTINUE
220 CONTINUE
DEALLOCATE(PIJS)
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(LGFULL,G)
RETURN
END
|
