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
|
*DECK LIBEAQ
SUBROUTINE LIBEAQ(CFILNA,NEL,IMPX,QQNG,QQF)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover Q and pseudo-Q values from an APOLIB2 file.
*
*Copyright:
* Copyright (C) 2025 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-2 file name.
* NEL number of isotopes on library.
* IMPX print flag.
*
*Parameters: output
* QQNG radiative capture Q value.
* QQF fission pseudo Q value.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
CHARACTER CFILNA*(*)
INTEGER NEL,IMPX
REAL QQNG(NEL),QQF(NEL)
*----
* LOCAL VARIABLES
*----
EXTERNAL LIBA21
INTEGER ISFICH(3),NITCA(5)
PARAMETER (IOUT=6)
CHARACTER TEXT20*20,NOMOBJ*20,TEXT12*12,TEXT16*16,TYPOBJ*8,
> TYPSEG*8,HNISOR*20,HSMG*131
LOGICAL LPHEAD,LPCONS,LPFIX
*----
* SCRATCH STORAGE ALLOCATION
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,NOMOB,KDS,LGS,ITCARO,
1 NOM
TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR
INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM
REAL, POINTER, DIMENSION(:) :: RTSEGM
*
INTEGER TKCARO(31)
SAVE TKCARO
DATA TKCARO /
& 0, 1, 2, 3, 4, 5, 6, 30, 7, -8,
& 9, -10, 11, -12, 13, -14, 15, 16, -17, 18,
& -19, 20, -21, 22, 23, -24, 25, -26, 27, -28,
& 29 /
*----
* OPEN AND PROBE THE APOLIB-2 FILE.
*----
CALL AEXTPA(CFILNA,ISFICH)
IADRES=ISFICH(1)
NBOBJ=ISFICH(2)
LBLOC=ISFICH(3)
IUNIT=KDROPN(CFILNA,2,4,LBLOC)
IF(IUNIT.LE.0) THEN
TEXT12=CFILNA
CALL XABORT('LIBEAQ: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
1 'E OPENED')
ENDIF
*----
* INDEX THE APOLIB-2 FILE.
*----
ALLOCATE(VINTE(2*NBOBJ))
CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ)
IDKNO=1-TKCARO(14)
IDKTY=1-TKCARO(21)
IDKDS=1-TKCARO(10)
IDKTS=1-TKCARO(23)
IDKNS=TKCARO(2)+1
IDKLS=TKCARO(8)
*
NSEGM=0
NMGY=0
NISOT=0
ALLOCATE(NOMOB(5*(NBOBJ-3)),KDS(NBOBJ-3),LGS(NBOBJ-3))
LPHEAD=.FALSE.
LPCONS=.FALSE.
DO 80 IOBJ=3,NBOBJ
IDKOBJ=VINTE(2*IOBJ-1)
LGSEG=VINTE(2*IOBJ)+1
ALLOCATE(ITCARO(LGSEG))
CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
IDK=ITCARO(IDKNO)
CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
IDK=ITCARO(IDKTY)
CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
JDKDS=ITCARO(IDKDS)
JDKTS=ITCARO(IDKTS)
NS=ITCARO(IDKNS)
IF(TYPOBJ.EQ.'APOLIB') THEN
DO 70 IS=1,NS
IDK=JDKTS+8*(IS-1)
CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
LTESTS=ITCARO(IDKLS+IS)
IF(LTESTS.LE.0) GO TO 70
JDKS=ITCARO(JDKDS+IS)
CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
1 ICHDKL_PTR)
CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
TSEGM_PTR=LCMARA(LTESTS+1)
CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /))
CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /))
CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1)
IF(TYPSEG.EQ.'PHEAD') THEN
LPHEAD=.TRUE.
CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,
1 ICHDKL,IDK,NV)
IF(NV.EQ.0) THEN
TEXT12=CFILNA
CALL XABORT('LIBEAQ: NO ISOTOPES PRESENT ON APOLIB-2 '//
1 'FILE NAMED: '//TEXT12)
ENDIF
NISOT=NV/20
IF(NISOT.NE.NEL) CALL XABORT('LIBEAQ: INVALID NEL.')
ALLOCATE(NOM(5*NISOT))
DO 20 ISO=1,NISOT
ISO2=(ISO-1)*5+1
CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),HNISOR)
CALL LCMCAR(HNISOR,.TRUE.,NOM(ISO2))
20 CONTINUE
ENDIF
CALL LCMDRD(TSEGM_PTR)
CALL LCMDRD(ICHDIM_PTR)
CALL LCMDRD(ICHTYP_PTR)
CALL LCMDRD(ICHDKL_PTR)
70 CONTINUE
ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN
NSEGM=NSEGM+1
ISO2=(NSEGM-1)*5+1
CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2))
KDS(NSEGM)=IDKOBJ
LGS(NSEGM)=LGSEG
ELSE
CALL XABORT('LIBEAQ: WEIRD SEGMENT TYPE: '//TYPOBJ//' (1).')
ENDIF
DEALLOCATE(ITCARO)
80 CONTINUE
IF(.NOT.LPHEAD) CALL XABORT('LIBEAQ: PHEAD SEGMENT NOT FOUND.')
DEALLOCATE(VINTE)
*----
* SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES.
*----
IF(IMPX.GT.2) WRITE(IOUT,'(/16H LIBEAQ: ISOTOPE,12X,4HQ-NG,9X,
1 9HQ-FISSION)')
KISEG2=0
DO 260 ISO=1,NISOT
ISO2=(ISO-1)*5+1
CALL LCMCAR(TEXT16,.FALSE.,NOM(ISO2))
TEXT20='ISOTOP'//TEXT16(:14)
CALL LCMCAR(TEXT20,.TRUE.,NITCA(1))
DO 90 ISEG=1,NSEGM
ISEG2=(ISEG-1)*5+1
IF(NITCA(1).EQ.NOMOB(ISEG2)) THEN
IF(NITCA(2).EQ.NOMOB(ISEG2+1)) THEN
IF(NITCA(3).EQ.NOMOB(ISEG2+2)) THEN
IF(NITCA(4).EQ.NOMOB(ISEG2+3)) THEN
IF(NITCA(5).EQ.NOMOB(ISEG2+4)) THEN
KISEG2=ISEG
GO TO 120
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
90 CONTINUE
WRITE (HSMG,500) HNISOR,CFILNA
CALL XABORT(HSMG)
*----
* ACTIVATION OF CORRESPONDING 'ISOTOP'//NAME SEGMENT.
*----
120 IDKOBJ=KDS(KISEG2)
LGSEG=LGS(KISEG2)
ALLOCATE(ITCARO(LGSEG))
CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
IDK=ITCARO(IDKNO)
CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
IDK=ITCARO(IDKTY)
CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
JDKDS=ITCARO(IDKDS)
JDKTS=ITCARO(IDKTS)
NS=ITCARO(IDKNS)
*----
* RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION.
*----
LPFIX=.FALSE.
DO 160 IS=1,NS
IDK=JDKTS+8*(IS-1)
CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
LTESTS=ITCARO(IDKLS+IS)
IF(LTESTS.LE.0) GO TO 160
JDKS=ITCARO(JDKDS+IS)
CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR)
CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
TSEGM_PTR=LCMARA(LTESTS+1)
CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /))
CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /))
CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1)
*----
* RECOVER Q VALUES.
*----
IF(TYPSEG.EQ.'PFIX') THEN
LPFIX=.TRUE.
* NG ENERGY.
CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
IF(NV.NE.0) THEN
IF(RTSEGM(IDK).NE.0.0) QQNG(ISO)=RTSEGM(IDK)
ENDIF
* FISSION ENERGIES.
CALL AEXGNV(20,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NMGEF)
IF(NMGEF.NE.0) THEN
IF(RTSEGM(IDK+NMGEF-1).NE.0.0) QQF(ISO)=RTSEGM(IDK+NMGEF-1)
ENDIF
ENDIF
CALL LCMDRD(TSEGM_PTR)
CALL LCMDRD(ICHDIM_PTR)
CALL LCMDRD(ICHTYP_PTR)
CALL LCMDRD(ICHDKL_PTR)
160 CONTINUE
IF(.NOT.LPFIX) CALL XABORT('LIBEAQ: NO PFIX SEGMENT.')
DEALLOCATE(ITCARO)
IF(IMPX.GT.2) WRITE(IOUT,'(9X,A16,1P,2E13.4)') TEXT16,
1 QQNG(ISO),QQF(ISO)
260 CONTINUE
*
DEALLOCATE(LGS,KDS,NOMOB,NOM)
IERR=KDRCLS(IUNIT,1)
IF(IERR.LT.0) THEN
TEXT12=CFILNA
CALL XABORT('LIBEAQ: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
1 'E CLOSED')
ENDIF
RETURN
*
500 FORMAT(26HLIBEAQ: MATERIAL/ISOTOPE ',A20,20H' IS MISSING ON APOL,
> 15HIB-2 FILE NAME ,A12,1H.)
END
|
