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
|
*DECK LIBXS2
SUBROUTINE LIBXS2(CFILNA,MAXR,NEL,NMDEPL,ITNAM,ITZEA,KPAX,BPAX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Read depletion data on an APOLIB-XSM formatted library.
*
*Copyright:
* Copyright (C) 2014 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
* CFILNA APOLIB-XSM file name.
* MAXR number of reaction types.
* NEL number of isotopes on library.
* NMDEPL names of reactions:
* NMDEPL(1)='DECAY'; NMDEPL(2)='NFTOT';
* NMDEPL(3)='NG' ; NMDEPL(4)='N2N';
* etc.
*
*Parameters: output
* ITNAM reactive isotope names in chain.
* ITZEA 6-digit nuclide identifier:
* atomic number z*10000 (digits) + mass number a*10 +
* energy state (0 = ground state, 1 = first state, etc.).
* KPAX complete reaction type matrix.
* BPAX complete branching ratio matrix.
*
*Comments:
* INPUT FORMAT
* LIB: APLIB2 FIL: CFILNA CHAIN
* [[ hnamson
* [ FROM [[ { DECAY | reaction } yield hnampar ]] ]
* ]]
* ENDCHAIN
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
CHARACTER CFILNA*(*),NMDEPL(MAXR)*8
INTEGER MAXR,NEL,ITNAM(3,NEL),ITZEA(NEL),KPAX(NEL+MAXR,NEL)
REAL BPAX(NEL+MAXR,NEL)
*
TYPE(C_PTR) IPAP
PARAMETER (IOUT=6)
CHARACTER TEXT20*20,TEXT12*12,HNISOR*20,HITNAM*20,HSMG*131
DOUBLE PRECISION DBLINP
REAL E458(9)
*----
* SCRATCH STORAGE ALLOCATION
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: NOM,IA,IZ,NFG,IKEEP
REAL, ALLOCATABLE, DIMENSION(:) :: GAMMA,RTSEGM
CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HSECTT
*----
* OPEN APOLIB FILE
*----
CALL LCMOP(IPAP,CFILNA,2,2,0)
*----
* RECOVER INFORMATION FROM PHEAD DIRECTORY
*----
CALL LCMSIX(IPAP,'PHEAD',1)
CALL LCMLEN(IPAP,'NOM',NV,ITYLCM)
NISOT=NV/5
ALLOCATE(NOM(5*NISOT))
CALL LCMGET(IPAP,'NOM',NOM)
DO 20 ISO=1,NISOT
WRITE(HNISOR,'(5A4)') (NOM((ISO-1)*5+II),II=1,5)
READ(HNISOR,'(3A4)') (ITNAM(II,ISO),II=1,3)
20 CONTINUE
CALL LCMSIX(IPAP,' ',2)
*----
* RECOVER INFORMATION FROM PCONST DIRECTORY
*----
CALL LCMSIX(IPAP,'PCONST',1)
CALL LCMLIB(IPAP)
CALL LCMLEN(IPAP,'A',NV,ITYLCM)
IF(NV.NE.NISOT) CALL XABORT('LIBXS2: IA OVERFLOW')
ALLOCATE(IA(NISOT),IZ(NISOT),NFG(NISOT))
CALL LCMGET(IPAP,'A',IA)
CALL LCMGET(IPAP,'Z',IZ)
CALL LCMGET(IPAP,'NFG',NFG)
CALL LCMSIX(IPAP,' ',2)
*----
* RECOVER INFORMATION FROM PNUMF DIRECTORY
*----
CALL LCMSIX(IPAP,'PNUMF',1)
CALL LCMLEN(IPAP,'GAMMA',NGAMMA,ITYLCM)
CALL LCMLEN(IPAP,'NOMFIS',NBFISS,ITYLCM)
CALL LCMLEN(IPAP,'NOMPF',NBPF,ITYLCM)
NBFISS=NBFISS/2
NBPF=NBPF/2
ALLOCATE(GAMMA(NGAMMA))
CALL LCMGET(IPAP,'GAMMA',GAMMA)
NMGY=NGAMMA/(NBFISS*NBPF)
CALL LCMSIX(IPAP,' ',2)
*----
* LOOP OVER ISOTOPES
*----
CALL LCMSIX(IPAP,'QFIX',1)
DO 260 ISO=1,NISOT
WRITE(HNISOR,'(5A4)') (NOM((ISO-1)*5+II),II=1,5)
WRITE(TEXT12,'(4HISOT,I8.8)') ISO
CALL LCMSIX(IPAP,TEXT12,1)
CALL LCMSIX(IPAP,'ISOTOP',1)
* NG ENERGY.
CALL LCMLEN(IPAP,'EGAMM',NV,ITYLCM)
IF(NV.NE.0) THEN
KPAX(NEL+3,ISO)=1
CALL LCMGET(IPAP,'EGAMM',BPAX(NEL+3,ISO))
ENDIF
* FISSION ENERGIES.
CALL LCMLEN(IPAP,'EF',NV,ITYLCM)
IF(NV.NE.0) THEN
KPAX(NEL+2,ISO)=1
CALL LCMGET(IPAP,'EF',BPAX(NEL+2,ISO))
ENDIF
CALL LCMLEN(IPAP,'ENER_458',NV,ITYLCM)
IF(NV.NE.0) THEN
KPAX(NEL+2,ISO)=1
CALL LCMGET(IPAP,'ENER_458',E458)
BPAX(NEL+2,ISO)=E458(8)
ENDIF
* RADIOACTIVE DECAY CONSTANTS.
CALL LCMLEN(IPAP,'LAMBD0',NCHANN,ITYLCM)
IF(NCHANN.GT.0) THEN
ALLOCATE(RTSEGM(NCHANN))
CALL LCMGET(IPAP,'LAMBD0',RTSEGM)
SUM=0.0
DO 140 I=1,NCHANN
SUM=SUM+RTSEGM(I)
140 CONTINUE
DEALLOCATE(RTSEGM)
IF(SUM.NE.0.0) BPAX(NEL+1,ISO)=SUM*1.0E8
ENDIF
* X-S NAMES.
CALL LCMLEN(IPAP,'TYSECT',NV,ITYLCM)
NSECTT=NV/2
ALLOCATE(HSECTT(NSECTT))
CALL LCMGTC(IPAP,'TYSECT',8,NSECTT,HSECTT)
DO 150 IS=1,NSECTT
IF(HSECTT(IS).EQ.'SIGA') THEN
KPAX(NEL+3,ISO)=1
ELSE IF(HSECTT(IS).EQ.'NEXCESS') THEN
KPAX(NEL+4,ISO)=1
ELSE IF(HSECTT(IS).EQ.'SIGF') THEN
KPAX(NEL+2,ISO)=1
ELSE IF(HSECTT(IS).EQ.'CREA-A') THEN
KPAX(NEL+7,ISO)=1
ELSE IF(HSECTT(IS).EQ.'CREA-P') THEN
KPAX(NEL+8,ISO)=1
ELSE IF(HSECTT(IS).EQ.'CREA-H2') THEN
KPAX(NEL+11,ISO)=1
ELSE IF(HSECTT(IS).EQ.'CREA-H3') THEN
KPAX(NEL+12,ISO)=1
ENDIF
150 CONTINUE
DEALLOCATE(HSECTT)
*----
* SET OTHER INFORMATION.
*----
ITZEA(ISO)=IZ(ISO)*10000+IA(ISO)*10
IPF=NFG(ISO)
IF(IPF.LT.0) THEN
KPAX(NEL+2,ISO)=-1
DO 250 JSO=1,NISOT
IFI=NFG(JSO)
IF(IFI.GT.0) THEN
IOFSET=((-IPF-1)*NBFISS+(IFI-1))*NMGY+NMGY
IF(IOFSET.GT.NGAMMA) CALL XABORT('LIBXS2: GAMMA OVERFLOW.')
BPAX(ISO,JSO)=GAMMA(IOFSET)
IF(BPAX(ISO,JSO).NE.0.0) KPAX(ISO,JSO)=2
ENDIF
250 CONTINUE
ENDIF
CALL LCMSIX(IPAP,' ',2)
CALL LCMSIX(IPAP,' ',2)
260 CONTINUE
CALL LCMSIX(IPAP,' ',2)
*
DEALLOCATE(GAMMA,NFG,IZ,IA,NOM)
CALL LCMCL(IPAP,1)
*----
* RECOVER INFORMATION FROM INPUT DATA STREAM.
*----
ALLOCATE(IKEEP(NEL))
IKEEP(:NEL)=0
TEXT12=' '
CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
IF(INDIC.NE.3.OR.TEXT12.NE.'CHAIN')
> CALL XABORT('LIBXS2: KEYWORD CHAIN MISSING')
CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
DO 340 IEL=1,NEL
IF(TEXT12.EQ.'ENDCHAIN') GO TO 350
IF(INDIC.NE.3) CALL XABORT('LIBXS2: ISOTOPE NAME hnamson MISSING')
I1=INDEX(TEXT12,'_')
HNISOR=' '
IF(I1.EQ.0) THEN
HNISOR(:12)=TEXT12
ELSE
HNISOR(:I1-1)=TEXT12(:I1-1)
ENDIF
IDEPL=0
DO 270 JEL=1,NEL
WRITE(TEXT12,'(3A4)') (ITNAM(II,JEL),II=1,3)
I1=INDEX(TEXT12,'_')
HITNAM=' '
IF(I1.EQ.0) THEN
HITNAM(:12)=TEXT12
ELSE
HITNAM(:I1-1)=TEXT12(:I1-1)
ENDIF
IF(HNISOR.EQ.HITNAM) THEN
IDEPL=JEL
GO TO 280
ENDIF
270 CONTINUE
WRITE(HSMG,'(25HLIBXS2: MISSING ISOTOPE '',A12,5H''(1).)')
> HNISOR
CALL XABORT(HSMG)
280 IKEEP(IDEPL)=1
IF(BPAX(NEL+1,IDEPL).NE.0.0) KPAX(NEL+1,IDEPL)=1
CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
IF(INDIC.NE.3) CALL XABORT('LIBXS2: REACTION TYPE EXPECTED')
IF(TEXT12.EQ.'FROM') THEN
CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DBLINP)
290 IF(INDIC.NE.3) CALL XABORT('LIBXS2: REACTION TYPE EXPECTED')
DO 330 IREAC=1,MAXR
RRAT=1.0
IF(TEXT12.EQ.NMDEPL(IREAC)) THEN
DO 320 JEL=1,NEL
CALL REDGET(INDIC,ISOT,RRAT,TEXT12,DBLINP)
IF(INDIC.NE.2) GO TO 290
CALL REDGET(INDIC,ISOT,FLOTT,TEXT12,DBLINP)
IF(INDIC.NE.3) CALL XABORT('LIBXS2: ISOTOPE NAME HNAMPAR '
> //'MISSING')
I1=INDEX(TEXT12,'_')
TEXT20=' '
IF(I1.EQ.0) THEN
TEXT20(:12)=TEXT12
ELSE
TEXT20(:I1-1)=TEXT12(:I1-1)
ENDIF
JDEPL=0
DO 300 JREL=1,NEL
WRITE(TEXT12,'(3A4)') (ITNAM(II,JREL),II=1,3)
I1=INDEX(TEXT12,'_')
HITNAM=' '
IF(I1.EQ.0) THEN
HITNAM(:12)=TEXT12
ELSE
HITNAM(:I1-1)=TEXT12(:I1-1)
ENDIF
IF(TEXT20.EQ.HITNAM) THEN
JDEPL=JREL
GO TO 310
ENDIF
300 CONTINUE
WRITE(HSMG,'(25HLIBXS2: MISSING ISOTOPE '',A12,5H''(2).)')
> TEXT20
CALL XABORT(HSMG)
310 KPAX(IDEPL,JDEPL)=IREAC
BPAX(IDEPL,JDEPL)=RRAT
320 CONTINUE
CALL XABORT('LIBXS2: TO MANY PARENT ISOTOPES')
ENDIF
330 CONTINUE
ENDIF
340 CONTINUE
IF(INDIC.NE.3.OR.TEXT12.NE.'ENDCHAIN')
> CALL XABORT('LIBXS2: KEYWORD ENDCHAIN MISSING')
350 DO 380 JEL=1,NEL
IF(IKEEP(JEL).EQ.0) THEN
DO 360 IREAC=1,NEL+MAXR
KPAX(IREAC,JEL)=0
360 CONTINUE
DO 370 IEL=1,NEL
KPAX(JEL,IEL)=0
370 CONTINUE
ENDIF
380 CONTINUE
DEALLOCATE(IKEEP)
RETURN
END
|
