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
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
|
*DECK LIBDRA
SUBROUTINE LIBDRA (IPLIB,IPDRL,NAMFIL,NGRO,NBISO,NL,ISONAM,
1 ISONRF,IPISO,TN,SN,SB,MASKI,NED,HVECT,IMPX,NGF,NGFR,NDEL,NBESP)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Transcription of the useful interpolated microscopic cross section
* data from a microscopic x-section library (draglib format) to LCM
* data structures.
*
*Copyright:
* Copyright (C) 2002 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
* IPLIB pointer to the lattice microscopic cross section library
* (L_LIBRARY signature).
* IPDRL pointer to the draglib (L_DRAGLIB signature).
* NAMFIL name of the Dragon library file.
* NGRO number of energy groups.
* NBISO number of isotopes present in the calculation domain.
* NL number of Legendre orders required in the calculation
* NL=1 or higher.
* ISONAM alias name of isotopes.
* ISONRF library name of isotopes.
* IPISO pointer array towards microlib isotopes.
* TN temperature of each isotope.
* SN dilution cross section in each energy group of each
* isotope. a value of 1.0e10 is used for infinite dilution.
* SB dilution cross section as used in livolant and jeanpierre
* normalization.
* MASKI isotopic mask. Isotope with index I is processed if
* MASKI(I)=.true.
* NED number of extra vector edits.
* HVECT names of the extra vector edits.
* IMPX print flag.
*
*Parameters: output
* NGF number of fast groups without self-shielding.
* NGFR number of fast and resonance groups.
* NDEL number of precursor groups for delayed neutrons.
* NBESP number of energy-dependent fission spectra.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
PARAMETER(MAXDEL=10,MAXESP=4)
CHARACTER*(*) HVECT(NED),NAMFIL
TYPE(C_PTR) IPLIB,IPDRL,IPISO(NBISO)
INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO),NED,IMPX,
1 NGF,NGFR,NDEL,NBESP
REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO)
LOGICAL MASKI(NBISO)
*----
* LOCAL VARIABLES
*----
CHARACTER CD*4,HSMG*131,HTITLE*80,HNISOR*12,HNAMIS*12,HNUSIG*12,
1 HCHI*12
PARAMETER (IOUT=6,MAXTMP=50,NOTX=3)
TYPE(C_PTR) KPLIB
LOGICAL LSIGF,LGOLD,LOGT,LNZERO
INTEGER IESP(MAXESP+1)
DOUBLE PRECISION FACTOR,TERP(MAXTMP),DDELI
REAL TEMP(MAXTMP),ZLAMB(MAXDEL),EESP(MAXESP+1)
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS,ITYPRO,ITITLE
REAL, ALLOCATABLE, DIMENSION(:) :: AWR,DELTA,TOTAL,GOLD,ZNPHI,
1 ENER,BIN,EBIN,SIGS2,SCAT2,TOTAL2,SIGF2,CHI2,SADD2,GOLD2,BIN2,
2 ZNPHI2,CHI4G2
REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,SIGF,CHI,SADD,CHI4G
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSCAT,LADD
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(NFS(NGRO),ITYPRO(NL))
ALLOCATE(AWR(NBISO),DELTA(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),
1 TOTAL(NGRO),SIGF(NGRO,0:MAXDEL),CHI(NGRO,0:MAXDEL),
2 SADD(NGRO,NED),ENER(NGRO+1),GOLD(NGRO),ZNPHI(NGRO))
ALLOCATE(LSCAT(NL),LADD(NED))
*----
* RECOVER THE GROUP STRUCTURE.
*----
NGF=NGRO+1
NGFR=0
NDEL=0
IF(IMPX.GT.0) WRITE (IOUT,900) NAMFIL
CALL LCMLEN(IPDRL,'README',LENGT,ITYLCM)
IF((IMPX.GT.0).AND.(LENGT.GT.0)) THEN
ALLOCATE(ITITLE(LENGT))
CALL LCMGET(IPDRL,'README',ITITLE)
WRITE (IOUT,940)
I2=0
DO 10 J=0,LENGT/20
I1=I2+1
I2=MIN(I1+19,LENGT)
WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2)
WRITE (IOUT,'(1X,A80)') HTITLE
10 CONTINUE
DEALLOCATE(ITITLE)
WRITE (IOUT,'(40H LIBDRA: NUMBER OF ISOTOPES IN MICROLIB=,I6)')
1 NBISO
ENDIF
CALL LCMLEN(IPDRL,'ENERGY',LENGT,ITYLCM)
LENGT=LENGT-1
IF(LENGT.NE.NGRO) CALL XABORT('LIBDRA: INVALID GROUP STRUCTURE.')
CALL LCMGET(IPDRL,'ENERGY',ENER)
CALL LCMLEN(IPDRL,'DELTAU',LENGT,ITYLCM)
IF(LENGT.EQ.NGRO) THEN
CALL LCMGET(IPDRL,'DELTAU',DELTA)
ELSE IF(LENGT.EQ.0) THEN
IF(ENER(NGRO+1).EQ.0.0) ENER(NGRO+1)=1.0E-5
DO 15 J=1,NGRO
DELTA(J)=LOG(ENER(J)/ENER(J+1))
15 CONTINUE
ENDIF
CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER)
CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA)
CALL LCMLEN(IPDRL,'CHI-LIMITS',NBESP,ITYLCM)
IF(NBESP.GT.0) THEN
NBESP=NBESP-1
IF(NBESP.GT.MAXESP) CALL XABORT('LIBDRA: MAXESP OVERFLOW.')
CALL LCMGET(IPDRL,'CHI-LIMITS',IESP)
CALL LCMPUT(IPLIB,'CHI-LIMITS',NBESP+1,1,IESP)
CALL LCMGET(IPDRL,'CHI-ENERGY',EESP)
CALL LCMPUT(IPLIB,'CHI-ENERGY',NBESP+1,2,EESP)
ENDIF
ALLOCATE(CHI4G(NGRO,NBESP))
*----
* READ THROUGH DRAGON FILE AND ACCUMULATE CROSS SECTIONS FOR THIS RANGE
* OF MATS, LEGENDRE ORDERS, AND GROUPS.
*----
DO 400 IMX=1,NBISO
IF(MASKI(IMX)) THEN
WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3)
CALL LCMLEN(IPDRL,HNISOR,LENGT,ITYLCM)
IF(LENGT.EQ.0) THEN
CALL LCMLIB(IPDRL)
WRITE (HSMG,910) HNAMIS,HNISOR,NAMFIL,IMX
CALL XABORT(HSMG)
ENDIF
IF(IMPX.GT.0) WRITE (IOUT,920) HNAMIS,HNISOR
CALL LCMSIX(IPDRL,HNISOR,1)
*
CALL LCMGET(IPDRL,'AWR',AWR(IMX))
CALL LCMLEN(IPDRL,'README',LTITLE,ITYLCM)
IF(LTITLE.GT.0) THEN
ALLOCATE(ITITLE(LTITLE))
CALL LCMGET(IPDRL,'README',ITITLE)
IF(IMPX.GT.0) THEN
WRITE (IOUT,930)
I2=0
DO 20 J=0,LTITLE/20
I1=I2+1
I2=MIN(I1+19,LTITLE)
WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2)
WRITE (IOUT,'(1X,A80)') HTITLE
20 CONTINUE
ENDIF
ENDIF
*----
* RECOVER BIN TYPE INFORMATION (IF AVAILABLE).
*----
LBIN=0
CALL LCMLEN (IPDRL,'BIN-NFS',LENGT,ITYXSM)
IF(LENGT.GT.0) THEN
CALL LCMGET (IPDRL,'BIN-NFS',NFS)
DO 30 I=1,NGRO
LBIN=LBIN+NFS(I)
30 CONTINUE
ALLOCATE(BIN(3*LBIN),EBIN(LBIN+1))
CALL LCMGET (IPDRL,'BIN-ENERGY',EBIN)
CALL LCMLEN(IPDRL,'BIN-DELI',LENDEL,ITYLCM)
IF((LENDEL.EQ.1).AND.(ITYLCM.EQ.2)) THEN
CALL LCMGET (IPDRL,'BIN-DELI',RDELI)
ELSE IF((LENDEL.EQ.1).AND.(ITYLCM.EQ.4)) THEN
CALL LCMGET (IPDRL,'BIN-DELI',DDELI)
RDELI=REAL(DDELI)
ENDIF
ENDIF
*----
* RECOVER ECCOLIB INFORMATION (IF AVAILABLE).
*----
DELECC=0.0
IGECCO=0
CALL LCMLEN(IPDRL,'ONFLIGHTDEL',LENGT,ITYLCM)
IF(LENGT.GT.0) THEN
CALL LCMGET(IPDRL,'ONFLIGHTDEL',DELECC)
CALL LCMGET(IPDRL,'ONFLIGHTIGR',IGECCO)
ENDIF
*
CALL LCMLEN (IPDRL,'TEMPERATURE',NTMP,ITYLCM)
IF(NTMP.GT.MAXTMP) CALL XABORT('LIBDRA: MAXTMP OVERFLOW.')
IF(NTMP.EQ.0) THEN
CALL LCMLEN (IPDRL,'LAMBDA-D',NDEL0,ITYLCM)
NDEL=MAX(NDEL,NDEL0)
IF(NDEL0.GT.MAXDEL) CALL XABORT('LIBDRA: MAXDEL OVERFLOW.')
IF(NDEL0.GT.0) CALL LCMGET (IPDRL,'LAMBDA-D',ZLAMB)
CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,ENER,SN(1,IMX),
1 SB(1,IMX),NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,
2 IGECCO,IMPX,NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS(1,1),
3 SCAT(1,1,1),TOTAL,ZNPHI,SIGF(1,1),CHI(1,1),CHI4G(1,1),
4 SADD(1,1),GOLD(1),BIN(1))
ELSE
*----
* PERFORM TEMPERATURE LAGRANGIAN INTERPOLATION (ORDER ABS(NOTX)).
*----
CALL LCMSIX (IPDRL,'SUBTMP0001',1)
CALL LCMLEN (IPDRL,'LAMBDA-D',NDEL0,ITYLCM)
NDEL=MAX(NDEL,NDEL0)
IF(NDEL0.GT.MAXDEL) CALL XABORT('LIBDRA: MAXDEL OVERFLOW.')
IF(NDEL0.GT.0) CALL LCMGET (IPDRL,'LAMBDA-D',ZLAMB)
CALL LCMSIX (IPDRL,' ',2)
CALL LCMGET (IPDRL,'TEMPERATURE',TEMP)
CALL LIBLEX(NTMP,TN(IMX),TEMP,NOTX,TERP)
DO 121 IG1=1,NGRO
TOTAL(IG1)=0.0
ZNPHI(IG1)=0.0
DO 100 IDEL=0,NDEL0
SIGF(IG1,IDEL)=0.0
CHI(IG1,IDEL)=0.0
100 CONTINUE
DO 105 ISP=1,NBESP
CHI4G(IG1,ISP)=0.0
105 CONTINUE
GOLD(IG1)=0.0
DO 115 IL=1,NL
SIGS(IG1,IL)=0.0
DO 110 IG2=1,NGRO
SCAT(IG1,IG2,IL)=0.0
110 CONTINUE
115 CONTINUE
DO 120 IED=1,NED
SADD(IG1,IED)=0.0
120 CONTINUE
121 CONTINUE
DO 125 IG=1,3*LBIN
BIN(IG)=0.0
125 CONTINUE
ALLOCATE(SIGS2(NGRO*NL),SCAT2(NGRO*NGRO*NL),TOTAL2(NGRO),
1 SIGF2(NGRO*(NDEL0+1)),CHI2(NGRO*(NDEL0+1)),SADD2(NGRO*NED),
2 GOLD2(NGRO),BIN2(3*LBIN),ZNPHI2(NGRO),CHI4G2(NGRO*NBESP))
FACTOR=1.0D0
DO 210 ITM=1,NTMP
TERPM=REAL(TERP(ITM))
FACTOR=FACTOR-TERP(ITM)
IF(TERPM.EQ.0.0) GO TO 210
IF(IMPX.GT.4) WRITE(6,'(/30H DRAGLIB ACCESS AT TEMPERATURE,
> 1P,E12.4,18H KELVIN. FACTOR = ,E12.4)') TEMP(ITM),TERPM
WRITE (CD,'(I4.4)') ITM
CALL LCMSIX (IPDRL,'SUBTMP'//CD,1)
CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,ENER,SN(1,IMX),
1 SB(1,IMX),NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,
2 IGECCO,IMPX,NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS2(1),
3 SCAT2(1),TOTAL2,ZNPHI2,SIGF2(1),CHI2(1),CHI4G2(1),SADD2(1),
4 GOLD2(1),BIN2(1))
CALL LCMSIX (IPDRL,' ',2)
DO 130 IG=1,NGRO
TOTAL(IG)=TOTAL(IG)+TERPM*TOTAL2(IG)
ZNPHI(IG)=ZNPHI(IG)+TERPM*ZNPHI2(IG)
130 CONTINUE
IF(LSIGF) THEN
DO 141 IDEL=0,NDEL0
DO 140 IG=1,NGRO
IOFSET=IDEL*NGRO+IG-1
SIGF(IG,IDEL)=SIGF(IG,IDEL)+TERPM*SIGF2(IOFSET+1)
CHI(IG,IDEL)=CHI(IG,IDEL)+TERPM*CHI2(IOFSET+1)
140 CONTINUE
141 CONTINUE
DO 146 ISP=1,NBESP
DO 145 IG=1,NGRO
IOFSET=(ISP-1)*NGRO+IG-1
CHI4G(IG,ISP)=CHI4G(IG,ISP)+TERPM*CHI4G2(IOFSET+1)
145 CONTINUE
146 CONTINUE
ENDIF
DO 160 IL=1,NL
IF(LSCAT(IL)) THEN
DO 150 IG2=1,NGRO
SIGS(IG2,IL)=SIGS(IG2,IL)+TERPM*SIGS2((IL-1)*NGRO+IG2)
IOF=(IL-1)*NGRO*NGRO+(IG2-1)*NGRO
DO 151 IG1=1,NGRO
SCAT(IG1,IG2,IL)=SCAT(IG1,IG2,IL)+TERPM*
> SCAT2(IOF+IG1)
151 CONTINUE
150 CONTINUE
ENDIF
160 CONTINUE
DO 180 IED=1,NED
IF(LADD(IED)) THEN
DO 170 IG=1,NGRO
SADD(IG,IED)=SADD(IG,IED)+TERPM*SADD2((IED-1)*NGRO+IG)
170 CONTINUE
ENDIF
180 CONTINUE
IF(LGOLD) THEN
DO 190 IG=1,NGRO
GOLD(IG)=GOLD(IG)+TERPM*GOLD2(IG)
190 CONTINUE
ENDIF
DO 200 IG=1,3*LBIN
BIN(IG)=BIN(IG)+TERPM*BIN2(IG)
200 CONTINUE
210 CONTINUE
DEALLOCATE(CHI4G2,ZNPHI2,BIN2,GOLD2,SADD2,CHI2,SIGF2,TOTAL2,
> SCAT2,SIGS2)
IF(ABS(FACTOR).GT.1.0D-4) CALL XABORT('LIBDRA: TERP ERROR')
ENDIF
CALL LCMSIX(IPDRL,' ',2)
*----
* SAVE CROSS SECTION DATA ON LCM.
*----
KPLIB=IPISO(IMX) ! set IMX-th isotope
CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS)
CALL LCMPUT(KPLIB,'AWR',1,2,AWR(IMX))
IF(LTITLE.GT.0) THEN
CALL LCMPUT(KPLIB,'README',LTITLE,3,ITITLE)
DEALLOCATE(ITITLE)
ENDIF
DO 220 IG=1,NGRO
IF(TOTAL(IG).LT.0.0) THEN
WRITE(HSMG,'(42HLIBDRA: NEGATIVE TOTAL CROSS SECTION IN GR,
1 3HOUP,I4,14H FOR ISOTOPE '',A12,2H''.)') IG,HNAMIS
CALL XABORT(HSMG)
ELSE IF(ZNPHI(IG).LT.0.0) THEN
WRITE(HSMG,'(41HLIBDRA: NEGATIVE INTEGRATED FLUX IN GROUP,
1 I4,14H FOR ISOTOPE '',A12,2H''.)') IG,HNAMIS
CALL XABORT(HSMG)
ENDIF
220 CONTINUE
CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,TOTAL)
CALL LCMPUT(KPLIB,'NWT0',NGRO,2,ZNPHI)
IF(NDEL0.GT.0) CALL LCMPUT (KPLIB,'LAMBDA-D',NDEL0,2,ZLAMB)
IF(LSIGF) THEN
DO 250 IDEL=0,NDEL0
IF(IDEL.EQ.0) THEN
HNUSIG='NUSIGF'
ELSE
WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL
ENDIF
CALL LCMPUT(KPLIB,HNUSIG,NGRO,2,SIGF(1,IDEL))
IF(IDEL.EQ.0) THEN
IF(NBESP.GT.0) GO TO 250
HCHI='CHI'
ELSE
WRITE(HCHI,'(3HCHI,I2.2)') IDEL
ENDIF
CALL LCMPUT(KPLIB,HCHI,NGRO,2,CHI(1,IDEL))
250 CONTINUE
DO 260 ISP=1,NBESP
LNZERO=.FALSE.
DO 255 IG=1,NGRO
LNZERO=LNZERO.OR.(CHI4G(IG,ISP).NE.0.0)
255 CONTINUE
IF(LNZERO) THEN
WRITE(HCHI,'(5HCHI--,I2.2)') ISP
CALL LCMPUT(KPLIB,HCHI,NGRO,2,CHI4G(1,ISP))
ENDIF
260 CONTINUE
ENDIF
CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO)
DO 340 IED=1,NED
IF(LADD(IED).AND.(HVECT(IED)(:3).NE.'CHI')
1 .AND.(HVECT(IED)(:2).NE.'NU')
2 .AND.(HVECT(IED).NE.'NTOT0')
3 .AND.(HVECT(IED)(:3).NE.'NWT')) THEN
CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,SADD(1,IED))
ENDIF
340 CONTINUE
IF(LGOLD) CALL LCMPUT(KPLIB,'NGOLD',NGRO,2,GOLD)
IF(LBIN.GT.0) THEN
CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS)
CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,EBIN)
CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,BIN)
CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,BIN(LBIN+1))
LOGT=.FALSE.
DO 350 I=1,LBIN
LOGT=LOGT.OR.(BIN(2*LBIN+I).NE.0.0)
350 CONTINUE
IF(LOGT) THEN
CALL LCMPUT(KPLIB,'BIN-NUSIGF',LBIN,2,BIN(2*LBIN+1))
ENDIF
DEALLOCATE(EBIN,BIN)
IF(LENDEL.EQ.1) CALL LCMPUT(KPLIB,'BIN-DELI',1,2,RDELI)
ENDIF
IF(IMPX.GT.9) CALL LCMLIB(KPLIB)
ENDIF
400 CONTINUE
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(LADD,LSCAT)
DEALLOCATE(CHI4G,ZNPHI,GOLD,ENER,SADD,CHI,SIGF,TOTAL,SCAT,SIGS,
1 DELTA,AWR)
DEALLOCATE(ITYPRO,NFS)
RETURN
*
900 FORMAT(/33H PROCESSING DRAGON LIBRARY NAMED ,A12,1H.)
910 FORMAT(26HLIBDRA: MATERIAL/ISOTOPE ',A12,5H' = ',A12,9H' IS MISS,
1 25HING ON DRAGON FILE NAMED ,A12,10H (ISOTOPE=,I10,2H).)
920 FORMAT(/30H PROCESSING ISOTOPE/MATERIAL ',A12,11H' (HNISOR=',A12,
1 3H').)
930 FORMAT(/23H ISOTOPE/MATERIAL INFO:)
940 FORMAT(/24H X-SECTION LIBRARY INFO:)
END
|
