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
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
|
*DECK CPOMAR
SUBROUTINE CPOMAR(IPEDIT,NGROUP,NMERGE,NL ,NIFISS,NEDMAC,
> HVECT ,IVECT ,NPROC ,ILEAKS,DXSMAC,DSCMAC,
> EMJMAC,DISFC ,IFCDIS,DISFAC )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Get macroscopic cross section from IPEDIT.
*
*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): G. Marleau
*
*Parameters: input
* IPEDIT pointer to the edit.
* NGROUP number of groups condensed.
* NMERGE number of regions merged.
* NL number of Legendre orders.
* NIFISS number of fissile isotopes.
* NEDMAC number of extra edit vectors.
* HVECT name of additional xs.
* IVECT location of additional xs.
* NPROC number of microscopic xs to process.
* ILEAKS leak calculation:
* = 0 no leakage;
* = 1 homogeneous leakage coefficients;
* = 2 directional leakage coefficients.
*
*Parameters: output
* DXSMAC averaged region/group x-s.
* DSCMAC scattering rates.
* DISFC disadvantage factor.
* EMJMAC energy per fission.
* IFCDIS discontinuity factor present (1) or absent.
* DISFAC discontinuity factors.
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPEDIT
INTEGER NGROUP,NMERGE,NL,NIFISS,NEDMAC,IVECT(NEDMAC),
> NPROC,ILEAKS
CHARACTER HVECT(NEDMAC)*8
REAL DISFC(NGROUP),
> EMJMAC(NMERGE)
DOUBLE PRECISION DXSMAC(NGROUP,NPROC,NMERGE),
> DSCMAC(NGROUP,NGROUP,NL,NMERGE)
INTEGER IFCDIS
DOUBLE PRECISION DISFAC(2,NGROUP,3)
*----
* LOCAL PARAMETERS
*----
TYPE(C_PTR) JPEDIT,KPEDIT
INTEGER NDPROC
PARAMETER (NDPROC=20)
INTEGER IGR,IED,IXSR,JXSR,KXSR,IMRG,IFIS,ILOCED,
> IL,IPOSIT,JGR1,JGR2,JGR,ILCMLN,ITYLCM
CHARACTER CM*2
INTEGER IDIR,IPL,IEL
REAL TEMP(6)
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ
REAL, ALLOCATABLE, DIMENSION(:) :: SCATC
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DNUFI
*----
* SCRATCH STORAGE ALLOCATION
* SCATC compress scattering data.
* IJJ position of first diffusion group.
* NJJ number of diffusion group.
* DNUFI fission source.
*----
ALLOCATE(IJJ(NMERGE),NJJ(NMERGE))
ALLOCATE(SCATC(NMERGE*NGROUP))
ALLOCATE(DNUFI(NMERGE,NIFISS+1))
*----
* INITIALIZE REACTION RATE VECTOR
*----
DXSMAC(:NGROUP,:NPROC,:NMERGE)=0.0D0
DSCMAC(:NGROUP,:NGROUP,:NL,:NMERGE)=0.0D0
DNUFI(:NMERGE,:NIFISS+1)=0.0D0
*----
* READ ALL CROSS SECTION FROM IPEDIT EXCEPT CHI
*----
CALL LCMLEN(IPEDIT,'FLUXDISAFACT',ILCMLN,ITYLCM)
IF(ILCMLN.EQ.NGROUP) THEN
CALL LCMGET(IPEDIT,'FLUXDISAFACT',DISFC)
ELSE
DISFC(:NGROUP)=0.0
ENDIF
JPEDIT=LCMGID(IPEDIT,'GROUP')
DO 100 IGR=1,NGROUP
KPEDIT=LCMGIL(JPEDIT,IGR)
IF(NEDMAC.GT.0) THEN
DO 110 IED=1,NEDMAC
IXSR=IVECT(IED)
IF(IXSR.GT.0) THEN
CALL LCMGET(KPEDIT,HVECT(IED),SCATC)
DO 111 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG))
111 CONTINUE
ENDIF
110 CONTINUE
ENDIF
IXSR=NDPROC+NL+1
CALL LCMLEN(KPEDIT,'OVERV',ILCMLN,ITYLCM)
IF(ILCMLN.EQ.NMERGE) THEN
CALL LCMGET(KPEDIT,'OVERV',SCATC)
DO 120 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG))
120 CONTINUE
ENDIF
IXSR=1
CALL LCMGET(KPEDIT,'NTOT0',SCATC)
DO 130 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG))
130 CONTINUE
IXSR=2
CALL LCMGET(KPEDIT,'TRANC',SCATC)
DO 170 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG))
170 CONTINUE
IF(IFCDIS .EQ. 1) THEN
CALL LCMLEN(KPEDIT,'ADFGENERAL',ILCMLN,ITYLCM)
IF(ILCMLN .EQ. 6) THEN
CALL LCMGET(KPEDIT,'ADFGENERAL',TEMP)
IEL=0
DO IDIR=1,3
DO IPL=1,2
IEL=IEL+1
DISFAC(IPL,IGR,IDIR)=DBLE(TEMP(IEL))
ENDDO
ENDDO
ELSE
IFCDIS=0
ENDIF
ENDIF
IXSR=16
CALL LCMGET(KPEDIT,'FLUX-INTG',SCATC)
DO 190 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DBLE(SCATC(IMRG))
190 CONTINUE
IF(NIFISS.GT.0) THEN
IXSR=3
JXSR=16
CALL LCMGET(KPEDIT,'NUSIGF',SCATC)
ILOCED=1
DO 150 IFIS=1,NIFISS
DO 151 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,IXSR,IMRG)
> +DBLE(SCATC(ILOCED))
DNUFI(IMRG,IFIS)=DNUFI(IMRG,IFIS)
> +DBLE(SCATC(ILOCED))*DXSMAC(IGR,JXSR,IMRG)
ILOCED=ILOCED+1
151 CONTINUE
150 CONTINUE
IXSR=4
CALL LCMGET(KPEDIT,'NFTOT',SCATC)
DO 153 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,IXSR,IMRG)
> +DBLE(SCATC(IMRG))
153 CONTINUE
ENDIF
IXSR=NDPROC
DO 200 IL=1,NL
IXSR=IXSR+1
WRITE (CM,'(I2.2)') IL-1
CALL LCMGET(KPEDIT,'SCAT'//CM,SCATC)
CALL LCMGET(KPEDIT,'NJJS'//CM,NJJ)
CALL LCMGET(KPEDIT,'IJJS'//CM,IJJ)
IPOSIT=0
DO 210 IMRG=1,NMERGE
JGR2=IJJ(IMRG)
JGR1=JGR2-NJJ(IMRG)+1
DO 211 JGR=JGR2,JGR1,-1
IPOSIT=IPOSIT+1
DSCMAC(IGR,JGR,IL,IMRG)=DBLE(SCATC(IPOSIT))
DXSMAC(JGR,IXSR,IMRG)=DXSMAC(JGR,IXSR,IMRG)
> +DSCMAC(IGR,JGR,IL,IMRG)
211 CONTINUE
210 CONTINUE
200 CONTINUE
IF(ILEAKS.EQ.1) THEN
IXSR=17
CALL LCMGET(KPEDIT,'DIFF',SCATC)
DO 180 IMRG=1,NMERGE
IF(SCATC(IMRG).GT.0.0) THEN
DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG)))
ENDIF
180 CONTINUE
ELSE IF(ILEAKS.EQ.2) THEN
IXSR=17
CALL LCMGET(KPEDIT,'DIFF',SCATC)
DO 181 IMRG=1,NMERGE
IF(SCATC(IMRG).GT.0.0) THEN
DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG)))
ENDIF
181 CONTINUE
IXSR=18
CALL LCMGET(KPEDIT,'DIFFX',SCATC)
DO 182 IMRG=1,NMERGE
IF(SCATC(IMRG).GT.0.0) THEN
DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG)))
ENDIF
182 CONTINUE
IXSR=19
CALL LCMGET(KPEDIT,'DIFFY',SCATC)
DO 183 IMRG=1,NMERGE
IF(SCATC(IMRG).GT.0.0) THEN
DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG)))
ENDIF
183 CONTINUE
IXSR=20
CALL LCMGET(KPEDIT,'DIFFZ',SCATC)
DO 184 IMRG=1,NMERGE
IF(SCATC(IMRG).GT.0.0) THEN
DXSMAC(IGR,IXSR,IMRG)=1.0D0/(3.0D0*DBLE(SCATC(IMRG)))
ENDIF
184 CONTINUE
ELSE
IXSR=17
JXSR=1
IF(NL.GE.2) THEN
KXSR=NDPROC+2
DO 185 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,JXSR,IMRG)
> -DXSMAC(IGR,KXSR,IMRG)
185 CONTINUE
ELSE
DO 186 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,JXSR,IMRG)
186 CONTINUE
ENDIF
ENDIF
100 CONTINUE
*----
* PROCESS CHI IF REQUIRED
*----
IF(NIFISS.GT.0) THEN
DO 160 IGR=1,NGROUP
KPEDIT=LCMGIL(JPEDIT,IGR)
IXSR=5
CALL LCMGET(KPEDIT,'CHI',SCATC)
ILOCED=1
DO 161 IFIS=1,NIFISS
DO 162 IMRG=1,NMERGE
DXSMAC(IGR,IXSR,IMRG)=DXSMAC(IGR,IXSR,IMRG)
> +DBLE(SCATC(ILOCED))*DNUFI(IMRG,IFIS)
ILOCED=ILOCED+1
162 CONTINUE
161 CONTINUE
160 CONTINUE
ENDIF
*----
* FIND TOTAL ENERGY PRODUCTION
*----
JXSR=16
EMJMAC(:NMERGE)=0.0
DO 251 IGR=1,NGROUP
KPEDIT=LCMGIL(JPEDIT,IGR)
CALL LCMLEN(KPEDIT,'H-FACTOR',ILCMLN,ITYLCM)
IF(ILCMLN.EQ.NMERGE) THEN
CALL LCMGET(KPEDIT,'H-FACTOR',SCATC)
DO 250 IMRG=1,NMERGE
EMJMAC(IMRG)=EMJMAC(IMRG)+REAL(DXSMAC(IGR,JXSR,IMRG))*
> SCATC(IMRG)*1.0E18
250 CONTINUE
ENDIF
251 CONTINUE
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(DNUFI)
DEALLOCATE(SCATC)
DEALLOCATE(NJJ,IJJ)
RETURN
END
|
