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
|
*DECK CPOMIC
SUBROUTINE CPOMIC(IPCPO ,IPEDIT,IPRINT,NGROUP,NMERGE,NBMICR,
> NL ,IMRG ,ISOR ,NPROC ,ISOTMP,IDIMIX,
> INDPRO,ITYPRO,DENCPO,DENTMP,DXSMIC,DSCMIC,
> DMJCPO,DFLUX )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Compute microscopic cross sections for the Compo file.
*
*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
* IPCPO pointer to the compo (L_COMPO signature).
* IPEDIT pointer to edit information (L_EDIT signature).
* IPRINT print parameter. Equal to zero for no print.
* NGROUP number of groups condensed .
* NMERGE number of regions merged.
* NBMICR maximum number of isotopes.
* NL number of Legendre orders.
* IMRG merge region indices.
* ISOR Compo isotope number.
* NPROC number of isotopes.
* ISOTMP name of isotopes in EDIT.
* IDIMIX isotopes identifier in each Compo material.
* INDPRO identifier for xs processing.
* ITYPRO identifier for xs processed.
* DENCPO Compo isotopes concentration.
* DENTMP Dragon isotopes concentration.
*
*Parameters: input/output
* DXSMIC micro vector xs.
* DSCMIC micro scat matrix xs.
* DFLUX flux.
* DMJCPO fission energy for macro.
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPCPO,IPEDIT
INTEGER IPRINT,NGROUP,NMERGE,NBMICR,NL,IMRG,ISOR,NPROC,
> ISOTMP(3,NBMICR),IDIMIX(NMERGE,NBMICR),
> INDPRO(NPROC),ITYPRO(NPROC)
REAL DENTMP(NBMICR)
DOUBLE PRECISION DENCPO(NBMICR),DXSMIC(NGROUP,NPROC),
> DSCMIC(NGROUP,NGROUP,NL),DMJCPO(2,NBMICR),
> DFLUX(NGROUP)
*----
* ALLOCATABLE ARRAYS
*----
REAL, ALLOCATABLE, DIMENSION(:) :: HFACT
REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT
TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
*----
* LOCAL PARAMETERS
*----
INTEGER IOUT,NDPROC,IORD
PARAMETER (IOUT=6,NDPROC=20)
TYPE(C_PTR) KPEDIT
INTEGER NBISOE,ISOE,IADDXS,ITC,IXSR,JXSR,KXSR,IL,
> IGR,JGR,ILCMLN,ITYLCM
CHARACTER NAMISO*12
DOUBLE PRECISION DSCPO,DNUFI,FACDEN,FACAXS
*----
* SCRATCH STORAGE ALLOCATION
* XSREC fission energy for macro.
* XSCAT compress scattering.
*----
ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL),
> IPISO(NBMICR))
*----
* FIND ISOTOPE POINTERS IN INPUT MICROLIB
*----
CALL LIBIPS(IPEDIT,NBMICR,IPISO)
*----
* COMPUTE FINAL DENSITY OF ISOTOPE ISOR IN MIXTURE IMRG
*----
NBISOE=0
DO 100 ISOE=1,NBMICR
IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN
NBISOE=NBISOE+1
DENCPO(ISOR)=DENCPO(ISOR)+DENTMP(ISOE)
ENDIF
100 CONTINUE
IF(DENCPO(ISOR).EQ.0.0D0) THEN
FACDEN=1.0D0/DBLE(NBISOE)
IADDXS=0
ELSE
FACDEN=1.0D0/DENCPO(ISOR)
IADDXS=1
ENDIF
*----
* SCAN ALL ISOTOPES FOR THIS MERGE REGION AND
* LOCATE ADD XS FOR THOSE ASSOCIATED WITH ISOR
*----
DSCPO=0.0D0
DO 110 ISOE=1,NBMICR
IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN
IF(IADDXS.EQ.0) THEN
FACAXS=FACDEN
ELSE
FACAXS=FACDEN*DBLE(DENTMP(ISOE))
ENDIF
*----
* READ MICRO XS
*----
WRITE(NAMISO,'(3A4)') (ISOTMP(ITC,ISOE),ITC=1,3)
IF(IPRINT.GE.10) WRITE(IOUT,6000) NAMISO
KPEDIT=IPISO(ISOE) ! set ISOE-th isotope
IORD=1
CALL XDRLGS(KPEDIT,-1,IPRINT,0,NL-1,IORD,NGROUP,
> XSREC(1,NDPROC+1),XSCAT,ITYPRO(NDPROC+1))
CALL CPOLGX(KPEDIT,-1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),
> ITYPRO)
*----
* ADD MICRO XS TO CPO ISOTOPE
*----
DO 120 IXSR=1,4
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 121 IGR=1,NGROUP
DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
> +FACAXS*DBLE(XSREC(IGR,IXSR))
121 CONTINUE
ENDIF
120 CONTINUE
IXSR=4
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
*----
* COMPUTE TOTAL NEUTRON PRODUCED AND TOTAL ENERGY GENERATED
*----
CALL LCMLEN(KPEDIT,'H-FACTOR',ILCMLN,ITYLCM)
IF(ILCMLN.EQ.NGROUP) THEN
ALLOCATE(HFACT(NGROUP))
CALL LCMGET(KPEDIT,'H-FACTOR',HFACT)
DO 122 IGR=1,NGROUP
DMJCPO(1,ISOR)=DMJCPO(1,ISOR)+DENTMP(ISOE)
> *DFLUX(IGR)*DBLE(HFACT(IGR))*1.0E18
DMJCPO(2,ISOR)=DMJCPO(2,ISOR)+DENTMP(ISOE)
> *DFLUX(IGR)*DBLE(XSREC(IGR,IXSR))
122 CONTINUE
DEALLOCATE(HFACT)
ENDIF
ENDIF
IXSR=5
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
JXSR=3
DNUFI=0.0D0
DO 130 IGR=1,NGROUP
DNUFI=DNUFI+DFLUX(IGR)*DBLE(XSREC(IGR,JXSR))
130 CONTINUE
DNUFI=DNUFI*FACAXS
DSCPO=DSCPO+DNUFI
DO 140 IGR=1,NGROUP
DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
> +DNUFI*DBLE(XSREC(IGR,IXSR))
140 CONTINUE
ENDIF
DO 150 IXSR=7,NDPROC
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 151 IGR=1,NGROUP
DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
> +FACAXS*DBLE(XSREC(IGR,IXSR))
151 CONTINUE
ENDIF
150 CONTINUE
IL=0
DO 160 IXSR=NDPROC+1,NDPROC+NL
IL=IL+1
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 170 IGR=1,NGROUP
DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR)
> +FACAXS*DBLE(XSREC(IGR,IXSR))
DO 171 JGR=1,NGROUP
DSCMIC(IGR,JGR,IL)=DSCMIC(IGR,JGR,IL)
> +FACAXS*DBLE(XSCAT(IGR,JGR,IL))
171 CONTINUE
170 CONTINUE
ENDIF
160 CONTINUE
ENDIF
110 CONTINUE
*----
* SAVE AVERAGE XS
*----
XSREC(:NGROUP,:NPROC)=0.0
XSCAT(:NGROUP,:NGROUP,:NL)=0.0
DO 180 IXSR=1,4
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 181 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR))
181 CONTINUE
ENDIF
180 CONTINUE
IXSR=5
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
IF(DSCPO.NE.0.0D0) THEN
DO 190 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)/DSCPO)
190 CONTINUE
ENDIF
ENDIF
IXSR=6
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
JXSR=4
KXSR=3
DO 191 IGR=1,NGROUP
IF(DXSMIC(IGR,JXSR).GT.0.0) THEN
XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,KXSR)/DXSMIC(IGR,JXSR))
ENDIF
191 CONTINUE
ENDIF
DO 200 IXSR=7,NDPROC
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 201 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR))
201 CONTINUE
ENDIF
200 CONTINUE
IL=0
DO 210 IXSR=NDPROC+1,NDPROC+NL
IL=IL+1
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 220 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR))
DO 221 JGR=1,NGROUP
XSCAT(IGR,JGR,IL)=REAL(DSCMIC(IGR,JGR,IL))
221 CONTINUE
220 CONTINUE
ENDIF
210 CONTINUE
*----
* SAVE CPO MICRO
*----
IORD=1
CALL XDRLGS(IPCPO,1,IPRINT,0,NL-1,IORD,NGROUP,XSREC(1,NDPROC+1),
> XSCAT,ITYPRO(NDPROC+1))
CALL CPOLGX(IPCPO,1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),ITYPRO)
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(IPISO,XSCAT,XSREC)
RETURN
*----
* PRINT FORMAT
*----
6000 FORMAT(' CPOMIC: INCLUDE ISOTOPE = ',A12)
END
|
