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
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
|
*DECK D2PXSA
SUBROUTINE D2PXSA(IPDAT,IPSAP,ICAL,IPRINT,NGP,NREA,NISO,NMAC,
1 NMIL,NANI,NVAR,NADRX,STAIDX,B2,ADF_T,NSF,LABS,SCAT,LADF)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover FISSION cross sections of an elementary calculation and store
* in INFO/BRANCH_INFO/MACROLIB_XS/SFI.
* WARNING: the GET_SFI_XS subroutine cannot recover FISSION XS in the
* case where cross sections are ineterpolated by the SCR: module
*
*Author(s):
* J. Taforeau
*
*Parameters: input
* IPDAT address of the INFO data block
* ICAL number of the elementary calculation in which fission cross
* sections is to be recovered
* IPSAP address of the Saphyb object
* NGP number of group energies in Saphyb
* NREA number of reactions in Saphyb
* NISO number of isotopes in Saphyb
* NMAC number of macros in Saphyb
* NMIL number of mixtures in Saphyb
* NANI number of Legendre orders in Saphyb
* NADRX concerne cross section vector (ADRX)
* STAIDX index of current branch state values
* NSF number of elements of the tranfert matrix
* LABS content of absorption xs LABS(1) : ABS XS = TOTAL - SIGS00 ;
* LABS(2) abs xs recovered from sap ; LABS (3) abs xs recovered
* from SAP minus excess xs
*Parameters: output
* SFI fission cross sections of the current BRANCH:
* INFO/BRANCH_INFO/MACROLIB_XS/SFI
*
*Parameters:
* IPRINT
* NVAR
* B2
* ADF_T
* SCAT
* LADF
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPDAT,IPSAP
INTEGER ICAL,IPRINT,NGP,NREA,NISO,NMAC, NMIL,NANI,NVAR,
1 STAIDX(NVAR),NSF,NADRX
REAL B2
CHARACTER*3 ADF_T
LOGICAL LABS(3),SCAT,LADF
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) IPTH,KPTH
! order numbers of current : reaction , isotope, macro
INTEGER iprf,isot,imil,imac,iabs,iexc,idif,itra
INTEGER idifc
INTEGER ani, il, nj, ii, it, i1,i2, j1, j2, iadc,g
INTEGER ND
! location of excess cross sections in RDATAX
INTEGER ADR_EXC
! location of absorption cross sections in RDATAX
INTEGER ADR_ABS
! location of profil cross sections in RDATAX
INTEGER ADR_PRF
! location of TRANSFERT cross sections in RDATAX
INTEGER ADR_TRA
INTEGER ADR_DIF
! number of group energies in Saphyb
INTEGER NG
! type of data recovered from GANLIB subroutines
INTEGER ITYLCM
! name of : isotopes, macros
CHARACTER(LEN=8) NOM_MAC(NMAC)
! name of reactions
CHARACTER(LEN=10) NOM_REA(NREA)
! residual macro
INTEGER RESMAC(NMIL)
! 3rd index of ADRX
INTEGER ISADRX(NMIL)
! number of elements in RADATAX
INTEGER LENGDX(NMIL)
! name of total macro
INTEGER TOTMAC(NMIL)
! number of elements in IDATAP
INTEGER LENGDP(NMIL)
! contains the adress of the 1st element in RDATAX
INTEGER ADRX (NREA+2,NISO+NMAC,NADRX)
REAL ABSORPTION(NGP)
REAL TRANSFERT (NANI,NGP*NGP)
REAL DIFC(NGP)
CHARACTER(LEN=12) CALDIR
INTEGER fagg, lagg,fdgg,wgal,fag,lag ! CF SAPHTOOL MANUAL
INTEGER fdg(NGP),adr(NGP+1) ! CF SAPHTOOL MANUAL
INTEGER NSCAT
REAL CURRN(NSF,NGP,2)
REAL SRFLX(NSF,NGP)
REAL ZAFLX(NMIL,NGP)
DOUBLE PRECISION RPAR (6,NSF)
INTEGER IPAR (3,NSF)
REAL ADF(NGP,NSF,10)
REAL SCAT_MAT(NGP*NGP)
! transfert matrix
INTEGER ,ALLOCATABLE, DIMENSION(:) :: IDATAP
! contains values of cross sections of an elementary calculation
REAL,ALLOCATABLE, DIMENSION(:) :: RDATAX
TRANSFERT(:,:) = 0
WRITE(CALDIR,'("calc", I8)') ICAL
CALL LCMSIX(IPSAP,' ',0)
CALL LCMSIX(IPSAP,'contenu',1)
IF(NMIL.NE.1) THEN
! the number of mixtures must be equal to one for converting
! Saphyb into PMAXS format
CALL XABORT('@D2P: MORE THAN ONE MIXTRURE IN SAPHYB')
ENDIF
CALL LCMGTC(IPSAP,'NOMREA',10,NREA,NOM_REA)
CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,NOM_MAC)
CALL LCMGET(IPSAP,'RESMAC',RESMAC)
CALL LCMGET(IPSAP,'TOTMAC',TOTMAC)
CALL LCMSIX(IPSAP,' ',0)
CALL LCMSIX(IPSAP,'adresses',1)
CALL LCMGET(IPSAP,'ADRX',ADRX)
CALL LCMSIX(IPSAP,' ',0)
CALL LCMSIX(IPSAP,CALDIR,1)
CALL LCMSIX(IPSAP,'info',1)
CALL LCMGET(IPSAP,'ISADRX',ISADRX)
CALL LCMGET(IPSAP,'LENGDX',LENGDX)
CALL LCMGET(IPSAP,'LENGDP',LENGDP)
ALLOCATE (RDATAX(LENGDX(1)),IDATAP(LENGDP(1)))
imac=0
IF(RESMAC(1).NE.0) THEN
imac=RESMAC(1) ! recover name of residual macro
ELSE IF(TOTMAC(1).NE.0) THEN
imac=TOTMAC(1) ! recover name of total macro
ELSE
CALL XABORT('@D2P: NO MACRO DEFINED')
ENDIF
isot=NISO+imac ! we interest in macro fission cross sections
imil=1 ! set the mixtures number to 1
iprf=0
iexc=0
iabs=0
idif=0
iadc=0
itra=0
idifc=0
!TEST HFATC
NSCAT=1
DO ir=1,NREA
! store the order numbers of PROFIL matrix
IF((SCAT) .and. NOM_REA(ir)=="PROFIL") iprf=ir
IF((SCAT) .and. NOM_REA(ir)=="DIFFUSION") idif=ir
IF((SCAT) .and. NOM_REA(ir)=="TRANSFERT") itra=ir
IF(NOM_REA(ir)=="NU*FISSION") iabs=ir
! store the order numbers of EXCESS matrix
IF(LABS(3).and. NOM_REA(ir)=="EXCESS") iexc=ir
IF((LADF) .and. NOM_REA(ir)=="FUITES") idifc=ir
ENDDO
IF(iabs==0) CALL XABORT ('@D2P: NO ABSORPTION XS AVAILABLE')
IF(LABS(3).and.iexc==0) THEN
CALL XABORT('@D2P: NO EXCESS XS AVAILABLE')
ENDIF
IF(SCAT .and. iprf==0) THEN
CALL XABORT('@D2P: NO PROFIL XS AVAILABLE')
ENDIF
IF(SCAT .and. idif==0) THEN
CALL XABORT('@D2P: NO DIFFUSION XS AVAILABLE')
ENDIF
IF(SCAT .and. itra==0) THEN
CALL XABORT('@D2P: NO TRANSFERT XS AVAILABLE')
ENDIF
IF((LADF) .and. idifc==0) THEN
CALL XABORT('@D2P: NO FUITES XS AVAILABLE')
ENDIF
NANI=ADRX(NREA+2,isot,ISADRX(imil))-1
ND=ADRX(NREA+1,isot,ISADRX(imil))
IF(MOD(idif,NREA+1).GT.0 .AND. ND.GE.1) THEN
iadc=ADRX(idif,isot,ISADRX(imil))+NGP
ENDIF
! address in RDATAX of ABSORPTION XS
ADR_ABS=ADRX(iabs,isot,ISADRX(imil))
! address in RDATAX of EXCESS XS
ADR_EXC=0
IF(LABS(3)) ADR_EXC=ADRX(iexc,isot,ISADRX(imil))
! address in RDATAX of PROFIL XS
ADR_PRF=0
IF(SCAT) ADR_PRF=ADRX(iprf,isot,ISADRX(imil))
! address in RDATAX of TRANSFERT XS
ADR_TRA=0
IF(SCAT) ADR_TRA=ADRX(itra,isot,ISADRX(imil))
! address in RDATAX of FUITES XS
ADR_DIF=0
IF(LADF) ADR_DIF=ADRX(idifc,isot,ISADRX(imil))
! moving in the saphyyb object to recover RDATAX information
CALL LCMSIX(IPSAP,' ',0)
CALL LCMSIX(IPSAP,CALDIR,1)
CALL LCMSIX(IPSAP,'mili 1',1)
CALL LCMGET(IPSAP,'RDATAX',RDATAX)
CALL LCMGET(IPSAP,'IDATAP',IDATAP)
! LOOP over energy groups
DO ig=1, NGP
ABSORPTION(ig)=RDATAX(ADR_ABS+ig-1)
IF(LADF) DIFC(ig)=RDATAX(ADR_DIF+ig-1)
IF(LABS(3)) THEN
ABSORPTION(ig)=ABSORPTION(ig)-RDATAX(ADR_EXC+ig-1)
ENDIF
ENDDO
IF(SCAT)THEN ! recover the scattering XS from Saphyb
ii = ADR_PRF
nj = IDATAP(ii+6+2*NGP)-1
DO ani=0, NANI
il = ADR_TRA + (ani) * nj
fagg =IDATAP(ii)
lagg =IDATAP(ii+1)
fdgg =IDATAP(ii+2)
wgal =IDATAP(ii+3)
fag =IDATAP(ii+4)
lag =IDATAP(ii+5)
fdg =IDATAP(ii+6:ii+5+NGP)
adr =IDATAP(ii+6+NGP:ii+6+2*NGP)
IF(wgal.GT.0)THEN
it=il
DO g=fagg,lagg
i1=(g-1)*NGP+fdgg
i2=(g-1)*NGP+fdgg+wgal-1
TRANSFERT(ani+1,i1:i2)=RDATAX(it:it+wgal-1)
it=it+wgal
ENDDO
ENDIF
DO g=fag,lag
i1=(g-1)*NGP+fdg(g)
i2=(g-1)*NGP+fdg(g)+adr(g+1)-adr(g)-1
j1=il-1+adr(g)
j2=il-1+adr(g+1)-1
TRANSFERT(ani+1,i1:i2)=RDATAX(j1:j2)
ENDDO
ENDDO
IF(iadc.NE.0)THEN
NG=NGP
! TRANSFERT(1,1:NG*NG:NG+1) =
! > TRANSFERT(1,1:NG*NG:NG+1) - RDATAX(iadc:iadc+NGP-1)
ENDIF
ENDIF
DO g=1, NGP
DO ig=1, NGP
SCAT_MAT(NSCAT) = TRANSFERT(1,g+(ig-1)*NGP)
NSCAT=NSCAT+1
ENDDO
ENDDO
! RECOVER ADF IN SAPHYB (IF AVAILABLE) (adapted from !
! saphyb_browser of UPM)
IF(LADF) THEN
IF((ADF_T.EQ.'SEL').OR.(ADF_T.EQ.'GET')) THEN
CALL LCMSIX (IPSAP,' ',0)
CALL LCMSIX (IPSAP,'geom ',1)
CALL LCMSIX (IPSAP,'outgeom ',1)
CALL LCMLEN(IPSAP,'SURF',NSURF,ITYLCM)
IF(NSF.NE.NSURF) THEN
WRITE(6,*) "@D2P: ERROR IN NUMBER OF ASSEMBLY SURFACES"
WRITE(6,*) "THE NUMBER OF SURFACES IN SAP (",
1 NSURF,") IF DIFFERENT FROM DRAG2PARCS INPUT (",NSF,")"
CALL XABORT('')
ENDIF
CALL LCMGET(IPSAP,'IPAR',IPAR)
CALL LCMGET(IPSAP,'RPAR',RPAR)
CALL LCMSIX(IPSAP,' ',0)
CALL LCMSIX(IPSAP,CALDIR,1)
CALL LCMSIX(IPSAP,'outflx ',1)
CALL LCMGET(IPSAP,'CURRM',CURRN(:,:,2))
CALL LCMGET(IPSAP,'CURRP',CURRN(:,:,1))
CALL LCMGET(IPSAP,'SURFLX',SRFLX(:,:))
CALL LCMGET(IPSAP,'REGFLX',ZAFLX(:,:))
ADF = 0.
DIFC(:)=DIFC(:)/B2
! CALL to GET_SFI_XS to recover ADF
CALL D2PADF(IPDAT,IPRINT,NGP,NMIL, ADF, NSF, DIFC,CURRN,SRFLX,
1 ZAFLX,RPAR,IPAR,ADF_T,STAIDX,NVAR)
ENDIF
ENDIF
! STORE RESULTS IN INFO DATA BLOCK
CALL LCMSIX(IPDAT,' ',0)
CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
IPTH=LCMGID(IPDAT,'CROSS_SECT')
KPTH=LCMDIL(IPTH,STAIDX(NVAR))
CALL LCMSIX(KPTH,'MACROLIB_XS',1)
IF(LABS(2)) CALL LCMPUT(KPTH,'ABSORPTION',NGP,2,ABSORPTION)
IF(SCAT) CALL LCMPUT(KPTH,'SCAT',NGP*NGP,2,SCAT_MAT)
IF(LABS(2)) WRITE(6,*) "ABSORPTION EXCESS :", ABSORPTION
IF(SCAT) WRITE(6,*) "SCATTERING MATRIX :", SCAT_MAT
DEALLOCATE (RDATAX,IDATAP)
END
|
