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
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
|
*DECK XCWTRK
SUBROUTINE XCWTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP,IPRT ,
> NDIM ,ITOPT ,NVOL ,NSUR ,NANGL ,ISYMM ,
> DENS ,PCORN ,MXSUB ,MXSEG ,ICODE ,TITREC)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Analyse cluster geometry and perform specular or isotropic
* traking if required.
*
*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
* IPTRK pointer to the excell tracking.
* IPGEOM pointer to the geometry.
* GEONAM geometry name.
* IFTEMP temporary tracking file.
* IPRT print option.
* TITREC title for execution.
*
*Parameters: input/output
* IDISP tracking file disposition:
* = -2 no traking - only analyse geometry
* then abort (option halt);
* = -1 modify tracking file;
* = 0 old tracking file;
* = 1 new tracking file.
*
*Parameters: output
* NDIM number of physical dimensions.
* ITOPT tracking option:
* = 0 finite;
* = 1 cyclic.
* NVOL number of physical regions.
* NSUR number of outer surface.
* NANGL number of angles.
* ISYMM symmetry factor.
* DENS track density.
* PCORN corner proximity.
* MXSUB maximum number of subtracks.
* MXSEG maximum segment length.
* ICODE albedo associated with face.
*
*------------------------- XCWTRK -------------------------------
*
USE GANLIB
IMPLICIT NONE
INTEGER IOUT,NALB,NSTATE
CHARACTER NAMSBR*6
PARAMETER (IOUT=6,NALB=6,NSTATE=40,
> NAMSBR='XCWTRK')
*----
* ROUTINE PARAMETERS
*----
TYPE(C_PTR) IPTRK,IPGEOM
INTEGER IDISP ,IFTEMP,IPRT ,NDIM ,ITOPT ,NVOL ,NSUR ,
> NANGL ,ISYMM ,MXSUB ,MXSEG ,ICODE(NALB)
REAL DENS ,PCORN
CHARACTER GEONAM*12,TITREC*7
*----
* REDGET VARIABLES
*----
INTEGER ITYPLU,INTLIR
CHARACTER CARLIR*12
REAL REALIR
DOUBLE PRECISION DBLLIR
*----
* LOCAL VARIABLES
*----
LOGICAL SWZERO
CHARACTER COMENT*80
INTEGER NCODE(NALB),IMS(NALB)
REAL ALBEDO(NALB)
INTEGER ISTATE(NSTATE)
REAL EXTKOP(NSTATE)
INTEGER ILENGT,ITYLCM,NANGR ,NCOMNT,NCOR ,NALBG,
> MSROD ,MAROD ,MNAN ,NRT ,NSURX ,NBAN ,
> NUNK ,JJ ,IHS
REAL COTE ,RADMIN
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,NRINFO,NRODS,
> NRODR,NXRI
REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,RAN,RODS,RODR
*----
* DEFAULT TRACKING OPTIONS:
*----
PCORN=0.0
ISTATE(:NSTATE)=0
EXTKOP(:NSTATE)=0.0
CALL LCMLEN(IPTRK,'STATE-VECTOR',ILENGT,ITYLCM)
IF(ILENGT .LE. 0 .OR. ILENGT .GT. NSTATE) THEN
ITOPT=0
NANGR=15
ISYMM=1
DENS=0.0
ELSE
CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP)
ITOPT=ISTATE(9)
NANGR=ISTATE(11)
ISYMM=ISTATE(12)
DENS=EXTKOP(2)
ENDIF
*----
* READ THE NEW TRACKING OPTIONS.
*----
IF(IDISP .LE. 0) GO TO 200
100 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
IF(ITYPLU .NE. 3) CALL XABORT(NAMSBR//
> ': CHARACTER DATA EXPECTED.')
IF((CARLIR .EQ. 'TISO') .OR. (CARLIR .EQ. 'TSPC')) THEN
IF(CARLIR .EQ. 'TSPC') THEN
ITOPT=1
SWZERO=.TRUE.
ELSE
ITOPT=0
ENDIF
*----
* 2-D QUADRATURE PARAMETERS (ANGLE AND SPACE).
*----
CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
IF(ITYPLU .EQ. 3) THEN
IF(ITOPT .EQ. 1 .AND. CARLIR .EQ. 'MEDI') THEN
SWZERO=.FALSE.
ELSE
CALL XABORT('XCWTRK: *MEDI* KEYWORD EXPECTED.')
ENDIF
CALL REDGET(ITYPLU,NANGR,REALIR,CARLIR,DBLLIR)
ENDIF
IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR//
> ': INTEGER DATA EXPECTED.')
NANGR=INTLIR
IF(NANGR.LT.2) CALL XABORT(NAMSBR//
> ': THE NUMBER OF ANGLES MUST BE > 1.')
CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
IF(ITYPLU .NE. 2) CALL XABORT(NAMSBR//
> ': REAL DATA EXPECTED.')
DENS=REALIR
ELSE IF(CARLIR .EQ. 'HALT') THEN
*----
* NO TRACKING OPTION
*----
IDISP=-2
ELSE IF(CARLIR .EQ. 'SYMM') THEN
*----
* SYMMETRY FACTOR
*----
CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
IF(ITYPLU .NE. 1) CALL XABORT(NAMSBR//
> ': INTEGER DATA EXPECTED.')
ISYMM=INTLIR
ELSE IF(CARLIR .EQ. ';') THEN
NANGL=NANGR
GO TO 200
ELSE
CALL XABORT(NAMSBR//': INVALID KEYWORD.')
ENDIF
GO TO 100
200 CONTINUE
*----
* Set NANGL for specular tracking to a valid value
*----
IF(ITOPT .EQ. 1) THEN
NANGL=MIN(30,NANGL)
IF(NANGL .GT. 24) THEN
NANGL = 30
ELSE IF(NANGL .GT. 20) THEN
NANGL = 24
ELSE IF(NANGL .GT. 18) THEN
NANGL = 20
ELSE IF(NANGL .GT. 14) THEN
NANGL = 18
ELSE IF(NANGL .GT. 12) THEN
NANGL = 14
ELSE IF(NANGL .GT. 8) THEN
NANGL = 12
ELSE
NANGL = 8
ENDIF
ISYMM=1
ENDIF
*----
* SAVE EXCELL SPECIFIC TRACKING INFORMATION.
*----
ISTATE(1)=NVOL
ISTATE(5)=NSUR
ISTATE(9)=ITOPT
ISTATE(11)=NANGR
ISTATE(12)=ISYMM
CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE)
EXTKOP(2)=DENS
CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP)
*----
* ANALYZE GEOMETRY AND STORE DESCRIPTION ON TRACKING STRUCTURE
*----
CALL AXGXCW(IPGEOM,IPTRK ,IPRT ,GEONAM,ISYMM )
*----
* READ TRACKING STRUCTURE
* KEYMRG : INTEGER MERGE VECTOR
* VOLSUR : REAL VOLUME-SURFACE VECTOR
* MATALB : INTEGER MATERIAL-FACE VECTOR
*----
ISTATE(:NSTATE)=0
CALL LCMSIX(IPTRK,'EXCELL ',1)
CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE )
NDIM = ISTATE(1)
NSUR = ISTATE(2)
NVOL = ISTATE(3)
NSURX = ISTATE(4)
NBAN = ISTATE(5)
NUNK = ISTATE(6)
NRT = ISTATE(7)
MSROD = ISTATE(8)
MAROD = ISTATE(9)
MNAN = ISTATE(10)
ALLOCATE(KEYMRG(NUNK),VOLSUR(NUNK),MATALB(NUNK))
ALLOCATE(NRINFO(2*MNAN),NRODS(3*NRT),NRODR(NRT),NXRI(NRT*NBAN))
ALLOCATE(RAN(NBAN),RODS(2*NRT),RODR(MSROD*NRT))
CALL LCMGET(IPTRK,'RAN ',RAN )
IF(NSURX .EQ. 4)
>CALL LCMGET(IPTRK,'COTE ',COTE )
CALL LCMGET(IPTRK,'RADMIN ',RADMIN)
CALL LCMGET(IPTRK,'NRODS ',NRODS )
CALL LCMGET(IPTRK,'RODS ',RODS )
CALL LCMGET(IPTRK,'NRODR ',NRODR )
CALL LCMGET(IPTRK,'RODR ',RODR )
CALL LCMGET(IPTRK,'NRINFO ',NRINFO)
CALL LCMGET(IPTRK,'NXRI ',NXRI )
CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG)
CALL LCMGET(IPTRK,'MATALB ',MATALB)
CALL LCMGET(IPTRK,'VOLSUR ',VOLSUR)
CALL LCMSIX(IPTRK,'EXCELL ',2)
CALL LCMGET(IPTRK,'ALBEDO ',ALBEDO)
CALL LCMGET(IPTRK,'ICODE ',ICODE )
CALL LCMGET(IPTRK,'NCODE ',NCODE )
IF(ISYMM.GT.1) THEN
DO 110 IHS=1,NALB
IMS(IHS)=1
110 CONTINUE
ELSE
DO 111 IHS=1,NALB
IMS(IHS)=IHS
111 CONTINUE
ENDIF
IF(IDISP .EQ. 1) THEN
MXSUB=1
MXSEG=4*(NBAN+1+NRT*MSROD*MAROD)
IF(ITOPT .EQ. 1) THEN
MXSUB=4*NANGL
MXSEG=16*NANGL*MXSEG
ENDIF
NCOMNT=5
NCOR=1
NALBG=NALB
WRITE(IFTEMP) '$TRK',NCOMNT,0,0
COMENT='CREATOR : DRAGON'
WRITE(IFTEMP) COMENT
COMENT='MODULE : XCWTRK'
WRITE(IFTEMP) COMENT
COMENT='TYPE : CLUSTER'
WRITE(IFTEMP) COMENT
COMENT='GEOMETRY : '//GEONAM
WRITE(IFTEMP) COMENT
COMENT=TITREC
WRITE(IFTEMP) COMENT
IF(ITOPT .EQ. 1) THEN
WRITE(IFTEMP) NDIM,ITOPT,NVOL,NSUR,NALBG,NCOR,4*NANGL,MXSUB,
> MXSEG
ELSE
WRITE(IFTEMP) NDIM,ITOPT,NVOL,NSUR,NALBG,NCOR,NANGL,MXSUB,
> MXSEG
ENDIF
WRITE(IFTEMP) (VOLSUR(JJ),JJ=1,1+NSUR+NVOL)
WRITE(IFTEMP) (MATALB(JJ),JJ=1,1+NSUR+NVOL)
WRITE(IFTEMP) (ICODE(JJ),JJ=1,NALBG)
WRITE(IFTEMP) (ALBEDO(JJ),JJ=1,NALBG)
*----
* SET DEFAULT TRACKING DENSITY
*----
IF(DENS .EQ. 0.0) DENS=5.0/RADMIN
IF(ITOPT .EQ. 1) THEN
*----
* SPECULAR TRACKING
*----
CALL XCWSCL(NDIM ,NSURX ,NVOL ,NBAN ,NRT ,MSROD ,MAROD ,
> NANGL ,DENS ,IFTEMP,IPRT ,NCODE ,SWZERO,NRINFO,
> RAN ,COTE ,NRODS ,RODS ,NRODR ,RODR ,MXSUB ,
> MXSEG ,NXRI ,IMS )
NANGL=4*NANGL
ELSE
*----
* ISOTROPIC TRACKING
*----
CALL XCWICL(NDIM ,NSURX ,NVOL ,NBAN ,NRT ,MSROD ,MAROD ,
> NANGL ,DENS ,ISYMM ,IFTEMP,IPRT ,NRINFO,RAN ,
> COTE ,NRODS ,RODS ,NRODR ,RODR ,MXSEG ,NXRI ,
> IMS)
ENDIF
ENDIF
*----
* RELEASE BLOCKS FOR GEOMETRY
*----
DEALLOCATE(RODR,RODS,RAN)
DEALLOCATE(NXRI,NRODR,NRODS,NRINFO)
DEALLOCATE(MATALB,VOLSUR,KEYMRG)
RETURN
END
|
