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
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
*DECK READMT
SUBROUTINE READMT (MAXPTS,IPGEOM,IR,MAT,VOL,ILK,ISTAT,NSUPCE,IPAS,
1 NMC,RAYRE,PROCEL,POURCE,SURFA,IMPX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover the input data for the description of an arbitrary multicell
* using the 'do-it-yourself' approach.
*
*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/output
* MAXPTS allocated storage for arrays of dimension NSUPCE or IPAS.
* IPGEOM pointer to the geometry L_GEOM signature).
* IR number of mixtures.
* MAT index-number of the mixture type assigned to each volume.
* VOL volumes.
* ILK leakage flag (ILK=.true. if neutron leakage through external
* boundary is present).
* ISTAT statistical approximation flag (set with ISTAT=1).
* NSUPCE number of cells.
* IPAS number of volumes.
* NMC offset of the first volume in each cell.
* RAYRE radius of the tubes in each cell.
* PROCEL user supplied geometrical matrix.
* POURCE weight assign to each cell.
* SURFA surface assign to each cell.
* IMPX print flag (equal to 0 for no print).
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPGEOM
INTEGER MAXPTS,IR,ISTAT,NSUPCE,IPAS,MAT(IPAS),NMC(NSUPCE+1),IMPX
REAL VOL(IPAS),RAYRE(NSUPCE+IPAS),PROCEL(NSUPCE**2),
1 POURCE(NSUPCE),SURFA(NSUPCE)
LOGICAL ILK
*----
* LOCAL VARIABLES
*----
PARAMETER (PI=3.141592654,EPS1=1.0E-5,EPS2=1.0E-4,NSTATE=40)
LOGICAL EMPTY,LCM
CHARACTER GEONAM*12,TEXT12*12,HSMG*131
DOUBLE PRECISION RRINT,RRZON,PAS,RJ,RJ1,RJN,RJN1
INTEGER ISTATE(NSTATE),ISTAT2(NSTATE)
INTEGER, ALLOCATABLE, DIMENSION(:) :: NBREG,MILIEU,CELL,IGEN
REAL, ALLOCATABLE, DIMENSION(:) :: RAYZON
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(NBREG(MAXPTS),MILIEU(MAXPTS),CELL(3*MAXPTS),IGEN(MAXPTS))
ALLOCATE(RAYZON(MAXPTS))
*
CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM)
CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE)
NSUPCE=ISTATE(3)
IF(NSUPCE.GT.MAXPTS) CALL XABORT('READMT: INSUFFICIENT STORAGE.')
CALL LCMLEN(IPGEOM,'PROCEL',ILEN,ITYLCM)
IF(ILEN.EQ.0) THEN
ISTAT=1
ELSE
ISTAT=0
CALL LCMGET(IPGEOM,'PROCEL',PROCEL)
ENDIF
CALL LCMGET(IPGEOM,'POURCE',POURCE)
*
SURFAT=0.0
IPAS=0
NMC(1)=0
PTOT=1.0
CALL LCMLEN(IPGEOM,'MIX',ILON,ITYLCM)
IF(ILON.NE.NSUPCE) CALL XABORT('READMT: INVALID NUMBER OF SUB'
1 //' GEOMETRIES.')
CALL LCMGET(IPGEOM,'CELL',CELL)
CALL LCMGET(IPGEOM,'MIX',IGEN)
DO 50 IKK=1,NSUPCE
PTOT=PTOT-POURCE(IKK)
IKG=-IGEN(IKK)
IF(IKG.LT.0) CALL XABORT('READMT: GENERATING CELLS EXPECTED.')
WRITE (TEXT12(:4),'(A4)') CELL(3*(IKG-1)+1)
WRITE (TEXT12(5:8),'(A4)') CELL(3*(IKG-1)+2)
WRITE (TEXT12(9:),'(A4)') CELL(3*(IKG-1)+3)
CALL LCMLEN(IPGEOM,TEXT12,ILEN,ITYLCM)
IF((ILEN.EQ.0).OR.(ITYLCM.NE.0)) CALL XABORT('READMT: SUB GEOME'
1 //'TRY '//TEXT12//' IS MISSING FROM GEOMETRY '//GEONAM//'.')
CALL LCMSIX(IPGEOM,TEXT12,1)
CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTAT2)
IF(ISTAT2(1).NE.3) CALL XABORT('READMT: A SUB GEOMETRY IS N'
1 //'OT A TUBE.')
NZONE=ISTAT2(2)
CALL LCMLEN(IPGEOM,'SPLITR',ILEN,ITYLCM)
IF(ILEN.GT.0) THEN
CALL LCMGET(IPGEOM,'SPLITR',NBREG)
ELSE
DO 10 I=1,NZONE
NBREG(I)=1
10 CONTINUE
ENDIF
CALL LCMGET(IPGEOM,'MIX',MILIEU)
CALL LCMGET(IPGEOM,'RADIUS',RAYZON)
CALL LCMSIX(IPGEOM,' ',2)
RAYRE(IPAS+IKK)=0.0
RINT=0.0
RRINT=0.0D0
RJN=0.0D0
RJ=0.0D0
DO 40 N=1,NZONE
RRZON=RAYZON(N+1)
PAS=(RRZON-RRINT)/DBLE(ABS(NBREG(N)))
IF(NBREG(N).LT.0) PAS=PAS*(RRZON+RRINT)
DO 30 I=1,ABS(NBREG(N))
J=I+IPAS
IF(J.GT.MAXPTS) THEN
WRITE (HSMG,200) J,MAXPTS
CALL XABORT(HSMG)
ENDIF
IF(NBREG(N).GT.0) THEN
RJ1=RJ+PAS
RJN1=RJ1**2
ELSE
RJN1=RJ*RJ+PAS
RJ1=SQRT(RJN1)
ENDIF
VOL(J)=PI*REAL(RJN1-RJN)*POURCE(IKK)
RAYRE(J+IKK)=REAL(RJ1)
RJ=RJ1
RJN=RJN1
MAT(J)=MILIEU(N)
30 CONTINUE
IPAS=IPAS+ABS(NBREG(N))
RRINT=RRZON
RINT=RAYZON(N+1)
40 CONTINUE
NMC(IKK+1)=IPAS
RINT=RAYRE(IPAS+IKK)
SURFA(IKK)=2.0*PI*RINT*POURCE(IKK)
SURFAT=SURFAT+SURFA(IKK)
50 CONTINUE
*
IF(ABS(PTOT).GT.EPS1) CALL XABORT('READMT: INVALID CELL PROPORT'
1 //'IONS.')
IF(ISTAT.EQ.1) THEN
* STATISTICAL OPTION.
DO 70 IKK=1,NSUPCE
DO 60 JKK=1,NSUPCE
PROCEL((JKK-1)*NSUPCE+IKK)=SURFA(JKK)/SURFAT
60 CONTINUE
70 CONTINUE
ENDIF
DO 85 IKK=1,NSUPCE
DO 80 JKK=1,IKK-1
X1=SURFA(IKK)*PROCEL((JKK-1)*NSUPCE+IKK)
X2=SURFA(JKK)*PROCEL((IKK-1)*NSUPCE+JKK)
IF(ABS(X1-X2).GT.EPS2) THEN
WRITE (HSMG,210) ABS(X1-X2),IKK,JKK
CALL XABORT(HSMG)
ENDIF
80 CONTINUE
85 CONTINUE
*
IR=0
DO 90 I=1,IPAS
IR=MAX(IR,MAT(I))
90 CONTINUE
ILK=.FALSE.
*
IF(IMPX.GT.0) THEN
WRITE (6,'(/46H DO-IT-YOURSELF MULTICELL OPTION BASED ON GEOM,
1 5HETRY ,A12,1H./)') GEONAM
WRITE (6,'(/34H USER SUPPLIED GEOMETRICAL MATRIX:/)')
DO 100 I=1,NSUPCE
WRITE (6,'(1X,1P,10E12.4)') (PROCEL((J-1)*NSUPCE+I),J=1,NSUPCE)
100 CONTINUE
I1=0
DO 120 IKK=1,NSUPCE
I2=NMC(IKK+1)-NMC(IKK)
WRITE (6,'(//)')
WRITE (6,230) IKK
J1=I1+1
DO 110 I=1,1+(I2-1)/8
J2=MIN0(J1+7,I1+I2)
WRITE (6,240) (J,J=J1,J2)
WRITE (6,250) (RAYRE(J+IKK),J=J1,J2)
J1=J1+8
110 CONTINUE
I1=I1+I2
120 CONTINUE
WRITE (6,'(//)')
WRITE (6,260) IPAS,MAXPTS,IR
WRITE (6,'(17H INFINITE DOMAIN./)')
ENDIF
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(RAYZON)
DEALLOCATE(IGEN,CELL,MILIEU,NBREG)
RETURN
*
200 FORMAT (24HREADMT: A CELL NUMBER (=,I4,18H) EXCEED MAXPTS (=,
1 I4,1H))
210 FORMAT (53HREADMT: THE USER SUPPLIED GEOMETRICAL MATRIX DO NOT M,
1 31HEET THE RECIPROCITY CONDITION (,1P,E10.1,7H); CELL,I5,4H <->,
2 5H CELL,I5,1H.)
230 FORMAT (1X,11(1H*)/7H * CELL,I3,2H */1X,11(1H*))
240 FORMAT (/11H VOLUME ,8(4X,I4,6X,1HI))
250 FORMAT ( 11H ABSCISSA ,8(F12.6,2X,1HI))
260 FORMAT (/20H NUMBER OF VOLUMES =,I4,5X,23HAVAILABLE STORAGE: MAXB,
1 4HLK =,I4/21H NUMBER OF MIXTURES =,I4/)
END
|
