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
|
*DECK D2PRFL
SUBROUTINE D2PRFL( IPDAT, IPMIC , IPRINT, NBU, NGP, NBMIX,
> NANI, NVAR, STAIDX, LADF, NADF, NTYPE)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover macroscopic and microscopic cross sections from a microlib
* object and write cross sections for one branch at a fixed burnup point
* in the INFO data block.
* WARNING: 04/2014 The information recovered by this routine is exactly
* the same than GET_MACROLIB_XS but is used for reflector case, in this
* case the following reactions are set to zero :
* DET(IGR) = 0
* SFI(IGR) = 0
* KAPPA_FI(IGR)= 0
* FLUX(IGR) = 0
* VELINV(IGR) = 0
* CHI_SPEC(IGR) = 0
* X_NU_FI(IGR) = 0
* KAPPA_FI(IGR) = 0
* XENG(IGR)=0
* SMNG(IGR)=0
* NB : for reflector case, the upscattering is fixed to zero
*
*Author(s):
* J. Taforeau
*
*Parameters: input
* IPDAT address of info data block
* IPMIC address of the microlib object
* NBU number of burnup points
* NBMIX number of mixturess
* NGP number of energy groups
* NANI number of anisotropy
* NVAR number of state variables
* STAIDX table of states index order
* NADF number of ADF to be recovered
* NTYPE number of adf type
* LADF flag for adf
*
*Parameters:
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPDAT,IPMIC
INTEGER STAIDX(NVAR)
INTEGER NBU,NVAR,NBMIX,NGP,NANI,NADF,NTYPE
LOGICAL LADF
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) JPMIC,KPMIC,IPTH,KPTH
INTEGER NSCAT,MIX
INTEGER IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)
REAL GAR2(NGP,NGP,NBMIX,NANI),GAR3(NBMIX*NGP)
REAL XSECT(NGP,NBMIX) ! TOTAL CROSS SECTIONS
REAL KAPPA_FI(NGP) ! KAPPA FISSION CROSS SECTIONS
REAL X_NU_FI(NGP) ! NU SIGMA FISSION CROSS SECTIONS
REAL XTR(NGP) ! TRANSPORT CROSS SECTIONS
REAL DIFF(NGP,NBMIX) ! DIFFUSION COEFF
REAL SCAT(NGP,NBMIX) ! SCATTERING CROSS SECTIONS
REAL DET(NGP) ! DETECTOR CROSS SECTIONS
REAL SFI(NGP) ! FISSION CROSS SECTIONS
REAL ABSORPTION(NGP) ! ABSORPTION CROSS SECTIONS
REAL SCAT_MAT(NGP*NGP) ! SCATTERING MATRIX
REAL SCAT_TMP(NGP,NGP,NBMIX,NANI) ! TEMPORARY SCATTERING MATRIX
REAL FLUX(NGP)
REAL VELINV(NGP)
REAL XENG(NGP)
REAL CHI_SPEC(NGP),VOLUME(NBMIX)
REAL SMNG(NGP),FLXHET(NGP*NBMIX),FLXHOM(NGP,NBMIX)
REAL FLXL(NGP),FLXR(NGP),CURL(NGP),CURR(NGP)
REAL ADF(NADF,NGP)
CHARACTER CM*2,ADF_T*3
CHARACTER*8 ADFD(NADF),HADF(NTYPE),HFLX(2),HCUR(2)
IF(IPRINT > 0) THEN
WRITE(6,*)
WRITE(6,*) "****** RECOVER REFLECTOR CROSS SECTIONS ******"
ENDIF
CALL LCMSIX(IPDAT,' ',0)
CALL LCMSIX(IPDAT,'SAPHYB_INFO',1)
IF(LADF) THEN
ADF_T=" "
CALL LCMGTC(IPDAT,'ADF_TYPE',3,ADF_T)
IF ((ADF_T.NE.'DRA').AND.(ADF_T.NE.'GEN')) THEN
WRITE(6,*)'@D2PRFL:',ADF_T,'ADF NOT SUPPORTED ',
> 'WITH REFL CALCULATION'
CALL XABORT('')
ENDIF
IF ((ADF_T.EQ.'DRA')) THEN
CALL LCMGTC(IPDAT,'HADF',8,NADF,ADFD)
ELSE IF ((ADF_T.EQ.'GEN')) THEN
CALL LCMGTC(IPDAT,'HFLX',8,2,HFLX)
CALL LCMGTC(IPDAT,'HCUR',8,2,HCUR)
ENDIF
ENDIF
CALL LCMGET(IPDAT,'MIX',MIX)
CALL LCMSIX(IPDAT,' ',0)
CALL LCMSIX(IPMIC,' ',0)
CALL LCMSIX(IPMIC,'MACROLIB',1)
CALL LCMGET(IPMIC,'VOLUME',VOLUME)
IF (LADF) THEN
CALL LCMSIX(IPMIC,'ADF',1)
CALL LCMGTC(IPMIC,'HADF',8,NTYPE,HADF)
ITYPE=1
IF ((ADF_T.EQ.'DRA')) THEN
DO ITYPE=1,NTYPE
CALL LCMGET(IPMIC,HADF(ITYPE),FLXHET)
DO I=1,NADF
IF(HADF(ITYPE).EQ.ADFD(I))THEN
DO IGR=1, NGP
ADF(I,IGR)= FLXHET((IGR-1)*NBMIX+MIX)
ENDDO
ENDIF
ENDDO
ENDDO
ELSE IF ((ADF_T.EQ.'GEN')) THEN
DO ITYPE=1,NTYPE
CALL LCMGET(IPMIC,HADF(ITYPE),FLXHET)
IF(HADF(ITYPE).EQ.HFLX(1))THEN
FLXL(:)=FLXHET
ENDIF
IF (HADF(ITYPE).EQ.HFLX(2))THEN
FLXR(:)=FLXHET
ENDIF
IF (HADF(ITYPE).EQ.HCUR(1))THEN
CURL(:)=FLXHET
ENDIF
IF (HADF(ITYPE).EQ.HCUR(2))THEN
CURR(:)=FLXHET
ENDIF
ENDDO
ENDIF
CALL LCMSIX(IPMIC,'',2)
ENDIF
JPMIC=LCMGID(IPMIC,'GROUP')
! RECOVER CROSS SECTIONS INFORMATION
DO IGR=1,NGP
WRITE(6,'(/28H PROCESS ENERGY GROUP NUMBER,I4)') IGR
KPMIC=LCMGIL(JPMIC,IGR)
CALL LCMLEN(KPMIC,'NTOT0',ILONG,ITYLCM)
IF(ILONG.NE.NBMIX) THEN
CALL XABORT('D2P: MORE THAN ONE MIXTURE IN SAPHYB')
ENDIF
CALL LCMGET(KPMIC,'FLUX-INTG',FLXHOM(IGR,1:NBMIX))
CALL LCMGET(KPMIC,'NTOT0',XSECT(IGR,1:NBMIX))
CALL LCMGET(KPMIC,'SIGS00',SCAT(IGR,1:NBMIX))
CALL LCMGET(KPMIC,'DIFF',DIFF(IGR,1:NBMIX))
ABSORPTION(IGR)=XSECT(IGR,MIX)-SCAT(IGR,MIX)
IF (LADF) ADF(:,IGR)= VOLUME * ADF(:,IGR) / FLXHOM(IGR,MIX)
DET(IGR) = 0
SFI(IGR) = 0
KAPPA_FI(IGR)= 0
FLUX(IGR) = 0
VELINV(IGR) = 0
CHI_SPEC(IGR) = 0
X_NU_FI(IGR) = 0
KAPPA_FI(IGR) = 0
XENG(IGR)=0
SMNG(IGR)=0
XTR(IGR)=1/(3*DIFF(IGR,MIX))
GAR2(:NGP,:NGP,:NBMIX,:NANI)=0.0
DO IL=1,NANI
WRITE(CM,'(I2.2)') IL-1
LENGTH=1
IF(IL.GT.1) CALL LCMLEN(KPMIC,'SCAT'//CM,LENGTH,ITYLCM)
IF(LENGTH.GT.0) THEN
CALL LCMGET(KPMIC,'SCAT'//CM,GAR3)
CALL LCMGET(KPMIC,'NJJS'//CM,NJJ)
CALL LCMGET(KPMIC,'IJJS'//CM,IJJ)
CALL LCMGET(KPMIC,'IPOS'//CM,IPOS)
DO IMIL=1,NBMIX
IPOSDE=IPOS(IMIL)
DO JGR=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1
GAR2(IGR,JGR,IMIL,IL)=GAR3(IPOSDE) ! IGR <-- JGR
SCAT_TMP(IGR,JGR,IMIL,IL)=GAR2(IGR,JGR,IMIL,IL)
IPOSDE=IPOSDE+1
ENDDO
ENDDO
ENDIF
ENDDO
ENDDO
NSCAT=1
DO J=1, NGP
DO I=1, NGP
SCAT_MAT(NSCAT)=SCAT_TMP(I,J,MIX,1) ! I <-- J
IF(NSCAT==3) SCAT_MAT(NSCAT)=0
NSCAT=NSCAT+1
ENDDO
ENDDO
CALL LCMSIX(IPDAT,' ',0)
CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
IF(STAIDX(NVAR)==1) THEN
IPTH=LCMLID(IPDAT,'CROSS_SECT',NBU)
ELSE
IPTH=LCMGID(IPDAT,'CROSS_SECT')
ENDIF
KPTH=LCMDIL(IPTH,STAIDX(NVAR))
CALL LCMSIX(KPTH,'MICROLIB_XS',1)
CALL LCMPUT(KPTH,'XENG',NGP,2,XENG)
CALL LCMPUT(KPTH,'SMNG',NGP,2,SMNG)
CALL LCMSIX(KPTH,' ',2)
CALL LCMSIX(KPTH,'MACROLIB_XS',1)
CALL LCMPUT(KPTH,'XTR',NGP,2,XTR)
CALL LCMPUT(KPTH,'ABSORPTION',NGP,2,ABSORPTION)
CALL LCMPUT(KPTH,'X_NU_FI',NGP,2,X_NU_FI)
CALL LCMPUT(KPTH,'KAPPA_FI',NGP,2,KAPPA_FI)
CALL LCMPUT(KPTH,'SFI',NGP,2,SFI)
CALL LCMPUT(KPTH,'DET',NGP,2,DET)
CALL LCMPUT(KPTH,'SCAT',NGP*NGP,2,SCAT_MAT)
IF (LADF) THEN
IF (ADF_T.EQ.'DRA') THEN
CALL LCMPUT(KPTH,'ADF',NADF*NGP,2,ADF)
ELSE IF (ADF_T.EQ.'GEN') THEN
CALL LCMPUT(KPTH,'FLXL',NGP,2,FLXL)
CALL LCMPUT(KPTH,'FLXR',NGP,2,FLXR)
CALL LCMPUT(KPTH,'CURL',NGP,2,CURL)
CALL LCMPUT(KPTH,'CURR',NGP,2,CURR)
ENDIF
ENDIF
IF(IPRINT>1) THEN
WRITE(6,*)
WRITE(6,*) "**** MACROSCOPIC cross sections (1:NGP) ****"
WRITE(6,*) "TOTALE :",XSECT(:,MIX)
WRITE(6,*) "DIFFUSION :",DIFF(:,MIX)
WRITE(6,*) "TRANSPORT :",XTR
WRITE(6,*) "ABSORPTION :",ABSORPTION
WRITE(6,*) "NU FISSION :",X_NU_FI
WRITE(6,*) "KAPPA FISSION :",KAPPA_FI
WRITE(6,*) "DETECTOR :",DET
WRITE(6,*) "SCATTERING (g to g') :",SCAT_MAT
IF (LADF) THEN
IF (ADF_T.EQ.'DRA') THEN
WRITE(6,*) "ADF([N/E/W/S]||[W/E]) :",ADF
ELSE IF (ADF_T.EQ.'GEN') THEN
WRITE(6,*) "WEST FLUX BOUNDARY :",FLXL
WRITE(6,*) "EST FLUX BOUNDARY :",FLXR
WRITE(6,*) "WEST CURRENT BOUNDARY :",CURL
WRITE(6,*) "EST CURRENT BOUNDARY :",CURR
ENDIF
ENDIF
ENDIF
END
|
