]> git.uio.no Git - u/mrichter/AliRoot.git/blame - GEANT321/ggeom/glvolu.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Minor corrections after big transformer changes
[u/mrichter/AliRoot.git] / GEANT321 / ggeom / glvolu.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.1.1.1 1995/10/24 10:20:51 cernlib
6* Geant
7*
8*
9#include "geant321/pilot.h"
10*CMZ : 3.21/04 18/01/95 19.56.13 by S.Giani
11*-- Author :
12 SUBROUTINE GLVOLU (NLEV, LNAM, LNUM, IER)
13C.
14C. ******************************************************************
15C. * *
16C. * Loads the common block GCVOLU for the volume at lebel NLEV *
17C. * as described by the lists of names (LNAM) and numbers (LNUM) *
18C. * *
19C. * The routine is optimized and does not re-compute the part of *
20C. * history already available in GCVOLU. *
21C. * *
22C. * IER returns non zero in case of fatal error *
23C. * *
24C. * Called by : 'User', GDRVOL *
25C. * Authors : S.Banerjee, F.Bruyant, A.McPherson *
26C. * *
27C. ******************************************************************
28C.
29#include "geant321/gcbank.inc"
30#include "geant321/gconsp.inc"
31#include "geant321/gcunit.inc"
32#include "geant321/gcvolu.inc"
33 PARAMETER (NLVMAX=15)
34 INTEGER LNUM(*), LNAM(*), IDTYP(3,12)
35 DIMENSION LVOLS(NLVMAX), LINDX(NLVMAX)
36 REAL XC(3)
37 CHARACTER*4 KNAME
38 SAVE IDTYP
39C.
40 DATA IDTYP / 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 2, 3, 1,
41 + 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 4, 3, 1, 1, 1,
42 + 2, 3, 1, 2, 3, 1/
43C.
44C. ------------------------------------------------------------------
45*
46 IER = 0
47 NLEVL=NLEV
48 IF (NLEVL.LE.0.OR.NLEVL.GT.NLVMAX) GO TO 910
49 IF (JGPAR.EQ.0) THEN
50 CALL MZBOOK (IXCONS, JGPAR, JGPAR, 1, 'GPAR', NLVMAX, 0,
51 + NLVMAX, 2, 0)
52 ENDIF
53 IF (NLEVEL.EQ.0) GO TO 20
54*
55* *** Scan tree from top to bottom to
56* check if some levels are already filled
57*
58 NLMX = MIN (NLEVL, NLEVEL)
59 NLEVEL = 0
60 DO 10 I = 1,NLMX
61 IF (LNAM(I).NE.NAMES(I)) GO TO 15
62 IF (LNUM(I).NE.NUMBER(I)) GO TO 15
63 NLEVEL = NLEVEL +1
64 10 CONTINUE
65 IF (NLEVL.GT.NLEVEL) GO TO 95
66 nlevel=0
67 15 IF (NLEVEL.NE.0) GO TO 95
68*
69* *** Special case, first volume
70*
71 20 IF (JVOLUM.EQ.0) GO TO 920
72 IF (IQ(JVOLUM+1).EQ.LNAM(1)) THEN
73 IVO = 1
74 ELSE
75#if defined(CERNLIB_DEBUG)
76 WRITE (CHMAIL, 7000) LNAM(1)
77 CALL GMAIL (0, 0)
78#endif
79 IF (IQ(JVOLUM-1).LE.1) GO TO 920
80 DO 25 IV=2,IQ(JVOLUM-1)
81 IF (IQ(JVOLUM+IV).EQ.LNAM(1)) THEN
82 IVO = IV
83 GO TO 30
84 ENDIF
85 25 CONTINUE
86 WRITE (CHMAIL, 8000) LNAM(1)
87 CALL GMAIL (0, 0)
88 GO TO 999
89 ENDIF
90 30 NLEVEL = 1
91 JVO = LQ(JVOLUM-IVO)
92 LVOLUM(NLEVEL) = IVO
93 NAMES(NLEVEL) = IQ(JVOLUM+IVO)
94 NUMBER(NLEVEL) = LNUM(1)
95 GONLY(NLEVEL) = 1.
96 IF (LQ(JVO).EQ.0) THEN
97 NLDEV(1) = NLVMAX
98 ELSE
99 NLDEV(1) = 1
100 ENDIF
101 IF (IVO.EQ.1) THEN
102 LINDEX(NLEVEL) = 1
103 LINMX (NLEVEL) = 1
104 NLDM = 0
105 IQ(JGPAR+NLEVEL) = Q(JVO+5)
106 LQ(JGPAR-NLEVEL) = JVO + 6
107 ELSE
108 CALL UHTOC(NAMES,4,KNAME,4)
109 CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
110 IF (NLDM.GT.0) THEN
111 JVOM = LQ(JVOLUM-LVOLS(NLDM))
112 NIN = Q(JVOM+3)
113 IF (NIN.LT.0) THEN
114 LINDEX(NLEVEL) = LNUM(1)
115 ELSE
116 LINMX(NLEVEL) = NIN
117 DO 70 IN = 1, NIN
118 JIN = LQ(JVOM-IN)
119 IF (IFIX(Q(JIN+2)).NE.LVOLUM(1)) GO TO 70
120 IF (IFIX(Q(JIN+3)).NE.LNUM(1)) GO TO 70
121 LINDEX(NLEVEL) = IN
122 GO TO 75
123 70 CONTINUE
124 GO TO 920
125 ENDIF
126 75 JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
127 IF (NLDM.GT.1) THEN
128 DO 76 ILEV = 2, NLDM
129 IF (IQ(JPAR+1).EQ.0) THEN
130 JPAR = LQ(JPAR-LINDX(ILEV))
131 IF (JPAR.EQ.0) GO TO 77
132 ELSE IF (IQ(JPAR-3).GT.1) THEN
133 JPAR = LQ(JPAR-LINDX(ILEV))
134 ELSE
135 JPAR = LQ(JPAR-1)
136 ENDIF
137 76 CONTINUE
138 ENDIF
139 IF (NIN.GT.0) THEN
140 JPAR = LQ(JPAR-IN)
141 IF (JPAR.EQ.0) GO TO 77
142 ELSE
143 NDIV = IQ(JPAR+1)
144 LINMX(NLEVEL) = NDIV
145 IF (LINDEX(1).GT.NDIV) THEN
146 NL1 = 1
147 NAME = IQ(JVOLUM+LVOLS(NLDM))
148 GO TO 950
149 ENDIF
150 IF (IQ(JPAR-3).GT.1) THEN
151 IF (LINDEX(1).GT.0) THEN
152 JPAR = LQ(JPAR-LINDEX(1))
153 ELSE
154 JPAR = LQ(JPAR-1)
155 ENDIF
156 ELSE
157 JPAR = LQ(JPAR-1)
158 ENDIF
159 ENDIF
160 IQ(JGPAR+NLEVEL) = IQ(JPAR+5)
161 LQ(JGPAR-NLEVEL) = JPAR + 5
162 GO TO 78
163 77 NPAR = Q(JVO+5)
164 IF (NPAR.EQ.0.AND.NIN.GT.0) THEN
165 IQ(JGPAR+NLEVEL) = Q(JIN+9)
166 LQ(JGPAR-NLEVEL) = JIN+9
167 ELSE
168 IQ(JGPAR+NLEVEL) = NPAR
169 LQ(JGPAR-NLEVEL) = JVO + 6
170 ENDIF
171 ELSE
172 LINDEX(NLEVEL) = 1
173 LINMX(NLEVEL) = 1
174 IQ(JGPAR+NLEVEL) = Q(JVO+5)
175 LQ(JGPAR-NLEVEL) = JVO + 6
176 ENDIF
177 ENDIF
178 78 CONTINUE
179*
180 DO 90 I = 1,3
181 GTRAN(I,1) = 0.
182 DO 80 J = 1,3
183 K = (I-1)*3 +J
184 GRMAT(K,1) = 0.
185 80 CONTINUE
186 K = I*4 -3
187 GRMAT(K,1) = 1.
188 90 CONTINUE
189 GRMAT(10,1) = 0.
190 IF (NLEVL.GT.1) THEN
191 GO TO 100
192 ELSE
193 GO TO 990
194 ENDIF
195*
196* *** Check if there are volumes up in the tree where development
197* structure exists
198*
199 95 IF (LVOLUM(1).EQ.1.OR.NLDEV(1).EQ.1) THEN
200 NLDM = 0
201 ELSE
202 CALL UHTOC(NAMES,4,KNAME,4)
203 CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
204 ENDIF
205*
206* ** Next level
207*
208 100 CONTINUE
209 IVO = LVOLUM(NLEVEL)
210 JVO = LQ(JVOLUM-IVO)
211 NLD = NLDEV(NLEVEL)
212 NIN = Q(JVO+3)
213 IF (NIN.EQ.0) GO TO 930
214 NL1 = NLEVEL +1
215*
216 IF (NIN.GT.0) THEN
217*
218* * Content obtained by positioning
219*
220 DO 110 IN=1,NIN
221 JIN=LQ(JVO-IN)
222 IVOT=Q(JIN+2)
223 IF (IQ(JVOLUM+IVOT).NE.LNAM(NL1)) GO TO 110
224 INUM = Q(JIN+3)
225 IF (INUM.EQ.LNUM(NL1)) GO TO 115
226 110 CONTINUE
227 GO TO 940
228 115 IF (NLEVEL.GE.NLD) THEN
229* (case with JVOLUM structure locally developed)
230 JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
231 DO 120 ILEV = NLD, NLEVEL
232 IF (IQ(JPAR+1).EQ.0) THEN
233 IF (ILEV.EQ.NLEVEL) THEN
234 JPAR = LQ(JPAR-IN)
235 ELSE
236 JPAR = LQ(JPAR-LINDEX(ILEV+1))
237 ENDIF
238 IF (JPAR.EQ.0) GO TO 125
239 ELSE IF (IQ(JPAR-3).GT.1) THEN
240 JPAR = LQ(JPAR-LINDEX(ILEV+1))
241 ELSE
242 JPAR = LQ(JPAR-1)
243 ENDIF
244 120 CONTINUE
245 JPAR = JPAR + 5
246 NPAR = IQ(JPAR)
247 GO TO 130
248 ELSE IF (NLDM.GT.0) THEN
249 JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
250 IF (NLDM.GT.1) THEN
251 DO 121 ILEV = 2, NLDM
252 IF (IQ(JPAR+1).EQ.0) THEN
253 JPAR = LQ(JPAR-LINDX(ILEV))
254 IF (JPAR.EQ.0) GO TO 125
255 ELSE IF (IQ(JPAR-3).GT.1) THEN
256 JPAR = LQ(JPAR-LINDX(ILEV))
257 ELSE
258 JPAR = LQ(JPAR-1)
259 ENDIF
260 121 CONTINUE
261 ENDIF
262 DO 122 ILEV = 1, NL1
263 IF (IQ(JPAR+1).EQ.0) THEN
264 IF (ILEV.EQ.NL1) THEN
265 JPAR = LQ(JPAR-IN)
266 ELSE
267 JPAR = LQ(JPAR-LINDEX(ILEV))
268 ENDIF
269 IF (JPAR.EQ.0) GO TO 125
270 ELSE IF (IQ(JPAR-3).GT.1) THEN
271 JPAR = LQ(JPAR-LINDEX(ILEV))
272 ELSE
273 JPAR = LQ(JPAR-1)
274 ENDIF
275 122 CONTINUE
276 JPAR = JPAR + 5
277 NPAR = IQ(JPAR)
278 GO TO 130
279 ENDIF
280* (normal case)
281 125 JVOT = LQ(JVOLUM-IVOT)
282 NPAR = Q(JVOT+5)
283 IF (NPAR.EQ.0) THEN
284 JPAR = JIN + 9
285 NPAR = Q(JPAR)
286 ELSE
287 JPAR = JVOT + 6
288 ENDIF
289*
290 130 IROTT = Q(JIN+4)
291 NINSK = NIN
292 GONLY(NL1) = Q(JIN+8)
293 CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), Q(JIN+5), IROTT
294 +, GTRAN(1,NL1), GRMAT(1,NL1))
295*
296 ELSE
297*
298* * This section for divided objects
299*
300 JDIV = LQ(JVO-1)
301 IVOT = Q(JDIV+2)
302 IF (LNAM(NL1).NE.IQ(JVOLUM+IVOT)) GO TO 960
303 JVOT = LQ(JVOLUM-IVOT)
304 IF (NLEVEL.GT.NLD) THEN
305* (case with JVOLUM structure locally developed)
306 JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
307 DO 135 ILEV = NLD, NLEVEL-1
308 IF (IQ(JPAR+1).EQ.0) THEN
309 JPAR = LQ(JPAR-LINDEX(ILEV+1))
310 IF (JPAR.EQ.0) GO TO 140
311 ELSE IF (IQ(JPAR-3).GT.1) THEN
312 JPAR = LQ(JPAR-LINDEX(ILEV+1))
313 ELSE
314 JPAR = LQ(JPAR-1)
315 ENDIF
316 IF (ILEV.EQ.NLEVEL-1) THEN
317 NDIV = IQ(JPAR+1)
318 ORIG = Q(JPAR+2)
319 STEP = Q(JPAR+3)
320 ENDIF
321 135 CONTINUE
322 GO TO 145
323 ELSE IF (NLD.EQ.NLEVEL) THEN
324 JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
325 ELSE IF (NLDM.GT.0) THEN
326 JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
327 IF (NLDM.GT.1) THEN
328 DO 136 ILEV = 2, NLDM
329 IF (IQ(JPAR+1).EQ.0) THEN
330 JPAR = LQ(JPAR-LINDX(ILEV))
331 IF (JPAR.EQ.0) GO TO 140
332 ELSE IF (IQ(JPAR-3).GT.1) THEN
333 JPAR = LQ(JPAR-LINDX(ILEV))
334 ELSE
335 JPAR = LQ(JPAR-1)
336 ENDIF
337 136 CONTINUE
338 ENDIF
339 DO 137 ILEV = 1, NLEVEL
340 IF (IQ(JPAR+1).EQ.0) THEN
341 JPAR = LQ(JPAR-LINDEX(ILEV))
342 IF (JPAR.EQ.0) GO TO 140
343 ELSE IF (IQ(JPAR-3).GT.1) THEN
344 JPAR = LQ(JPAR-LINDEX(ILEV))
345 ELSE
346 JPAR = LQ(JPAR-1)
347 ENDIF
348 IF (ILEV.EQ.NLEVEL) THEN
349 NDIV = IQ(JPAR+1)
350 ORIG = Q(JPAR+2)
351 STEP = Q(JPAR+3)
352 ENDIF
353 137 CONTINUE
354 GO TO 145
355 ELSE
356 JPAR = 0
357 ENDIF
358* (normal case)
359 140 NDIV = Q(JDIV+3)
360 ORIG = Q(JDIV+4)
361 STEP = Q(JDIV+5)
362 145 IN = LNUM(NL1)
363 IF (IN.LT.1.OR.IN.GT.NDIV) THEN
364 NAME = NAMES(NLEVEL)
365 GO TO 950
366 ENDIF
367*
368 IF (JPAR.NE.0) THEN
369 IF (IQ(JPAR-3).GT.1) THEN
370 JPAR = LQ(JPAR-IN)
371 ELSE
372 JPAR = LQ(JPAR-1)
373 ENDIF
374 JPAR = JPAR + 5
375 NPAR = IQ(JPAR)
376 ELSE
377 NPAR = Q(JVOT+5)
378 JPAR = JVOT + 6
379 ENDIF
380 GONLY(NL1) = GONLY(NLEVEL)
381*
382 IAXIS = Q(JDIV+1)
383 ISH = Q(JVO+2)
384 IDT = IDTYP(IAXIS,ISH)
385 NINSK = NDIV
386*
387 IF (IDT.EQ.1) THEN
388 DO 151 I = 1, 3
389 151 XC(I) = 0.
390 XC(IAXIS) = ORIG + (IN - 0.5) * STEP
391 IF (ISH.EQ.4.OR.(ISH.EQ.10.AND.IAXIS.NE.1)) THEN
392 CALL GCENT (IAXIS, XC)
393 ENDIF
394 IF (GRMAT(10,NLEVEL).EQ.0.0) THEN
395 DO 152 I = 1, 3
396 152 GTRAN(I,NL1) = GTRAN(I,NLEVEL)+XC(I)
397 DO 153 I = 1, 10
398 153 GRMAT(I,NL1) = GRMAT(I,NLEVEL)
399 ELSE
400 CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), XC, 0,
401 + GTRAN(1,NL1), GRMAT(1,NL1))
402 ENDIF
403*
404 ELSE IF (IDT.EQ.3.OR.IDT.EQ.4) THEN
405 IF (IDT.EQ.3) THEN
406 PH0 = DEGRAD * (ORIG + (IN - 0.5) * STEP)
407 CPHR = COS (PH0)
408 SPHR = SIN (PH0)
409 ELSE
410 PH0 = 0.0
411 CPHR = 1.0
412 SPHR = 0.0
413 ENDIF
414 DO 154 I = 1, 3
415 GTRAN(I ,NL1) = GTRAN(I ,NLEVEL)
416 GRMAT(I ,NL1) = GRMAT(I ,NLEVEL)*CPHR
417 + + GRMAT(I+3,NLEVEL)*SPHR
418 GRMAT(I+3,NL1) = GRMAT(I+3,NLEVEL)*CPHR
419 + - GRMAT(I ,NLEVEL)*SPHR
420 GRMAT(I+6,NL1) = GRMAT(I+6,NLEVEL)
421 154 CONTINUE
422 IF (PH0.EQ.0.0.AND.GRMAT(10,NLEVEL).EQ.0.0) THEN
423 GRMAT(10,NL1) = 0.0
424 ELSE
425 GRMAT(10,NL1) = 1.0
426 ENDIF
427*
428 ELSE
429 DO 155 I = 1, 3
430 155 GTRAN(I,NL1) = GTRAN(I,NLEVEL)
431 DO 156 I = 1, 10
432 156 GRMAT(I,NL1) = GRMAT(I,NLEVEL)
433 ENDIF
434 ENDIF
435*
436 200 LINDEX(NL1) = IN
437 LVOLUM(NL1) = IVOT
438 NAMES(NL1) = LNAM(NL1)
439 NUMBER(NL1) = LNUM(NL1)
440 LINMX(NL1) = NINSK
441 IF (LQ(LQ(JVOLUM-IVOT)).EQ.0) THEN
442 NLDEV(NL1) = NLD
443 ELSE
444 NLDEV(NL1) = NL1
445 ENDIF
446 IQ(JGPAR+NL1) = NPAR
447 LQ(JGPAR-NL1) = JPAR
448 NLEVEL = NL1
449 IF (NLEVEL.EQ.NLEVL) GO TO 990
450 GO TO 100
451*
452* *** Error messages
453*
454 910 IER = 1
455 WRITE (CHMAIL, 1000) NLEV
456 CALL GMAIL (0, 0)
457 GO TO 999
458*
459 920 IER = 2
460 WRITE (CHMAIL, 2000) LNAM(1)
461 CALL GMAIL (0, 0)
462 GO TO 999
463*
464 930 IER = 3
465 WRITE (CHMAIL, 3000) NLEVEL,NLEV,NAMES(NLEVEL)
466 CALL GMAIL (0, 0)
467 GO TO 999
468*
469 940 IER = 4
470 WRITE (CHMAIL, 4000) LNAM(NL1),NL1,NAMES(NLEVEL)
471 CALL GMAIL (0, 0)
472 GO TO 999
473*
474 950 IER = 5
475 WRITE (CHMAIL, 5000) NL1,LNUM(NL1),NAME,NDIV
476 CALL GMAIL (0, 0)
477 GO TO 999
478*
479 960 IER = 6
480 WRITE (CHMAIL, 6000) NL1,LNAM(NL1),IQ(JVOLUM+IVOT)
481 CALL GMAIL (0, 0)
482 GO TO 999
483*
484 990 CONTINUE
485#if defined(CERNLIB_DEBUG)
486 WRITE (CHMAIL, 1001) NLEVEL
487 CALL GMAIL (0, 0)
488 DO 991 I1=1,NLEVEL,5
489 I2 = I1 + 4
490 IF (I2.GT.NLEVEL) I2 = NLEVEL
491 WRITE (CHMAIL, 1003) (NAMES(I),NUMBER(I),LVOLUM(I),LINDEX(I),
492 + I=I1,I2)
493 CALL GMAIL (0, 0)
494 991 CONTINUE
495 DO 992 I= 1,NLEVEL
496 WRITE (CHMAIL, 1002) (GTRAN(J,I),J=1,3),(GRMAT(J,I),J=1,10)
497 CALL GMAIL (0, 0)
498 992 CONTINUE
499 1001 FORMAT (' GLVOLU : NLEVEL =',I3)
500 1003 FORMAT (5(1X,A4,3I3))
501 1002 FORMAT (1X,13F9.4)
502#endif
503*
504 1000 FORMAT (' GLVOLU : called with useless Level # ',I5)
505 2000 FORMAT (' GLVOLU : Volume ',A4,' not top of tree, or no tree')
506 3000 FORMAT (' GLVOLU : at Level ',I3,' of ',I3,' there are no',
507 * ' contents for Volume ',A4)
508 4000 FORMAT (' GLVOLU : Volume ',A4,' for Level ',I3,
509 * ' does not exist in Volume ',A4)
510 5000 FORMAT (' GLVOLU : at Level ',I3,' asked for #',I3,
511 * ' in divided Volume ',A4,' which has ',I3,' divisions.')
512 6000 FORMAT (' GLVOLU : at Level ',I3,' user name ',A4,
513 * ' not equal to name ',A4,' of division.')
514#if defined(CERNLIB_DEBUG)
515 7000 FORMAT (' GLVOLU : Warning, ',A4,' not top of tree',
516 * ' you should reset NLEVEL to 0 before tracking !')
517#endif
518 8000 FORMAT (' GLVOLU : Volume ',A4,' Level 1 does not exist')
519* END GLVOLU
520 999 END