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
|
*DECK LIBDI5
SUBROUTINE LIBDI5 (MAXDIL,NAMFIL,HSHI,NDIL,DILUT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Find the dilutions corresponding to a resonant isotope within a
* library in Apolib-2 format.
*
*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
* MAXDIL maximum number of dilutions.
* NAMFIL name of the APOLIB-2 file.
* HSHI library name of the self-shielding data.
*
*Parameters: output
* NDIL number of finite dilutions.
* DILUT dilutions.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER MAXDIL,NDIL
CHARACTER HSHI*12
CHARACTER NAMFIL*(*)
REAL DILUT(MAXDIL)
*----
* LOCAL VARIABLES
*----
EXTERNAL LIBA21
CHARACTER HSMG*131,TEXT8*8,TEXT20*20,NOMOBJ*20,TYPOBJ*8,TYPSEG*8
LOGICAL LISO,LPTHOM
INTEGER ISFICH(3)
INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,ITCARO
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 /
*----
* INDEX THE APOLIB-2 FILE.
*----
CALL AEXTPA(NAMFIL,ISFICH)
IADRES=ISFICH(1)
NBOBJ=ISFICH(2)
LBLOC=ISFICH(3)
NIN=KDROPN(NAMFIL,2,4,LBLOC)
IF(NIN.LE.0) THEN
WRITE (HSMG,'(35HLIBDI5: UNABLE TO OPEN LIBRARY FILE,1X,A16,
1 1H.)') NAMFIL
CALL XABORT(HSMG)
ENDIF
ALLOCATE(VINTE(2*NBOBJ))
CALL AEXDIR(NIN,LBLOC,VINTE,IADRES,2*NBOBJ)
IDKNO=1-TKCARO(14)
IDKTY=1-TKCARO(21)
IDKDS=1-TKCARO(10)
IDKTS=1-TKCARO(23)
IDKDA=1-TKCARO(26)
IDKNS=TKCARO(2)+1
IDKLS=TKCARO(8)
*
TEXT20='SSDATA'//HSHI
LISO=.FALSE.
DO 70 I=3,NBOBJ
IDKOBJ=VINTE(2*I-1)
LGSEG=VINTE(2*I)+1
ALLOCATE(ITCARO(LGSEG))
CALL AEXDIR(NIN,LBLOC,ITCARO,IDKOBJ,LGSEG)
IDK=ITCARO(IDKNO)
CALL AEXCPC(IDK,20,ITCARO,NOMOBJ)
IDK=ITCARO(IDKTY)
CALL AEXCPC(IDK,8,ITCARO,TYPOBJ)
JDKDS=ITCARO(IDKDS)
JDKTS=ITCARO(IDKTS)
NS=ITCARO(IDKNS)
IDK=ITCARO(IDKDA)
CALL AEXCPC(IDK,8,ITCARO,TEXT8)
IF((TYPOBJ.EQ.'APOLIBE').AND.(NOMOBJ.EQ.TEXT20)) THEN
LISO=.TRUE.
LPTHOM=.FALSE.
DO 60 IS=1,NS
IDK=JDKTS+8*(IS-1)
CALL AEXCPC(IDK,8,ITCARO,TYPSEG)
LNGS=ITCARO(IDKLS+IS)
IF(LNGS.LE.0) GO TO 60
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(LNGS+1)
CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
CALL AEXDIR(NIN,LBLOC,ITSEGM,JDKS,LNGS+1)
IF(TYPSEG.EQ.'PTHOM1') THEN
CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
LPTHOM=.TRUE.
CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSEQHO)
NDIL=NSEQHO-1
IF(NDIL.GT.MAXDIL) CALL XABORT('LIBDI5: INVALID MAXDIL.')
DILMAX=RTSEGM(IDK+NSEQHO-1)
IF(DILMAX.LT.1.0E10) THEN
WRITE(HSMG,'(35HLIBDI5: INVALID INFINITE DILUTION (,1P,
1 E12.4,14H) FOR ISOTOPE ,A12,1H.)') DILMAX,HSHI
CALL XABORT(HSMG)
ENDIF
DO 50 J=1,NSEQHO
DILUT(J)=RTSEGM(IDK+J-1)
50 CONTINUE
ENDIF
CALL LCMDRD(TSEGM_PTR)
CALL LCMDRD(ICHDIM_PTR)
CALL LCMDRD(ICHTYP_PTR)
CALL LCMDRD(ICHDKL_PTR)
60 CONTINUE
IF(.NOT.LPTHOM) CALL XABORT('LIBDI5: NO PTHOM1 SEGMENT '
1 //'FOR ISOTOPE '//HSHI//'.')
ENDIF
DEALLOCATE(ITCARO)
70 CONTINUE
DEALLOCATE(VINTE)
IF(.NOT.LISO) CALL XABORT('LIBDI5: UNABLE TO FIND ISOTOPE '
1 //HSHI//'.')
IER=KDRCLS(NIN,1)
IF(IER.LT.0) THEN
WRITE (HSMG,'(36HLIBDI5: UNABLE TO CLOSE LIBRARY FILE,1X,A16,
1 1H.)') NAMFIL
CALL XABORT(HSMG)
ENDIF
RETURN
END
|
