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
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
|
*DECK NCRLIB
SUBROUTINE NCRLIB(MAXNIS,MAXISO,MAXFEL,IPLIB,IPCPO,IACCS,NMIL,
1 NMIX,NGRP,NGFF,NALBP,IDF,IMPX,NCAL,TERP,NISO,LISO,HISO,CONC,
2 MIXC,LXS,LRES,LPURE,B2)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Build the microlib by scanning the NCAL elementary calculations and
* weighting them with TERP factors.
*
*Copyright:
* Copyright (C) 2006 Ecole Polytechnique de Montreal
*
*Author(s):
* A. Hebert
*
*Parameters: input
* MAXNIS maximum value of NISO(I) in user data.
* MAXISO maximum allocated space for output microlib TOC information.
* MAXFEL number of fuel rings used for the micro-depletion.
* IPLIB address of the output microlib LCM object.
* IPCPO address of the multicompo object.
* IACCS =0 microlib is created; =1 ... is updated.
* NMIL number of material mixtures in the multicompo.
* NMIX maximum number of material mixtures in the microlib.
* NGRP number of energy groups.
* NGFF number of group form factors per energy group.
* NALBP number of physical albedos per energy group.
* IDF ADF type, 0 = none, 1 = Albedo, 2 = FD_B/FD_C/..., 3 = ADF.
* IMPX print parameter (equal to zero for no print).
* NCAL number of elementary calculations in the multicompo.
* TERP interpolation factors.
* NISO number of user-selected isotopes.
* LISO type of treatment (=.true.: ALL; =.false.: ONLY).
* HISO name of the user-selected isotopes.
* CONC user-defined number density of the user-selected isotopes.
* A value of -99.99 is set to indicate that the multicompo value
* is used.
* MIXC mixture index in the multicompo corresponding to each microlib
* mixture. Equal to zero if a microlib mixture is not updated.
* LXS =.true. if keyword 'ALLX' is specified
* LRES =.true. if the interpolation is done without updating isotopic
* densities
* LPURE =.true. if the interpolation is a pure linear interpolation
* with TERP factors.
* B2 buckling
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPLIB,IPCPO
INTEGER MAXNIS,MAXISO,MAXFEL,IACCS,NMIL,NMIX,NGRP,NGFF,NALBP,
1 IDF,IMPX,NCAL,NISO(NMIX),HISO(2,NMIX,MAXNIS),MIXC(NMIX)
REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2
LOGICAL LISO(NMIX),LXS,LRES,LPURE
*----
* LOCAL VARIABLES
*----
INTEGER, PARAMETER::IOUT=6
INTEGER, PARAMETER::MAXED=50
INTEGER, PARAMETER::NSTATE=40
INTEGER I0, IACCOLD, IBMOLD, IBM, ICAL, IED1, IED2, IGR, ILONG,
& ISO, ITRANC, ITYLCM, I, JSO1, JSO, J, KSO1, KSO, NBISO1, NBISO2,
& NBISOT2, NBISOT, NBRG, NCOMB2, NCOMB, NDEL, NBESP, NDEPL, NDFI,
& NED1, NED2, NFINF, NL, NW, NTYPE
REAL WEIGHT
CHARACTER TEXT12*12,HNAME*12,HSMG*131,HVECT1(MAXED)*8,
1 HVECT2(MAXED)*8,CHAR1*4,CHAR2*4,HHISO*8
INTEGER ISTATE(NSTATE)
LOGICAL LUSER
TYPE(C_PTR) JPCPO,KPCPO,LPCPO,MPCPO,JPLIB,KPLIB
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYP1,ITOD1,IMIX2,ITYP2,
1 ITOD2,MILVO,IMICR
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE1,HNAM1,HUSE2,HNAM2
REAL, ALLOCATABLE, DIMENSION(:) :: TEMP1,VOL1,DENS2,TEMP2,VOL2,
1 DENS3,TEMP3,VOL3,ENER,DELT,VOLMI2,GAR1,GAR2
REAL, ALLOCATABLE, DIMENSION(:,:) :: FACT,DENS1
TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPLIST
INTEGER NBISS
CHARACTER ISTMPN*12
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(HUSE1(3,MAXISO),HNAM1(3,MAXISO),ITYP1(MAXISO),
1 ITOD1(MAXISO),IMIX2(MAXISO),ITYP2(MAXISO),ITOD2(MAXISO),
2 HUSE2(3,MAXISO),HNAM2(3,MAXISO),MILVO(NMIX))
ALLOCATE(TEMP1(MAXISO),VOL1(MAXISO),DENS2(MAXISO),TEMP2(MAXISO),
1 VOL2(MAXISO),ENER(NGRP+1),DELT(NGRP),VOLMI2(NMIX),IPLIST(MAXISO))
IACCOLD=IACCS ! for ADF and GFF
*----
* MICROLIB INITIALIZATION
*----
ITRANC=0
VOLMI2(:NMIX)=0.0
DENS2(:MAXISO)=0.0
VOL2(:MAXISO)=0.0
TEMP2(:MAXISO)=0.0
IMIX2(:MAXISO)=0
ITYP2(:MAXISO)=0
ITOD2(:MAXISO)=0
IPLIST(:MAXISO)=C_NULL_PTR
IF(IACCS.EQ.0) THEN
IF(LRES) CALL XABORT('NCRLIB: RES OPTION IS INVALID.')
NBISO2=0
NCOMB2=0
NED2=0
TEXT12='L_LIBRARY'
CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12)
ELSE
CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
IF(ISTATE(1).NE.NMIX) CALL XABORT('NCRLIB: INVALID NUMBER OF '
1 //'MATERIAL MIXTURES IN THE MICROLIB.')
IF(ISTATE(3).NE.NGRP) CALL XABORT('NCRLIB: INVALID NUMBER OF '
1 //'ENERGY GROUPS IN THE MICROLIB.')
NBISO2=ISTATE(2)
NCOMB2=ISTATE(12)
IF(NBISO2.GT.MAXISO) CALL XABORT('NCRLIB: MAXISO OVERFLOW(1).')
NED2=ISTATE(13)
IF(NED2.GT.MAXED) CALL XABORT('NCRLIB: MAXED OVERFLOW.')
CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM)
IF(ILONG.GT.0) THEN
CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMI2)
ELSE
VOLMI2(:NMIX)=0.0
ENDIF
CALL LCMGET(IPLIB,'ISOTOPESUSED',HUSE2)
CALL LCMGET(IPLIB,'ISOTOPERNAME',HNAM2)
CALL LCMGET(IPLIB,'ISOTOPESTYPE',ITYP2)
CALL LCMGET(IPLIB,'ISOTOPESTODO',ITOD2)
CALL LCMGET(IPLIB,'ISOTOPESDENS',DENS2)
CALL LCMGET(IPLIB,'ISOTOPESVOL',VOL2)
CALL LCMGET(IPLIB,'ISOTOPESMIX',IMIX2)
CALL LCMGET(IPLIB,'ISOTOPESTEMP',TEMP2)
IF(NED2.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2)
CALL LCMGET(IPLIB,'ENERGY',ENER)
CALL LCMGET(IPLIB,'DELTAU',DELT)
ENDIF
*----
* RECOVER NDEPL
*----
NDEPL=0
CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILONG,ITYLCM)
IF(ILONG.NE.0) THEN
CALL LCMSIX(IPCPO,'DEPL-CHAIN',1)
CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE)
NDEPL=ISTATE(1)
CALL LCMSIX(IPCPO,' ',2)
ENDIF
*----
* LOOP OVER MICROLIB MIXTURES
*----
ALLOCATE(DENS3(MAXISO),TEMP3(MAXISO),VOL3(MAXISO))
MILVO(:NMIX)=0
NCOMB=0
JPCPO=LCMGID(IPCPO,'MIXTURES')
NBISS=0
DO 190 IBM=1,NMIX
IBMOLD=MIXC(IBM)
IF(IBMOLD.EQ.0) GO TO 190
IF(NISO(IBM).GT.MAXNIS) CALL XABORT('NCRLIB: MAXNIS OVERFLOW.')
KPCPO=LCMGIL(JPCPO,IBMOLD)
LPCPO=LCMGID(KPCPO,'CALCULATIONS')
*----
* FIND THE VALUE OF NBISO1 IN MIXTURE IBM
*----
DO ICAL=1,NCAL
IF(TERP(ICAL,IBM).EQ.0.0) CYCLE
MPCPO=LCMGIL(LPCPO,ICAL)
CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE)
NBISO1=ISTATE(2)
CALL LCMGET(MPCPO,'ISOTOPESUSED',HUSE1)
CALL LCMGET(MPCPO,'ISOTOPERNAME',HNAM1)
EXIT
ENDDO
ALLOCATE(FACT(NCAL,NBISO1),DENS1(NBISO1,NCAL))
*----
* LOOP OVER ELEMENTARY CALCULATIONS
*----
JSO1=0
DENS3(:NBISO1)=0.0
VOL3(:NBISO1)=0.0
TEMP3(:NBISO1)=0.0
DO 50 ICAL=1,NCAL
WEIGHT=TERP(ICAL,IBM)
IF(WEIGHT.EQ.0.0) GO TO 50
MPCPO=LCMGIL(LPCPO,ICAL)
IF(IMPX.GT.0) THEN
WRITE(IOUT,'(38H NCRLIB: MULTICOMPO ACCESS FOR MIXTURE,I8,
1 5H (<==,I4,17H) AND CALCULATION,I8,9H. WEIGHT=,1P,E12.4)')
2 IBM,IBMOLD,ICAL,WEIGHT
IF(IMPX.GT.50) CALL LCMLIB(MPCPO)
ENDIF
CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE)
IF(ISTATE(1).NE.1) CALL XABORT('NCRLIB: INVALID NUMBER OF MATERI'
1 //'AL MIXTURES IN THE MULTICOMPO.')
IF(ISTATE(2).NE.NBISO1) CALL XABORT('NCRLIB: INVALID NBISO1.')
IF(ISTATE(3).NE.NGRP) CALL XABORT('NCRLIB: INVALID NUMBER OF ENE'
1 //'RGY GROUPS IN THE MULTICOMPO.')
NL=ISTATE(4)
ITRANC=ISTATE(5)
NDEPL=MAX(ISTATE(11),NDEPL)
NED1=ISTATE(13)
NBESP=ISTATE(16)
NDEL=ISTATE(19)
NDFI=ISTATE(20)
NW=ISTATE(25)
IF(NED1.GT.MAXED) CALL XABORT('NCRLIB: MAXED OVERFLOW.')
CALL LCMLEN(MPCPO,'MIXTURESVOL',ILONG,ITYLCM)
IF(ILONG.GT.0) CALL LCMGET(MPCPO,'MIXTURESVOL',VOLMI2(IBM))
CALL LCMGET(MPCPO,'ISOTOPESDENS',DENS1(1,ICAL))
CALL LCMGET(MPCPO,'ISOTOPESTYPE',ITYP1)
CALL LCMGET(MPCPO,'ISOTOPESTODO',ITOD1)
CALL LCMGET(MPCPO,'ISOTOPESVOL',VOL1)
CALL LCMGET(MPCPO,'ISOTOPESTEMP',TEMP1)
IF(NED1.GT.0) CALL LCMGTC(MPCPO,'ADDXSNAME-P0',8,NED1,HVECT1)
CALL LCMGET(MPCPO,'ENERGY',ENER)
CALL LCMGET(MPCPO,'DELTAU',DELT)
DO 30 IED1=1,NED1
DO 20 IED2=1,NED2
IF(HVECT1(IED1).EQ.HVECT2(IED2)) GO TO 30
20 CONTINUE
NED2=NED2+1
IF(NED2.GT.MAXED) CALL XABORT('NCRLIB: MAXED OVERFLOW.')
HVECT2(NED2)=HVECT1(IED1)
30 CONTINUE
DO 49 ISO=1,NBISO1 ! multicompo isotope
WRITE(TEXT12,'(2A4)') (HUSE1(I,ISO),I=1,2)
IF(LXS) THEN
WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
READ(CHAR1,'(I4)') NBRG
NBISOT=NBRG+MAXFEL*(IBM-1)
IF(NBISOT.GT.9999) CALL XABORT('NCRLIB: NBISOT OVERFLOW.')
WRITE(TEXT12,'(2A4,I4.4)') (HUSE1(I,ISO),I=1,2),NBISOT
ENDIF
KSO1=0
DO 40 KSO=1,NISO(IBM) ! user-selected isotope
WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2)
IF(TEXT12(:8).EQ.HHISO) THEN
KSO1=KSO
GO TO 45
ENDIF
40 CONTINUE
45 LUSER=.FALSE.
IF(KSO1.GT.0) LUSER=(CONC(IBM,KSO1).NE.-99.99)
IF(LUSER) DENS1(ISO,ICAL)=CONC(IBM,KSO1)
DENS3(ISO)=DENS3(ISO)+WEIGHT*DENS1(ISO,ICAL)
VOL3(ISO)=VOL3(ISO)+WEIGHT*VOL1(ISO)
TEMP3(ISO)=TEMP3(ISO)+WEIGHT*TEMP1(ISO)
49 CONTINUE
50 CONTINUE
FACT(:NCAL,:NBISO1)=1.0
IF(.NOT.LPURE) THEN
DO ICAL=1,NCAL
IF(TERP(ICAL,IBM).EQ.0.0) CYCLE
DO ISO=1,NBISO1 ! multicompo isotope
IF(DENS3(ISO).GT.DENS1(ISO,ICAL)*1.0E-9) THEN
FACT(ICAL,ISO)=DENS1(ISO,ICAL)/DENS3(ISO)
ENDIF
ENDDO
ENDDO
ENDIF
DEALLOCATE(DENS1)
*----
* SET NUMBER DENSITIES AND VOLUMES IN OUTPUT MICROLIB
*----
IF(LRES) THEN
* -- Number densities are left unchanged except if they are
* -- listed in HISO array.
DO 60 KSO=1,NISO(IBM) ! user-selected isotope
DO JSO=1,NBISO2 ! microlib isotope
IF(IMIX2(JSO).NE.IBM) CYCLE
IF((HISO(1,IBM,KSO).EQ.HUSE2(1,JSO)).AND.
1 (HISO(2,IBM,KSO).EQ.HUSE2(2,JSO))) THEN
IF(CONC(IBM,KSO).EQ.-99.99) THEN
* -- Only number densities of isotopes set with "MICR" and
* -- "*" keywords are interpolated
DENS2(JSO)=0.0
DO ISO=1,NBISO1 ! multicompo isotope
JSO1=0
IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.
1 (HUSE1(2,ISO).EQ.HUSE2(2,JSO))) THEN
IF(ITYP1(ISO).NE.ITYP2(JSO)) THEN
WRITE(HSMG,500) 'ITYP',ISO,ITYP1(ISO),ITYP2(JSO)
CALL XABORT(HSMG)
ENDIF
IF(LXS) THEN
WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
WRITE(CHAR2,'(A4)') HUSE2(3,JSO)
READ(CHAR2,'(I4.4)') NBISOT2
NBISOT2=NBISOT2-MAXFEL*(IBM-1)
WRITE(CHAR2,'(I4.4)') NBISOT2
IF(CHAR1.EQ.CHAR2) THEN
JSO1=JSO
GO TO 55
ENDIF
ELSE
JSO1=JSO
GO TO 55
ENDIF
55 IF(JSO1.EQ.0) CALL XABORT('NCRLIB: JSO1=0')
DENS2(JSO1)=DENS2(JSO1)+DENS3(ISO)
TEMP2(JSO1)=TEMP3(ISO)
ENDIF
ENDDO
ELSE IF(CONC(IBM,KSO).NE.-99.99) THEN
* -- Number densities of isotopes set with "MICR" and
* -- fixed value are forced to this value
DENS2(JSO)=CONC(IBM,KSO)
ENDIF
GO TO 60
ENDIF
ENDDO
WRITE(HSMG,'(31HNCRLIB: UNABLE TO FIND ISOTOPE ,2A4,6H IN MI,
1 5HXTURE,I8,1H.)') HISO(1,IBM,KSO),HISO(2,IBM,KSO),IBM
CALL XABORT(HSMG)
60 CONTINUE
ELSE
* -- Number densities are interpolated or not according to
* -- ALL/ONLY option
DO JSO=1,NBISO2 ! microlib isotope
IF(IBM.EQ.IMIX2(JSO)) THEN
DO ISO=1,NBISO1 ! multicompo isotope
IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.
1 (HUSE1(2,ISO).EQ.HUSE2(2,JSO))) THEN
DENS2(JSO)=0.0
VOL2(JSO)=0.0
CYCLE
ENDIF
ENDDO
ENDIF
ENDDO
DO 110 ISO=1,NBISO1 ! multicompo isotope
WRITE(TEXT12,'(2A4)') (HUSE1(I,ISO),I=1,2)
IF(LXS) THEN
WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
READ(CHAR1,'(I4)') NBRG
NBISOT=NBRG+MAXFEL*(IBM-1)
IF(NBISOT.GT.9999) CALL XABORT('NCRLIB: NBISOT OVERFLOW.')
WRITE(TEXT12,'(2A4,I4.4)') (HUSE1(I,ISO),I=1,2),NBISOT
ENDIF
IF(.NOT.LISO(IBM)) THEN
* --ONLY option
DO KSO=1,NISO(IBM) ! user-selected isotope
WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2)
IF(TEXT12(:8).EQ.HHISO) GO TO 65
ENDDO
GO TO 110
ENDIF
65 DO 70 JSO=1,NBISO2 ! microlib isotope
JSO1=0
IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.(HUSE1(2,ISO).EQ.
1 HUSE2(2,JSO)).AND.(IMIX2(JSO).EQ.IBM)) THEN
IF(ITYP1(ISO).NE.ITYP2(JSO)) THEN
WRITE(HSMG,500) 'ITYP',ISO,ITYP1(ISO),ITYP2(JSO)
CALL XABORT(HSMG)
ENDIF
IF(LXS) THEN
WRITE(CHAR1,'(A4)') HUSE1(3,ISO)
WRITE(CHAR2,'(A4)') HUSE2(3,JSO)
READ(CHAR2,'(I4.4)') NBISOT2
NBISOT2=NBISOT2-MAXFEL*(IBM-1)
WRITE(CHAR2,'(I4.4)') NBISOT2
IF(CHAR1.EQ.CHAR2) THEN
JSO1=JSO
GO TO 100
ENDIF
ELSE
JSO1=JSO
GO TO 100
ENDIF
ENDIF
70 CONTINUE
NBISO2=NBISO2+1
IF(NBISO2.GT.MAXISO) THEN
WRITE(IOUT,'(/16H NCRLIB: NBISO2=,I6,8H MAXISO=,I6)') NBISO2,
1 MAXISO
CALL XABORT('NCRLIB: MAXISO OVERFLOW(2).')
ENDIF
READ(TEXT12,'(3A4)') (HUSE2(I0,NBISO2),I0=1,3)
DO 80 I0=1,3
HNAM2(I0,NBISO2)=HNAM1(I0,ISO)
80 CONTINUE
IMIX2(NBISO2)=IBM
ITYP2(NBISO2)=ITYP1(ISO)
ITOD2(NBISO2)=ITOD1(ISO)
IF(ITYP2(NBISO2).EQ.1) ITOD2(NBISO2)=1
JSO1=NBISO2
IF(ITOD2(NBISO2).NE.1) THEN
DO 90 J=1,NCOMB
IF(IBM.EQ.MILVO(J)) GO TO 100
90 CONTINUE
NCOMB=NCOMB+1
IF(NCOMB.GT.NMIX) CALL XABORT('NCRLIB: MILVO OVERFLOW.')
MILVO(NCOMB)=IBM
ENDIF
100 DENS2(JSO1)=DENS2(JSO1)+DENS3(ISO)
VOL2(JSO1)=VOL2(JSO1)+VOL3(ISO)
TEMP2(JSO1)=TEMP3(ISO)
110 CONTINUE
ENDIF
*----
* SELECT MICROLIB ISOTOPES CORRESPONDING TO MULTICOMPO ISOTOPES
*----
ALLOCATE(IMICR(NBISO1))
IMICR(:NBISO1)=0
DO 130 ISO=1,NBISO2 ! microlib isotope
IF(IMIX2(ISO).NE.IBM) GO TO 130
DO 120 JSO=1,NBISO1 ! multicompo isotope
IF((HUSE1(1,JSO).EQ.HUSE2(1,ISO)).AND.(HUSE1(2,JSO).EQ.
1 HUSE2(2,ISO))) THEN
IF(LXS) THEN
WRITE(CHAR1,'(A4)') HUSE1(3,JSO)
WRITE(CHAR2,'(A4)') HUSE2(3,ISO)
READ(CHAR1,'(I4.4)') NBRG
NBISOT=NBRG+MAXFEL*(IBM-1)
READ(CHAR2,'(I4.4)') NBISOT2
IF(NBISOT.EQ.NBISOT2) THEN
IMICR(JSO)=ISO
GO TO 130
ENDIF
ELSE
IMICR(JSO)=ISO
GO TO 130
ENDIF
ENDIF
120 CONTINUE
WRITE(TEXT12,'(3A4)') (HUSE2(I0,ISO),I0=1,3)
CALL XABORT('NCRLIB: UNABLE TO FIND '//TEXT12//'.')
130 CONTINUE
*----
* PROCESS ISOTOPE DIRECTORIES FOR MICROLIB MIXTURE IBM
*----
DO 180 JSO=1,NBISO1 ! multicompo isotope
ISO=IMICR(JSO) ! microlib isotope
IF(ISO.EQ.0) GO TO 180
NBISS=NBISS+1
WRITE(HNAME,'(3A4)') (HUSE1(I0,JSO),I0=1,3)
WRITE(ISTMPN,'(A4,I6.6,A2)') '*ISO',NBISS,' *'
CALL LCMOP(KPLIB,ISTMPN,0,1,0)
IPLIST(ISO)=KPLIB ! set isot ISO
CALL NCRISO(KPLIB,LPCPO,NBISO1,IMICR,HNAME,JSO,IBMOLD,NCAL,NGRP,
1 NL,NW,NED2,HVECT2,NDEL,NBESP,NDFI,IMPX,FACT(1,JSO),TERP(1,IBM),
2 LPURE)
180 CONTINUE
DEALLOCATE(IMICR,FACT)
190 CONTINUE
DEALLOCATE(VOL3,TEMP3,DENS3)
DEALLOCATE(VOL1,TEMP1,MILVO,ITOD1,ITYP1,HNAM1,HUSE1)
*----
* CREATE ISOTOPE LIST DIRECTORY IN MICROLIB
*----
JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO2)
DO 195 ISO=1,NBISO2 ! microlib isotope
IF(C_ASSOCIATED(IPLIST(ISO))) THEN
KPLIB=LCMDIL(JPLIB,ISO) ! step up isot ISO
CALL LCMEQU(IPLIST(ISO),KPLIB)
CALL LCMCL(IPLIST(ISO),2)
ENDIF
195 CONTINUE
DEALLOCATE(IPLIST)
*----
* MICROLIB FINALIZATION
*----
IF(.NOT.LRES) THEN
ISTATE(:NSTATE)=0
ISTATE(1)=NMIX
ISTATE(2)=NBISO2
ISTATE(3)=NGRP
ISTATE(4)=NL
ISTATE(5)=ITRANC
ISTATE(7)=1
ISTATE(11)=NDEPL
ISTATE(12)=NCOMB+NCOMB2
ISTATE(13)=NED2
ISTATE(14)=NMIX
ISTATE(18)=1
ISTATE(19)=NDEL
ISTATE(20)=NDFI
ISTATE(22)=MAXISO/NMIX
IF(NBISO2.EQ.0) CALL XABORT('NCRLIB: NBISO2=0.')
CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE)
CALL LCMPUT(IPLIB,'MIXTURESVOL',NMIX,2,VOLMI2)
CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO2,3,HUSE2)
CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO2,3,HNAM2)
CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2)
CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO2,1,IMIX2)
CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO2,1,ITYP2)
CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO2,1,ITOD2)
CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2)
CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO2,2,TEMP2)
IF(NED2.GT.0) CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2)
CALL LCMPUT(IPLIB,'ENERGY',NGRP+1,2,ENER)
CALL LCMPUT(IPLIB,'DELTAU',NGRP,2,DELT)
ELSE
CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2)
CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2)
CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO2,2,TEMP2)
ENDIF
IF(IMPX.GT.5) CALL LCMLIB(IPLIB)
IACCS=1
DEALLOCATE(VOLMI2,DELT,ENER,VOL2,TEMP2,DENS2,HNAM2,HUSE2,ITOD2,
1 ITYP2,IMIX2)
*----
* BUILD EMBEDDED MACROLIB
*----
CALL SPHEMB(IPLIB,IPCPO,NGRP,NMIX,MIXC,IMPX)
*----
* INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS)
*----
IF(B2.NE.0.0) THEN
IF(IMPX.GT.0) WRITE(6,'(/34H NCRLIB: INCLUDE LEAKAGE IN THE MA,
1 11HCROLIB (B2=,1P,E12.5,2H).)') B2
CALL LCMSIX(IPLIB,'MACROLIB',1)
JPLIB=LCMGID(IPLIB,'GROUP')
ALLOCATE(GAR1(NMIX),GAR2(NMIX))
DO 210 IGR=1,NGRP
KPLIB=LCMGIL(JPLIB,IGR)
CALL LCMGET(KPLIB,'NTOT0',GAR1)
CALL LCMGET(KPLIB,'DIFF',GAR2)
DO 200 IBM=1,NMIX
IF(MIXC(IBM).NE.0) GAR1(IBM)=GAR1(IBM)+B2*GAR2(IBM)
200 CONTINUE
CALL LCMPUT(KPLIB,'NTOT0',NMIX,2,GAR1)
210 CONTINUE
DEALLOCATE(GAR2,GAR1)
CALL LCMSIX(IPLIB,' ',2)
ENDIF
*----
* PROCESS ADF, GFF and physical albedos (if required)
*----
JPCPO=LCMGID(IPCPO,'MIXTURES')
KPCPO=LCMGIL(JPCPO,1)
LPCPO=LCMGID(KPCPO,'CALCULATIONS')
MPCPO=LCMGIL(LPCPO,1)
CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE)
IDF=ISTATE(24)
NTYPE=0
IF(IDF.EQ.1) THEN
NTYPE=2
ELSE IF(IDF.GE.2) THEN
CALL LCMSIX(MPCPO,'MACROLIB',1)
CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM)
IF(ILONG.EQ.0) CALL XABORT('NCRLIB: MISSING ADF DIRECTORY I'
1 //'N MULTICOMPO OBJECT.')
CALL LCMSIX(MPCPO,'ADF',1)
CALL LCMGET(MPCPO,'NTYPE',NTYPE)
CALL LCMSIX(MPCPO,' ',2)
CALL LCMSIX(MPCPO,' ',2)
ENDIF
IF(NGFF.GT.0) THEN
CALL LCMSIX(MPCPO,'MACROLIB',1)
CALL LCMLEN(MPCPO,'GFF',ILONG,ITYLCM)
IF(ILONG.EQ.0) CALL XABORT('NCRLIB: MISSING GFF DIRECTORY I'
1 //'N MULTICOMPO OBJECT.')
CALL LCMSIX(MPCPO,'GFF',1)
CALL LCMLEN(MPCPO,'FINF_NUMBER ',NFINF,ITYLCM)
CALL LCMSIX(MPCPO,' ',2)
CALL LCMSIX(MPCPO,' ',2)
ENDIF
CALL LCMSIX(IPLIB,'MACROLIB',1)
CALL NCRAGF(IPLIB,IPCPO,IACCOLD,NMIL,NMIX,NGRP,NGFF,NALBP,IMPX,
1 NCAL,TERP,MIXC,IDF,NTYPE,NFINF)
CALL LCMSIX(IPLIB,' ',2)
RETURN
*
500 FORMAT(8HNCRLIB: ,A,1H(,I4,2H)=,2I5)
END
|
