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
|
*DECK LIBA26
SUBROUTINE LIBA26(LGSEG,IG,NGBIN,IUNIT,LBLOC,TKCARO,TCAROB,NSIGF,
1 TT,NTEMPS,TEMPS,DELTF,SIGTF,SIGAF,DELINF,SGTINF,SGAINF)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Temperature interpolation of autolib (bin cross sections) information.
*
*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
* LGSEG dimension of the directory block.
* IG coarse energy group under consideration.
* NGBIN number of coarse energy groups.
* IUNIT APOLIB-2 file unit number.
* LBLOC number of words in the direct access buffer.
* TKCARO index array used to parse tcarob.
* TCAROB directory block.
* NSIGF number of fine energy groups.
* TT temperature of isotope.
* NTEMPS number of tabulated temperatures.
* TEMPS tabulated temperatures.
*
*Parameters: output
* DELTF fine group lethargy widths.
* SIGTF fine group total x-s.
* SIGAF fine group absorption x-s.
* DELINF calculated lethargy width for group IG.
* SGTINF calculated infinite-dilution total x-s for group IG.
* SGAINF calculated infinite-dilution absorption x-s for group IG.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER LGSEG,TKCARO(31),TCAROB(LGSEG),IG,NGBIN,IUNIT,LBLOC,NSIGF,
1 NTEMPS
REAL TT,TEMPS(NTEMPS),DELTF(NSIGF),SIGTF(NSIGF),SIGAF(NSIGF),
1 DELINF,SGTINF,SGAINF
*----
* LOCAL VARIABLES
*----
EXTERNAL LIBA21
CHARACTER HSMG*131,TYPSEG*8
PARAMETER (NINT=2,DTMIN=1.0)
DOUBLE PRECISION D1,D2,D3
LOGICAL LOK
TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR
INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM
REAL, POINTER, DIMENSION(:) :: RTSEGM
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SQRTEM,WEIJHT
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(WEIJHT(NTEMPS),SQRTEM(NTEMPS))
*----
* COMPUTE THE WEIGHTS.
*----
DO 10 I=1,NTEMPS
SQRTEM(I)=SQRT(TEMPS(I))
10 CONTINUE
IF(NTEMPS.EQ.1) THEN
IPROX=1
IGTFIX=1
ELSE
STT=SQRT(TT)
CALL LIBA28(STT,SQRTEM,NTEMPS,NINT,WEIJHT,IORD,IPROX,I0)
IF(ABS(TT-TEMPS(IPROX)).LE.DTMIN) THEN
IGTFIX=1
ELSEIF((STT.LT.SQRTEM(1)).OR.(STT.GT.SQRTEM(NTEMPS))) THEN
WRITE(HSMG,'(A,F8.2,A,F8.2,A,F8.2)')
1 'LIBA26: A TEMPSERATURE', TT,'K IS NOT INCLUDED BETWEEN ',
2 TEMPS(1),' AND ',TEMPS(NTEMPS)
WRITE(6,'(/1X,A)') HSMG
IGTFIX=2
ELSE
IGTFIX=0
ENDIF
ENDIF
*----
* LOOP OVER TABULATED TEMPERATURES.
*----
D1=0.0D0
IDKDS=1-TKCARO(10)
IDKTS=1-TKCARO(23)
IDKLS=TKCARO(8)
JDKDS=TCAROB(IDKDS)
JDKTS=TCAROB(IDKTS)
SIGTF(:NSIGF)=0.0
SIGAF(:NSIGF)=0.0
DO 50 J=1,IORD
IT=I0+J
IS=(IT-1)*NGBIN+IG
IDK=JDKTS+8*(IS-1)
CALL AEXCPC(IDK,8,TCAROB,TYPSEG)
LNGS=TCAROB(IDKLS+IS)
IF(LNGS.LE.0) CALL XABORT('LIBA26: INVALID PTHOM5(1).')
JDKS=TCAROB(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(LNGS+1)
CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /))
CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /))
CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LNGS+1)
CALL AEXGNV(1,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDD,NV)
IF(NV.NE.NSIGF) CALL XABORT('LIBA26: INVALID PTHOM5(2).')
CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDT,NV)
CALL AEXGNV(5,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDA,NV)
CALL LCMDRD(ICHDIM_PTR)
CALL LCMDRD(ICHTYP_PTR)
CALL LCMDRD(ICHDKL_PTR)
IF(IT.EQ.I0+1) THEN
D1=0.0D0
DO 20 I=1,NSIGF
DELTF(I)=RTSEGM(IDD+I-1)
D1=D1+DELTF(I)
20 CONTINUE
ELSE
LOK=.TRUE.
DO 30 I=1,NSIGF
LOK=LOK.AND.(DELTF(I).EQ.RTSEGM(IDD+I-1))
30 CONTINUE
IF(.NOT.LOK) CALL XABORT('LIBA26: INVALID AUTOLIB MESH.')
ENDIF
DO 40 I=1,NSIGF
SIGTF(I)=SIGTF(I)+REAL(WEIJHT(J)*RTSEGM(IDT+I-1))
SIGAF(I)=SIGAF(I)+REAL(WEIJHT(J)*RTSEGM(IDA+I-1))
40 CONTINUE
CALL LCMDRD(TSEGM_PTR)
50 CONTINUE
D2=0.0D0
D3=0.0D0
DO 60 I=1,NSIGF
SIGTF(I)=MAX(SIGTF(I),0.0)
SIGAF(I)=MAX(SIGAF(I),0.0)
D2=D2+SIGTF(I)*DELTF(I)
D3=D3+SIGAF(I)*DELTF(I)
60 CONTINUE
DELINF=REAL(D1)
SGTINF=REAL(D2/D1)
SGAINF=REAL(D3/D1)
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(SQRTEM,WEIJHT)
RETURN
END
|
