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 FMAC03
SUBROUTINE FMAC03(IPMACR,IG,IPART,NGP,MAXLEN,NANISO,NK,NPART,
1 HNPRT,NGPRT,NWA,H2)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Save a SCAT cross section in the GROUP list of a MACROLIB.
*
*Copyright:
* Copyright (C) 2020 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
* IPMACR LCM object address of the MACROLIB.
* IG secondary energy group.
* IPART index of the particle type corresponding to the MACROLIB.
* NGP sum of number of energy groups for all types of particles.
* MAXLEN second dimension of array H2.
* NANISO maximum scattering anisotropy.
* NK number of mixtures.
* NPART number of particle types.
* HNPRT character*1 names of particle types.
* NGPRT number of energy groups per particle type.
* NWA Legendre order of scattering cross-section information.
* H2 scattering cross-section information.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPMACR
INTEGER IG,IPART,NGP,MAXLEN,NANISO,NK,NPART,NGPRT(NPART),
1 NWA(NGP,NK)
CHARACTER(LEN=1) HNPRT(NPART)
REAL H2(NGP,MAXLEN)
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) KPMACR
CHARACTER(LEN=2) CM
CHARACTER(LEN=12) HGROUP
*----
* ALLOCATABLE ARRAYS
*----
TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: JPMACR
INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS
REAL, ALLOCATABLE, DIMENSION(:) :: GAR
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
*----
* DEFINE GROUP DIRECTORIES PER PARTICLE TYPE
*----
ALLOCATE(JPMACR(NPART))
DO JPART=1,NPART
IF(JPART.EQ.IPART) THEN
HGROUP='GROUP'
ELSE
HGROUP='GROUP-'//HNPRT(JPART)
ENDIF
JPMACR(JPART)=LCMLID(IPMACR,HGROUP,NGPRT(IPART))
ENDDO
IG1=1
DO I=1,IPART-1
IG1=IG1+NGPRT(I)
ENDDO
IG2=IG1+NGPRT(IPART)-1
IGR=IG-IG1+1
*----
* LOOP OVER PARTICLE TYPES
*----
DO JPART=1,NPART
ALLOCATE(SCAT(NK,NGPRT(JPART),NANISO+1))
SCAT(:NK,:NGPRT(JPART),:NANISO)=0.0
JG1=1
DO I=1,JPART-1
JG1=JG1+NGPRT(I)
ENDDO
JG2=JG1+NGPRT(JPART)-1
*----
* LOOP OVER TRANSITIONS
*----
DO JG=JG1,JG2
* Loop over primary energy groups
DO IBM=1,NK
IF(NWA(JG,IBM).NE.0) GO TO 10
ENDDO
CYCLE
* Find the primary particle type
10 JGR=JG-JG1+1
IOF=0
DO IBM=1,NK
IF(NWA(JG,IBM).GT.0) CALL XABORT('FMAC03: POSITIVE NWA NOT'
1 //' IMPLEMENTED.')
IF(-NWA(JG,IBM).GT.NANISO+1) CALL XABORT('FMAC03: NWA OVER'
1 //'FLOW.')
DO IL=1,-NWA(JG,IBM)
SCAT(IBM,JGR,IL)=H2(JG,IOF+IL)
ENDDO
IOF=IOF-NWA(JG,IBM)
ENDDO
ENDDO
*----
* SAVE SCATTERING INFORMATION ON MACROLIB
*----
ALLOCATE(NJJ(NK),IJJ(NK),IPOS(NK),GAR(NK*NGPRT(JPART)))
KPMACR=LCMDIL(JPMACR(JPART),IGR)
DO IL=1,NANISO
WRITE (CM,'(I2.2)') IL-1
IPOSIT=0
DO IBM=1,NK
J2=IGR
J1=IGR
DO JGR=1,NGPRT(JPART)
IF(SCAT(IBM,JGR,IL).NE.0.0) THEN
J2=MAX(J2,JGR)
J1=MIN(J1,JGR)
ENDIF
ENDDO
NJJ(IBM)=J2-J1+1
IJJ(IBM)=J2
IPOS(IBM)=IPOSIT+1
DO JGR=J2,J1,-1
IPOSIT=IPOSIT+1
IF(IPOSIT.GT.NK*NGPRT(JPART)) CALL XABORT('bug')
GAR(IPOSIT)=SCAT(IBM,JGR,IL)
ENDDO
ENDDO
CALL LCMPUT(KPMACR,'SIGW'//CM,NK,2,SCAT(1,IGR,IL))
CALL LCMPUT(KPMACR,'SCAT'//CM,IPOSIT,2,GAR)
CALL LCMPUT(KPMACR,'NJJS'//CM,NK,1,NJJ)
CALL LCMPUT(KPMACR,'IJJS'//CM,NK,1,IJJ)
CALL LCMPUT(KPMACR,'IPOS'//CM,NK,1,IPOS)
ENDDO
DEALLOCATE(GAR,IPOS,IJJ,NJJ,SCAT)
ENDDO
DEALLOCATE(JPMACR)
RETURN
END
|
