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
|
*DECK SPHSXS
SUBROUTINE SPHSXS(NREA,IDIM2,NADRX,NGROUP,NL,NDATAX,NDATAP,INDX,
1 IAD,ADRX,RDATAX,IDATAP,NOMREA,SIGS,SS2D,XS,LXS)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover the cross sections of an elementary calculation and single
* mixture in a Saphyb.
*
*Copyright:
* Copyright (C) 2011 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
* NREA number of reactions in the Saphyb.
* IDIM2 second dimension of ADRX array.
* NADRX number of address sets.
* NGROUP number of energy groups.
* NL maximum Legendre order (NL=1 is for isotropic scattering).
* NDATAX number of components in RDATAX.
* NDATAP number of components in IDATAP.
* INDX position of isotopic set in current mixture.
* IAD last index in ADRX.
* ADRX index for RDATAX in the Saphyb.
* RDATAX main cross section container in the Saphyb.
* IDATAP index for scattering matrix information in the Saphyb.
* NOMREA names of reactions in the Saphyb.
* LXS existence flag of each reaction.
*
*Parameters: output
* SIGS scattering cross sections.
* SS2D complete scattering matrix.
* XS cross sections per reaction.
* LXS existence flag of each reaction.
*
*-----------------------------------------------------------------------
*
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER NREA,IDIM2,NADRX,NGROUP,NL,NDATAX,NDATAP,INDX,IAD,
1 ADRX(NREA+2,IDIM2,NADRX),IDATAP(NDATAP)
REAL SS2D(NGROUP,NGROUP,NL),SIGS(NGROUP,NL),XS(NGROUP,NREA),
1 RDATAX(NDATAX)
LOGICAL LXS(NREA)
CHARACTER NOMREA(NREA)*12
*----
* LOCAL VARIABLES
*----
INTEGER FAGG,LAGG,FDGG,WGAL,FAG,LAG,FDG(NGROUP),ADR(NGROUP+1)
*----
* FILL OUTPUT ARRAYS
*----
IREAPR=0
IRENTO=0
DO IREA=1,NREA
IF(NOMREA(IREA).EQ.'PROFIL') IREAPR=IREA
IF(NOMREA(IREA).EQ.'TOTALE') IRENTO=IREA
ENDDO
SIGS(:NGROUP,:NL)=0.0
SS2D(:NGROUP,:NGROUP,:NL)=0.0
XS(:NGROUP,:NREA)=0.0
NL1=ADRX(NREA+1,INDX,IAD)
NL2=ADRX(NREA+2,INDX,IAD)
IF((NL1.GT.NL).OR.(NL2.GT.NL)) THEN
CALL XABORT('SPHSXS: NL OVERFLOW.')
ENDIF
DO IREA=1,NREA
IOF=ADRX(IREA,INDX,IAD)
IF(IOF.EQ.0) CYCLE
IF(NOMREA(IREA).EQ.'DIFFUSION') THEN
DO IL=1,NL1
DO IGR=1,NGROUP
SIGS(IGR,IL)=RDATAX(IOF+(IL-1)*NGROUP+IGR-1)
LXS(IREA)=LXS(IREA).OR.(SIGS(IGR,IL).NE.0.0)
ENDDO
ENDDO
IF(ADRX(IRENTO,INDX,IAD).EQ.0) THEN
DO IGR=1,NGROUP
XS(IGR,IRENTO)=XS(IGR,IRENTO)+RDATAX(IOF+IGR-1)
LXS(IRENTO)=LXS(IRENTO).OR.(XS(IGR,IRENTO).NE.0.0)
ENDDO
ENDIF
ELSE IF(NOMREA(IREA).EQ.'ABSORPTION') THEN
DO IGR=1,NGROUP
XS(IGR,IREA)=RDATAX(IOF+IGR-1)
LXS(IREA)=LXS(IREA).OR.(XS(IGR,IREA).NE.0.0)
ENDDO
IF(ADRX(IRENTO,INDX,IAD).EQ.0) THEN
DO IGR=1,NGROUP
XS(IGR,IRENTO)=XS(IGR,IRENTO)+RDATAX(IOF+IGR-1)
LXS(IRENTO)=LXS(IRENTO).OR.(XS(IGR,IRENTO).NE.0.0)
ENDDO
ENDIF
ELSE IF(NOMREA(IREA).EQ.'PROFIL') THEN
CYCLE
ELSE IF(NOMREA(IREA).EQ.'TRANSFERT') THEN
IF(IREAPR.EQ.0) CALL XABORT('SPHSXS: MISSING PROFILE INFO.')
IPROF=ADRX(IREAPR,INDX,IAD)
FAGG=IDATAP(IPROF)
LAGG=IDATAP(IPROF+1)
FDGG=IDATAP(IPROF+2)
WGAL=IDATAP(IPROF+3)
FAG=IDATAP(IPROF+4)
LAG=IDATAP(IPROF+5)
DO IGR=1,NGROUP
FDG(IGR)=IDATAP(IPROF+5+IGR)
ADR(IGR)=IDATAP(IPROF+5+NGROUP+IGR)
ENDDO
ADR(NGROUP+1)=IDATAP(IPROF+6+2*NGROUP)
JOFS=0
DO IL=1,NL2
ZIL=REAL(2*IL-1)
IF(WGAL.NE.0) THEN
DO IGR=FAGG,LAGG
DO JGR=FDGG,FDGG+WGAL-1
SS2D(IGR,JGR,IL)=RDATAX(IOF+JOFS)/ZIL ! IGR <-- JGR
JOFS=JOFS+1
LXS(IREA)=LXS(IREA).OR.(SS2D(IGR,JGR,IL).NE.0.0)
ENDDO
ENDDO
ENDIF
DO IGR=FAG,LAG
DO JGR=FDG(IGR),FDG(IGR)+(ADR(IGR+1)-ADR(IGR))-1
SS2D(IGR,JGR,IL)=RDATAX(IOF+JOFS)/ZIL ! IGR <-- JGR
JOFS=JOFS+1
LXS(IREA)=LXS(IREA).OR.(SS2D(IGR,JGR,IL).NE.0.0)
ENDDO
ENDDO
ENDDO
ELSE
DO IGR=1,NGROUP
XS(IGR,IREA)=RDATAX(IOF+IGR-1)
LXS(IREA)=LXS(IREA).OR.(XS(IGR,IREA).NE.0.0)
ENDDO
ENDIF
ENDDO
RETURN
END
|
