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
|
*DECK MACSCA
SUBROUTINE MACSCA(KPOLD,KPNEW,SCAT,SCAT2,CM,JGR,IL,MIX,NMXNEW,
1 NTOT,NMXOLD,NL,NGRP,LMAP)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover scattering matrices and store them in a new macrolib for
* a given anistropic level and energy group.
*
*Copyright:
* Copyright (C) 2007 Ecole Polytechnique de Montreal.
*
*Author(s):
* J. Koclas, E. Varin, D. Sekki
*
*Parameters: input
* KPOLD pointer to group directory in the initial macrolib.
* NL number of legendre orders (=1 for isotropic scattering).
* NGRP number of energy groups.
* NMXOLD number of material mixtures in the initial macrolib.
* NMXNEW number of material mixtures in the final macrolib.
* MIX index of all (material and virtual) mixtures per region.
* NTOT total number of all (material and virtual) mixtures.
* SCAT scattering matrices in the initial macrolib.
* SCAT2 scattering matrices in the final macrolib.
* IL anisotropic level to be treated.
* JGR energy group to be treated.
* CM anisotropic level in I2.2 format.
* LMAP flag for the initial macrolib:
* =.true. if the fuel map macrolib.
*
*Parameters: output
* KPNEW pointer to group directory in the final macrolib.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) KPOLD,KPNEW
REAL SCAT(NMXOLD,NL,NGRP,NGRP),SCAT2(NMXNEW,NL,NGRP,NGRP)
INTEGER MIX(NTOT)
CHARACTER CM*2
LOGICAL LMAP
*----
* LOCAL VARIABLES
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: IPOS,IPOS2
INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: IJJ,IJJ2,NJJ,NJJ2
REAL, ALLOCATABLE, DIMENSION(:) :: WORK,WORK2
CHARACTER HSMG*131
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(IPOS(NMXOLD),IPOS2(NMXNEW),IJJ(NMXOLD,NL,NGRP),
1 IJJ2(NMXNEW,NL,NGRP),NJJ(NMXOLD,NL,NGRP),NJJ2(NMXNEW,NL,NGRP))
ALLOCATE(WORK(NMXOLD*NGRP),WORK2(NMXNEW*NGRP))
WORK(:NMXOLD*NGRP)=0.0
WORK2(:NMXNEW*NGRP)=0.0
*----
* RECOVER EXISTING DATA
*----
CALL LCMLEN(KPNEW,'NJJS'//CM,ILENG,ITYP)
IF(LMAP.AND.(ILENG.GT.0))THEN
IF(ILENG.NE.NMXNEW)CALL XABORT('@MACSCA: INVALID MACROLIB(1).')
CALL LCMGET(KPNEW,'SCAT'//CM,WORK2(1))
CALL LCMGET(KPNEW,'NJJS'//CM,NJJ2(1,IL,JGR))
CALL LCMGET(KPNEW,'IJJS'//CM,IJJ2(1,IL,JGR))
CALL LCMGET(KPNEW,'IPOS'//CM,IPOS2(1))
DO 15 IBM=1,NMXNEW
IJJ0=IJJ2(IBM,IL,JGR)
IPOSDE=IPOS2(IBM)
DO 10 IGR=IJJ0,IJJ0-NJJ2(IBM,IL,JGR)+1,-1
SCAT2(IBM,IL,IGR,JGR)=WORK2(IPOSDE)
IPOSDE=IPOSDE+1
10 CONTINUE
15 CONTINUE
ENDIF
*----
* RECOVER SCAT,IJJ,NJJ,IPOS
*----
CALL LCMLEN(KPOLD,'NJJS'//CM,ILENG,ITYP)
IF(ILENG.EQ.0)CALL XABORT('@MACSCA: INVALID MACROLIB(2).')
CALL LCMGET(KPOLD,'SCAT'//CM,WORK(1))
CALL LCMGET(KPOLD,'NJJS'//CM,NJJ(1,IL,JGR))
CALL LCMGET(KPOLD,'IJJS'//CM,IJJ(1,IL,JGR))
CALL LCMGET(KPOLD,'IPOS'//CM,IPOS(1))
DO 25 IBM=1,NMXOLD
IJJ0=IJJ(IBM,IL,JGR)
IPOSDE=IPOS(IBM)
DO 20 IGR=IJJ0,IJJ0-NJJ(IBM,IL,JGR)+1,-1
SCAT(IBM,IL,IGR,JGR)=WORK(IPOSDE)
IPOSDE=IPOSDE+1
20 CONTINUE
25 CONTINUE
*----
* NEW SCAT2
*----
ITOT=0
DO 50 IBM=1,NTOT
IF(MIX(IBM).EQ.0)GOTO 50
ITOT=ITOT+1
IF(LMAP)THEN
* ONLY FUEL DATA WILL BE COPIED
IF(MIX(IBM).GT.0)GOTO 50
J=-MIX(IBM)
IF(J.GT.NMXOLD) THEN
WRITE(HSMG,'(25HMACSCA: A MIXTURE INDEX (,I6,12H) IS GREATER,
> 36H THAN THE TOTAL NUMBER OF MIXTURES (,I6,14H) IN 2ND RHS M,
> 8HACROLIB.)') J,NMXOLD
CALL XABORT(HSMG)
ENDIF
ELSE
* FUEL DATA WILL NOT BE COPIED
IF(MIX(IBM).LT.0)GOTO 50
J=MIX(IBM)
IF(J.GT.NMXOLD) THEN
WRITE(HSMG,'(25HMACSCA: A MIXTURE INDEX (,I6,12H) IS GREATER,
> 36H THAN THE TOTAL NUMBER OF MIXTURES (,I6,14H) IN 1ST RHS M,
> 8HACROLIB.)') J,NMXOLD
CALL XABORT(HSMG)
ENDIF
ENDIF
* COPY DATA
IJJ0=IJJ(J,IL,JGR)
DO 40 IGR=IJJ0,IJJ0-NJJ(J,IL,JGR)+1,-1
SCAT2(ITOT,IL,IGR,JGR)=SCAT(J,IL,IGR,JGR)
40 CONTINUE
50 CONTINUE
*----
* NEW IJJ2 AND NJJ2
*----
DO 70 IBM=1,NMXNEW
IGMIN=JGR
IGMAX=JGR
DO 60 IGR=NGRP,1,-1
IF(SCAT2(IBM,IL,IGR,JGR).NE.0.)THEN
IGMIN=MIN(IGMIN,IGR)
IGMAX=MAX(IGMAX,IGR)
ENDIF
60 CONTINUE
IJJ2(IBM,IL,JGR)=IGMAX
NJJ2(IBM,IL,JGR)=IGMAX-IGMIN+1
70 CONTINUE
*----
* STORE SCAT2,IJJ2,NJJ2,IPOS2
*----
IPOSDE=0
DO 85 IBM=1,NMXNEW
IPOS2(IBM)=IPOSDE+1
DO 80 IGR=IJJ2(IBM,IL,JGR),IJJ2(IBM,IL,JGR)-
1 NJJ2(IBM,IL,JGR)+1,-1
IPOSDE=IPOSDE+1
WORK2(IPOSDE)=SCAT2(IBM,IL,IGR,JGR)
80 CONTINUE
85 CONTINUE
CALL LCMPUT(KPNEW,'SCAT'//CM,IPOSDE,2,WORK2)
CALL LCMPUT(KPNEW,'IPOS'//CM,NMXNEW,1,IPOS2)
CALL LCMPUT(KPNEW,'NJJS'//CM,NMXNEW,1,NJJ2(1,IL,JGR))
CALL LCMPUT(KPNEW,'IJJS'//CM,NMXNEW,1,IJJ2(1,IL,JGR))
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(WORK2,WORK)
DEALLOCATE(NJJ2,NJJ,IJJ2,IJJ,IPOS2,IPOS)
RETURN
END
|
