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
|
*DECK CPOMAW
SUBROUTINE CPOMAW(IPCPO ,IPRINT,NGROUP,NL ,NPROC ,INDPRO,
> ITYPRO,DXSMAC,DSCMAC,DXSREM,DSCREM,DISFC ,
> DMJMAC,IFCDIS,DISFAC)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Put macroscopic cross section on Compo.
*
*Copyright:
* Copyright (C) 2007 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): G. Marleau
*
*Parameters: input
* IPCPO pointer to the Compo.
* IPRINT print parameter. Equal to zero for no print.
* NGROUP number of groups condensed.
* NL number of Legendre orders.
* NPROC number of microscopic xs to process.
* INDPRO identifier for xs processing.
* ITYPRO identifier for xs processed .
* DXSMAC macroscopic averaged region/group x-s.
* DSCMAC macroscopic scattering.
* DXSREM removed averaged region/group x-s.
* DSCREM removed scattering rates.
* DISFC disadvantage factor.
* DMJMAC energy.
* IFCDIS discontinuity factor present (1) or absent.
* DISFAC discontinuity factors.
*
*-----------------------------------------------------------------------
*
USE GANLIB
IMPLICIT NONE
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPCPO
INTEGER IPRINT,NGROUP,NL,NPROC,INDPRO(NPROC),
> ITYPRO(NPROC)
REAL DISFC(NGROUP)
DOUBLE PRECISION DXSMAC(NGROUP,NPROC),
> DSCMAC(NGROUP,NGROUP,NL),
> DXSREM(NGROUP,NPROC),
> DSCREM(NGROUP,NGROUP,NL),
> DMJMAC
INTEGER IFCDIS
DOUBLE PRECISION DISFAC(2,NGROUP,3)
*----
* LOCAL PARAMETERS
*----
INTEGER NDPROC
REAL CUTOFF
PARAMETER (NDPROC=20,CUTOFF=1.0E-7)
INTEGER IXSR,JXSR,KXSR,IL,IGR,JGR,IORD
REAL CUTLIM
DOUBLE PRECISION DNUFI,DNUFT
*----
* ALLOCATABLE ARRAYS
* XSREC micro vector xs
* XSCAT compress scattering data
* DISTMP temporary storage for discontinuity factors
*----
REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC,DISTMP
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL),
> DISTMP(2,NGROUP))
*----
* SAVE AVERAGE XS
*----
ITYPRO(:NPROC)=1
CALL LCMSIX(IPCPO,'MACR',1)
XSREC(:NGROUP,:NPROC)=0.0
XSCAT(:NGROUP,:NGROUP,:NL)=0.0
DO 100 IXSR=1,4
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 101 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR))
CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF)
IF(XSREC(IGR,IXSR).LT.CUTLIM) XSREC(IGR,IXSR)=0.0
101 CONTINUE
ENDIF
100 CONTINUE
IXSR=5
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
JXSR=3
KXSR=16
DNUFI=0.0D0
DNUFT=0.0D0
DO 120 IGR=1,NGROUP
DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR)
DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR))
> *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR))
120 CONTINUE
CUTLIM=ABS(REAL(DNUFT)*CUTOFF)
IF(REAL(DNUFI).GT.CUTLIM) THEN
DNUFI=1.0D0/DNUFI
DNUFT=1.0D0/DNUFT
DO 130 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DNUFI*(DXSMAC(IGR,IXSR)
> -DXSREM(IGR,IXSR)))
130 CONTINUE
ENDIF
ENDIF
IXSR=6
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
JXSR=4
KXSR=3
DO 140 IGR=1,NGROUP
DNUFI=DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR)
CUTLIM=ABS(REAL(DXSMAC(IGR,JXSR))*CUTOFF)
IF(REAL(DNUFI).GT.CUTLIM) THEN
XSREC(IGR,IXSR)=REAL((DXSMAC(IGR,KXSR)
> -DXSREM(IGR,KXSR))/DNUFI)
ENDIF
140 CONTINUE
ENDIF
DO 150 IXSR=7,NDPROC
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 160 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR))
CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF)
IF(XSREC(IGR,IXSR).LT.CUTLIM) XSREC(IGR,IXSR)=0.0
160 CONTINUE
ENDIF
150 CONTINUE
IL=0
DO 170 IXSR=NDPROC+1,NDPROC+NL
IL=IL+1
IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN
DO 180 IGR=1,NGROUP
XSREC(IGR,IXSR)=REAL(DXSMAC(IGR,IXSR)-DXSREM(IGR,IXSR))
CUTLIM=ABS(REAL(DXSMAC(IGR,IXSR))*CUTOFF)
IF(ABS(XSREC(IGR,IXSR)).LT.CUTLIM)
> XSREC(IGR,IXSR)=0.0
DO 190 JGR=1,NGROUP
XSCAT(IGR,JGR,IL)=REAL(DSCMAC(IGR,JGR,IL)
> -DSCREM(IGR,JGR,IL))
CUTLIM=ABS(REAL(DSCMAC(IGR,JGR,IL))*CUTOFF)
IF(ABS(XSCAT(IGR,JGR,IL)).LT.CUTLIM)
> XSCAT(IGR,JGR,IL)=0.0
190 CONTINUE
180 CONTINUE
ENDIF
170 CONTINUE
*----
* COMPUTE AVERAGED ENERGY PER FISSION
*----
JXSR=4
KXSR=16
DNUFI=0.0D0
DNUFT=0.0D0
DO 200 IGR=1,NGROUP
DNUFT=DNUFT+DXSMAC(IGR,KXSR)*DXSMAC(IGR,JXSR)
DNUFI=DNUFI+(DXSMAC(IGR,KXSR)-DXSREM(IGR,KXSR))
> *(DXSMAC(IGR,JXSR)-DXSREM(IGR,JXSR))
200 CONTINUE
CUTLIM=ABS(REAL(DNUFT)*CUTOFF)
IF(REAL(DNUFI).GT.CUTLIM) THEN
DMJMAC=DMJMAC/DNUFI
ELSE
DMJMAC=0.0D0
ENDIF
*----
* SAVE CPO MICRO
*----
IORD=1
CALL XDRLGS(IPCPO,1,IPRINT,0,NL-1,IORD,NGROUP,XSREC(1,NDPROC+1),
> XSCAT,ITYPRO(NDPROC+1))
CALL CPOLGX(IPCPO,1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),ITYPRO)
CALL LCMSIX(IPCPO,'MACR',2)
IXSR=NDPROC+NL+1
DO 210 IGR=1,NGROUP
XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR))
210 CONTINUE
CALL LCMPUT(IPCPO,'OVERV',NGROUP,2,XSREC)
IXSR=16
DO 220 IGR=1,NGROUP
XSREC(IGR,1)=REAL(DXSMAC(IGR,IXSR))
220 CONTINUE
CALL LCMPUT(IPCPO,'FLUX-INTG',NGROUP,2,XSREC)
CALL LCMPUT(IPCPO,'FLUXDISAFACT',NGROUP,2,DISFC)
IF(IFCDIS .EQ. 1) THEN
CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,1),1)
CALL LCMPUT(IPCPO,'DISFACX',2*NGROUP,2,DISTMP)
CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,2),1)
CALL LCMPUT(IPCPO,'DISFACY',2*NGROUP,2,DISTMP)
CALL XDRSDB(2*NGROUP,DISTMP,DISFAC(1,1,3),1)
CALL LCMPUT(IPCPO,'DISFACZ',2*NGROUP,2,DISTMP)
ENDIF
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(DISTMP,XSCAT,XSREC)
RETURN
END
|
