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
|
*DECK USSFLU
SUBROUTINE USSFLU(IPTRK,IPLIB,IPLI0,IFTRAK,NREG,NUN,NBMIX,NBISO,
1 NIRES,NL,NED,NDEL,ISONAM,ISOBIS,HCAL,MAT,VOL,KEYFLX,CDOOR,
2 LEAKSW,IMPX,DEN,MIX,IAPT,IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS,IREX,
3 TITR,ICORR,ISUBG,MAXST,GOLD,UNGAR,PHGAR,STGAR,SFGAR,SSGAR,S0GAR,
4 SAGAR,SDGAR,SWGAR,MASKG,SIGGAR)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Compute the self-shielded cross sections in each energy group using a
* subgroup approach.
*
*Copyright:
* Copyright (C) 2003 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
* IPTRK pointer to the tracking (L_TRACK signature).
* IPLIB pointer to the internal microscopic cross section library
* with subgroups (L_LIBRARY signature).
* IPLI0 pointer to the internal microscopic cross section library
* builded by the self-shielding module.
* IFTRAK file unit number used to store the tracks.
* NREG number of regions.
* NUN number of unknowns per energy group and band.
* NBMIX number of mixtures in the internal library.
* NBISO number of isotopes.
* NIRES number of correlated resonant isotopes.
* NL number of legendre orders required in the calculation
* (NL=1 or higher).
* NED number of extra vector edits.
* NDEL number of delayed neutron precursor groups.
* ISONAM alias name of isotopes in IPLIB.
* ISOBIS alias name of isotopes in IPLI0.
* HCAL name of the self-shielding calculation.
* MAT index-number of the mixture type assigned to each volume.
* VOL volumes.
* KEYFLX pointers of fluxes in unknown vector.
* CDOOR name of the geometry/solution operator.
* LEAKSW leakage flag (LEAKSW=.true. if neutron leakage through
* external boundary is present).
* IMPX print flag (equal to zero for no print).
* DEN density of each isotope.
* MIX mix number of each isotope (can be zero).
* IAPT resonant isotope index associated with isotope I. Mixed
* moderator if IAPT(I)=NIRES+1. Out-of-fuel isotope if
* IAPT(I)=0.
* IPHASE type of flux solution (=1 use a native flux solution door;
* =2 use collision probabilities).
* NGRP number of energy groups.
* IGRMIN first group where the self-shielding is applied.
* IGRMAX most thermal group where the self-shielding is applied.
* NBNRS number of correlated fuel regions. Note that NBNRS=max(IREX).
* IREX fuel region index assigned to each mixture. Equal to zero
* in non-resonant mixtures or in mixtures not used.
* TITR title.
* ICORR mutual resonance shielding flag (=1 to suppress the model
* in cases it is required in LIB operator).
* ISUBG type of self-shielding model (=1 use physical probability
* tables; =3 use original Ribon method; =4 use Ribon extended
* method).
* MAXST maximum number of fixed point iterations for the ST scattering
* source.
*
*Parameters: output
* GOLD Goldstein-Cohen parameters.
* UNGAR averaged flux unknowns.
* PHGAR averaged fluxes in correlated fuel regions.
* STGAR microscopic self-shielded total x-s.
* SFGAR microscopic self-shielded fission x-s.
* SSGAR microscopic self-shielded scattering x-s.
* S0GAR microscopic transfer scattering xs (isotope,secondary,
* primary).
* SAGAR microscopic self-shielded additional xs.
* SDGAR microscopic self-shielded delayed nu-sigf xs.
* SWGAR microscopic secondary slowing-down cross sections (ISUBG=4).
* ISMIN first secondary group indices.
* ISMAX last secondary group indices.
* MASKG energy group mask pointing on self-shielded groups.
* SIGGAR macroscopic x-s of the non-resonant isotopes in each mixture:
* (*,*,*,1) total; (*,*,*,2) transport correction;
* (*,*,*,3) P0 scattering; (*,*,*,4) flux times P0 scattering.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPTRK,IPLIB,IPLI0
INTEGER IFTRAK,NREG,NUN,NBMIX,NBISO,NIRES,NL,NED,NDEL,
1 ISONAM(3,NBISO),ISOBIS(3,NBISO),MAT(NREG),KEYFLX(NREG),IMPX,
2 MIX(NBISO),IAPT(NBISO),IPHASE,NGRP,IGRMIN,IGRMAX,NBNRS,
3 IREX(NBMIX),ICORR,ISUBG,MAXST
REAL VOL(NREG),DEN(NBISO),GOLD(NIRES,NGRP),UNGAR(NUN,NIRES,NGRP),
1 PHGAR(NBNRS,NIRES,NGRP),STGAR(NBNRS,NIRES,NGRP),
2 SFGAR(NBNRS,NIRES,NGRP),SSGAR(NBNRS,NIRES,NL,NGRP),
3 S0GAR(NBNRS,NIRES,NL,NGRP,NGRP),SAGAR(NBNRS,NIRES,NED,NGRP),
4 SDGAR(NBNRS,NIRES,NDEL,NGRP),SWGAR(NBNRS,NIRES,NGRP),
5 SIGGAR(NBMIX,0:NIRES,NGRP,4)
LOGICAL LEAKSW,MASKG(NGRP,NIRES)
CHARACTER HCAL*12,CDOOR*12,TITR*72
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) IPP,KPLIB,LPLIB,MPLIB,JPLI0,KPLI0
LOGICAL LRES,LLIB,LRIB
PARAMETER (MAXED=50,MAXNOR=12)
CHARACTER TEXT12*12,HVECT(MAXED)*8,CBDPNM*12,HSMG*131
*----
* ALLOCATABLE ARRAYS
*----
TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPPT1,IPISO1,IPISO2
INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK
INTEGER, ALLOCATABLE, DIMENSION(:,:) :: NOR,IPPT2,ISM,ISMIN,ISMAX
REAL, ALLOCATABLE, DIMENSION(:) :: GAS,GA1,VOLMER,DELTA,GOLD2
REAL, ALLOCATABLE, DIMENSION(:,:) :: GA2,CONR,XFLUX
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(IPPT1(NIRES))
ALLOCATE(NOR(NIRES,NGRP),IPPT2(NIRES,5),IWRK(NGRP),ISM(2,NL),
1 ISMIN(NL,NGRP),ISMAX(NL,NGRP))
ALLOCATE(XFLUX(NBNRS,MAXNOR),GAS(NGRP),GA1(NGRP),GA2(NGRP,NGRP),
1 CONR(NBNRS,NIRES),VOLMER(0:NBNRS),DELTA(NGRP))
ALLOCATE(IPISO1(NBISO),IPISO2(NBISO))
*
CALL KDRCPU(TK1)
DO 15 IG1=1,NGRP
DO 10 IL=1,NL
ISMIN(IL,IG1)=NGRP
ISMAX(IL,IG1)=1
10 CONTINUE
15 CONTINUE
DO 20 IRES=1,NIRES
NOR(IRES,1)=-1
20 CONTINUE
*
IF(NED.GT.0) THEN
IF(NED.GT.MAXED) CALL XABORT('USSFLU: INVALID VALUE OF MAXED.')
CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED,HVECT)
ENDIF
*
CALL LIBIPS(IPLIB,NBISO,IPISO1)
CALL LIBIPS(IPLI0,NBISO,IPISO2)
SIGGAR(:NBMIX,0:NIRES,:NGRP,:4)=0.0
DO 190 ISO=1,NBISO
IBM=MIX(ISO)
DO 30 I=1,NREG
IF(MAT(I).EQ.IBM) GO TO 35
30 CONTINUE
GO TO 190
35 IRES=IAPT(ISO)
DENN=DEN(ISO)
JRES=IRES
IF(IRES.EQ.NIRES+1) JRES=0
*----
* RECOVER INFINITE DILUTION OR SELF-SHIELDED CROSS SECTIONS AND
* COMPUTE OUT-OF-FUEL MACROSCOPIC CROSS SECTIONS.
*----
KPLI0=IPISO2(ISO) ! set ISO-th isotope
IF(C_ASSOCIATED(KPLI0)) THEN
CALL LCMLEN(KPLI0,'NTOT0',ILENGT,ITYLCM)
IF(ILENGT.NE.0) THEN
LLIB=.FALSE.
IPP=KPLI0
ELSE
LLIB=.TRUE.
IPP=IPISO1(ISO) ! set ISO-th isotope
ENDIF
ELSE
LLIB=.TRUE.
IPP=IPISO1(ISO) ! set ISO-th isotope
ENDIF
IF(LLIB.AND.(.NOT.C_ASSOCIATED(IPP))) THEN
WRITE(HSMG,'(18H USSFLU: ISOTOPE '',3A4,7H'' (ISO=,I8,5H) IS ,
1 39HNOT AVAILABLE IN THE ORIGINAL MICROLIB.)') (ISONAM(I0,ISO),
2 I0=1,3),ISO
CALL XABORT(HSMG)
ENDIF
IF((.NOT.LLIB).AND.(IMPX.GT.2)) WRITE(6,'(/18H USSFLU: RECOVER I,
1 8HSOTOPE '',3A4,23H'' FROM THE NEW LIBRARY.)') (ISOBIS(I0,ISO),
2 I0=1,3)
IF((DENN.NE.0.0).AND.(IBM.NE.0)) THEN
CALL LCMLEN(IPP,'NTOT0',ILENGT,ITYLCM)
IF(ILENGT.NE.NGRP) CALL XABORT('USSFLU: INVALID X-SECTIONS.')
CALL LCMGET(IPP,'NTOT0',GA1)
DO 40 IGRP=1,NGRP
SIGGAR(IBM,JRES,IGRP,1)=SIGGAR(IBM,JRES,IGRP,1)+DENN*GA1(IGRP)
40 CONTINUE
CALL LCMGET(IPP,'SIGS00',GA1)
CALL LCMLEN(IPP,'NWT0',ILENGT,ITYLCM)
IF(ILENGT.GT.0) THEN
CALL LCMGET(IPP,'NWT0',GAS)
ELSE
GAS(:NGRP)=1.0
ENDIF
DO 45 IGRP=1,NGRP
SIGGAR(IBM,JRES,IGRP,3)=SIGGAR(IBM,JRES,IGRP,3)+DENN*GA1(IGRP)
SIGGAR(IBM,JRES,IGRP,4)=SIGGAR(IBM,JRES,IGRP,4)+DENN*GA1(IGRP)*
1 GAS(IGRP)
45 CONTINUE
CALL LCMLEN(IPP,'TRANC',ILENGT,ITYLCM)
IF(ILENGT.GT.0) THEN
CALL LCMGET(IPP,'TRANC',GA1)
ELSE
GA1(:NGRP)=0.0
ENDIF
DO 50 IGRP=1,NGRP
SIGGAR(IBM,JRES,IGRP,2)=SIGGAR(IBM,JRES,IGRP,2)+DENN*GA1(IGRP)
50 CONTINUE
ENDIF
CALL LCMGET(IPLI0,'DELTAU',DELTA)
*----
* RECOVER PROBABILITY TABLE INFORMATION.
*----
IF((IRES.GT.0).AND.(IRES.LE.NIRES)) THEN
IF(NOR(IRES,1).EQ.-1) THEN
KPLIB=IPISO1(ISO) ! set ISO-th isotope
*
* RECOVER INFINITE DILUTION VALUES.
CALL LCMGET(KPLIB,'NTOT0',GAS)
DO 55 IG=1,NGRP
STGAR(:NBNRS,IRES,IG)=0.0
STGAR(:NBNRS,IRES,IG)=GAS(IG)
SFGAR(:NBNRS,IRES,IG)=0.0
SWGAR(:NBNRS,IRES,IG)=0.0
SAGAR(:NBNRS,IRES,:NED,IG)=0.0
SDGAR(:NBNRS,IRES,:NDEL,IG)=0.0
55 CONTINUE
CALL LCMLEN(KPLIB,'NUSIGF',ILENGT,ITYLCM)
IF(ILENGT.GT.0) THEN
CALL LCMGET(KPLIB,'NUSIGF',GAS)
DO 60 IG=1,NGRP
SFGAR(:NBNRS,IRES,IG)=GAS(IG)
60 CONTINUE
ENDIF
DO 80 IL=1,NL
CALL XDRLGS(KPLIB,-1,IMPX,IL-1,IL-1,1,NGRP,GAS,GA2,ITYPRO)
* JG IS THE SECONDARY GROUP.
DO 72 IG=1,NGRP
SSGAR(:NBNRS,IRES,IL,IG)=GAS(IG)
DO 70 JG=1,NGRP
IF(IL.EQ.1) THEN
SWGAR(:NBNRS,IRES,JG)=SWGAR(:NBNRS,IRES,JG)+GA2(JG,IG)*
1 DELTA(IG)
ENDIF
S0GAR(:NBNRS,IRES,IL,JG,IG)=GA2(JG,IG)
70 CONTINUE
72 CONTINUE
80 CONTINUE
DO 95 IG=1,NGRP
SWGAR(:NBNRS,IRES,IG)=SWGAR(:NBNRS,IRES,IG)/DELTA(IG)
95 CONTINUE
DO 110 IED=1,NED
CALL LCMLEN(KPLIB,HVECT(IED),ILENGT,ITYLCM)
IF(ILENGT.GT.0) THEN
CALL LCMGET(KPLIB,HVECT(IED),GAS)
DO 105 IG=1,NGRP
SAGAR(:NBNRS,IRES,IED,IG)=GAS(IG)
105 CONTINUE
ENDIF
110 CONTINUE
DO 130 IDEL=1,NDEL
WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
CALL LCMLEN(KPLIB,TEXT12,ILENGT,ITYLCM)
IF(ILENGT.GT.0) THEN
CALL LCMGET(KPLIB,TEXT12,GAS)
DO 125 IG=1,NGRP
SDGAR(:NBNRS,IRES,IDEL,IG)=GAS(IG)
125 CONTINUE
ENDIF
130 CONTINUE
*
GOLD(IRES,:NGRP)=1.0
NOR(IRES,:NGRP)=0
CALL LCMSIX(KPLIB,'PT-TABLE',1)
CALL LCMGET(KPLIB,'NOR',IWRK)
LPLIB=LCMGID(KPLIB,'GROUP-PT')
DO 150 IG1=1,NGRP
IF(IWRK(IG1).GT.1) THEN
MPLIB=LCMGIL(LPLIB,IG1)
CALL LCMGET(MPLIB,'ISM-LIMITS',ISM)
DO 140 IL=1,NL
ISMIN(IL,IG1)=MIN(ISMIN(IL,IG1),ISM(1,IL))
ISMAX(IL,IG1)=MAX(ISMAX(IL,IG1),ISM(2,IL))
140 CONTINUE
ENDIF
NOR(IRES,IG1)=IWRK(IG1)
150 CONTINUE
CALL LCMSIX(KPLIB,' ',2)
CALL LCMLEN(KPLIB,'NGOLD',ILENGT,ITYLCM)
IF(ILENGT.GT.0) THEN
ALLOCATE(GOLD2(NGRP))
CALL LCMGET(KPLIB,'NGOLD',GOLD2)
DO 160 IG1=1,NGRP
GOLD(IRES,IG1)=GOLD2(IG1)
160 CONTINUE
DEALLOCATE(GOLD2)
ENDIF
CALL LCMLEN(KPLIB,'BIN-NFS',ILENGT,ITYLCM)
IF(ILENGT.GT.0) THEN
CALL LCMGET(KPLIB,'BIN-NFS',IWRK)
DO 180 IG1=1,NGRP
IF((GOLD(IRES,IG1).LT.-900.).AND.(IWRK(IG1).EQ.0)) THEN
GOLD(IRES,IG1)=1.0
ENDIF
180 CONTINUE
ENDIF
ENDIF
ENDIF
190 CONTINUE
CALL KDRCPU(TK2)
IF(IMPX.GT.1) WRITE(6,'(/34H USSFLU: CPU TIME SPENT TO RECOVER,
1 23H INFINITE-DILUTION XS =,F8.1,8H SECOND./)') TK2-TK1
*
CALL KDRCPU(TK1)
TK4=0.0
TK5=0.0
ICPIJ=0
*----
* COMPUTE THE MERGED VOLUMES AND NUMBER DENSITIES.
*----
VOLMER(0:NBNRS)=0.0
DO 210 I=1,NREG
IBM=MAT(I)
IF(IBM.GT.0) VOLMER(IREX(IBM))=VOLMER(IREX(IBM))+VOL(I)
210 CONTINUE
CONR(:NBNRS,:NIRES)=0.0
DO 240 ISO=1,NBISO
JRES=IAPT(ISO)
IF((JRES.GT.0).AND.(JRES.LE.NIRES)) THEN
DENN=DEN(ISO)
DO 230 IREG=1,NREG
IBM=MAT(IREG)
IF(MIX(ISO).EQ.IBM) THEN
IND=IREX(IBM)
IF(IND.EQ.0) CALL XABORT('USSFLU: IREX FAILURE.')
CONR(IND,JRES)=CONR(IND,JRES)+DENN*VOL(IREG)/VOLMER(IND)
ENDIF
230 CONTINUE
ENDIF
240 CONTINUE
*----
* RECOVER POSITION OF PROBABILITY TABLES AND NAME OF RESONANT ISOTOPE.
*----
DO 270 IRES=1,NIRES
ISOT=0
DO 250 JSOT=1,NBISO
IF(IAPT(JSOT).EQ.IRES) THEN
ISOT=JSOT
GO TO 260
ENDIF
250 CONTINUE
CALL XABORT('USSFLU: UNABLE TO FIND A RESONANT ISOTOPE.')
260 KPLIB=IPISO1(ISOT) ! set ISOT-th isotope
CALL LCMLEN(KPLIB,'PT-TABLE',ILENGT,ITYLCM)
IF(ILENGT.EQ.0) CALL XABORT('USSFLU: BUG1.')
CALL LCMSIX(KPLIB,'PT-TABLE',1)
CALL LCMGET(KPLIB,'NDEL',NDEL0)
IF(NDEL0.GT.NDEL) CALL XABORT('USSFLU: NDEL OVERFLOW.')
CALL LCMLEN(KPLIB,'GROUP-PT',ILENGT,ITYLCM)
IF(ILENGT.EQ.0) CALL XABORT('USSFLU: BUG2.')
IPPT1(IRES)=KPLIB
CALL LCMSIX(KPLIB,' ',2)
IPPT2(IRES,1)=IREX(MIX(ISOT))
IPPT2(IRES,2)=ISONAM(1,ISOT)
IPPT2(IRES,3)=ISONAM(2,ISOT)
IPPT2(IRES,4)=ISONAM(3,ISOT)
IPPT2(IRES,5)=NDEL0
IF(IPPT2(IRES,1).LE.0) CALL XABORT('USSFLU: BUG3.')
270 CONTINUE
*----
* DETERMINE WHICH GROUPS ARE SELF-SHIELDED.
*----
DO 290 IGRP=1,NGRP
DO 280 IRES=1,NIRES
MASKG(IGRP,IRES)=((IGRP.GE.IGRMIN).AND.(IGRP.LE.IGRMAX).AND.
1 (NOR(IRES,IGRP).GT.1))
280 CONTINUE
290 CONTINUE
*----
* INITIALIZATION OF THE MULTIBAND FLUXES AND SOURCES.
*----
CALL LCMSIX(IPLI0,'SHIBA_SG',1)
CALL LCMSIX(IPLI0,HCAL,1)
DO 310 IRES=1,NIRES
WRITE(CBDPNM,'(3HCOR,I4.4,1H/,I4.4)') IRES,NIRES
CALL LCMSIX(IPLI0,CBDPNM,1)
JPLI0=LCMLID(IPLI0,'NWT0-PT',NGRP)
DO 300 IGRP=1,NGRP
IF(MASKG(IGRP,IRES)) THEN
CALL LCMLEL(JPLI0,IGRP,ILENGT1,ITYLCM)
IF(ILENGT1.EQ.0) THEN
NORI=NOR(IRES,IGRP)
XFLUX(:NBNRS,:NORI)=1.0
CALL LCMPDL(JPLI0,IGRP,NBNRS*NORI,2,XFLUX)
ENDIF
ENDIF
300 CONTINUE
CALL LCMSIX(IPLI0,' ',2)
310 CONTINUE
*
CALL KDRCPU(TKA)
*
DO 340 IRES=1,NIRES
LRIB=.FALSE.
DO 330 IGRP=1,NGRP
LRIB=LRIB.OR.(MASKG(IGRP,IRES).AND.(GOLD(IRES,IGRP).EQ.-999.))
IF(MASKG(IGRP,IRES)) ICPIJ=ICPIJ+NOR(IRES,IGRP)
330 CONTINUE
*----
* ITERATIVE APPROACH FOR THE HELIOS/WIMS-7 METHOD.
*----
CALL USSIT1(MAXNOR,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK,
1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW,
2 IREX,SIGGAR,TITR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,STGAR,
3 SSGAR,VOLMER,UNGAR)
*----
* ITERATIVE APPROACH FOR THE SUBGROUP PROJECTION METHOD.
*----
CALL USSIST(MAXNOR,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK,
1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAXST,MAT,VOL,KEYFLX,LEAKSW,
2 IREX,SIGGAR,TITR,ICORR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,
3 STGAR,SSGAR,VOLMER,UNGAR)
*----
* RESPONSE MATRIX APPROACH FOR THE RIBON EXTENDED METHOD.
*----
IF(LRIB) THEN
CALL USSIT0(MAXNOR,NGRP,MASKG(1,IRES),IRES,IPLI0,IPTRK,IFTRAK,
1 CDOOR,IMPX,NBMIX,NREG,NUN,NL,IPHASE,MAT,VOL,KEYFLX,LEAKSW,IREX,
2 SIGGAR,TITR,ICORR,NIRES,NBNRS,NOR,CONR,GOLD,IPPT1,IPPT2,STGAR,
3 SSGAR,SWGAR,VOLMER,UNGAR)
ENDIF
340 CONTINUE
CALL KDRCPU(TKB)
TK4=TK4+(TKB-TKA)
*----
* COMPUTE THE SELF-SHIELDED REACTION RATES.
*----
PHGAR(:NBNRS,:NIRES,:NGRP)=1.0
DO 360 IGRP=1,NGRP
LRES=.FALSE.
DO 345 IRES=1,NIRES
LRES=LRES.OR.MASKG(IGRP,IRES)
345 CONTINUE
IF(LRES) THEN
MAXXS=2+NL+NED+NDEL
DO 350 IL=1,NL
MAXXS=MAXXS+MAX(ISMAX(IL,IGRP)-ISMIN(IL,IGRP)+1,0)
350 CONTINUE
IF(ISUBG.EQ.4) MAXXS=MAXXS+1
CALL KDRCPU(TKA)
CALL USSIT2(MAXNOR,IPLI0,IGRP,NGRP,ISMIN(1,IGRP),ISMAX(1,IGRP),
1 NIRES,NBNRS,NL,NED,NDEL,NOR(1,IGRP),IPPT1,IPPT2,GOLD(1,IGRP),
2 MAXXS,ISUBG,PHGAR(1,1,IGRP),STGAR(1,1,IGRP),SFGAR(1,1,IGRP),
3 SSGAR(1,1,1,IGRP),S0GAR(1,1,1,1,IGRP),SAGAR(1,1,1,IGRP),
4 SDGAR(1,1,1,IGRP),SWGAR(1,1,IGRP))
CALL KDRCPU(TKB)
TK5=TK5+(TKB-TKA)
ENDIF
360 CONTINUE
* ***************************************************************
CALL LCMSIX(IPLI0,' ',2)
CALL LCMSIX(IPLI0,' ',2)
CALL LCMVAL(IPLI0,' ')
*----
* RESET MASKG FOR SPH CALCULATION IN SMALL LETHARGY WIDTH GROUPS.
*----
DO 380 IGRP=1,NGRP
DO 370 IRES=1,NIRES
IF(MASKG(IGRP,IRES)) THEN
LRES=((GOLD(IRES,IGRP).EQ.-998.).OR.(GOLD(IRES,IGRP).EQ.-1000.))
MASKG(IGRP,IRES)=.NOT.LRES
IF(DELTA(IGRP).GT.0.1) MASKG(IGRP,IRES)=.TRUE.
ENDIF
370 CONTINUE
380 CONTINUE
CALL KDRCPU(TK2)
IF(IMPX.GT.1) WRITE(6,'(/34H USSFLU: CPU TIME SPENT TO COMPUTE,
1 31H SELF-SHIELDED REACTION RATES =,F8.1,19H SECOND, INCLUDING:
2 /9X,F8.1,46H SECOND TO BUILD/SOLVE SUBGROUP MATRIX SYSTEM;/9X,
4 F8.1,38H SECOND TO COMPUTE THE REACTION RATES./9X,9HNUMBER OF,
5 23H ASSEMBLY DOORS CALLS =,I5,1H.)') TK2-TK1,TK4,TK5,ICPIJ
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(IPISO2,IPISO1)
DEALLOCATE(DELTA,VOLMER,CONR,GA2,GA1,GAS,XFLUX)
DEALLOCATE(ISMAX,ISMIN,ISM,IWRK,IPPT2,NOR)
DEALLOCATE(IPPT1)
RETURN
END
|
