5 * Revision 1.1.1.1 1995/10/24 10:20:51 cernlib
9 #include "geant321/pilot.h"
10 *CMZ : 3.21/04 18/01/95 19.56.13 by S.Giani
12 SUBROUTINE GLVOLU (NLEV, LNAM, LNUM, IER)
14 C. ******************************************************************
16 C. * Loads the common block GCVOLU for the volume at lebel NLEV *
17 C. * as described by the lists of names (LNAM) and numbers (LNUM) *
19 C. * The routine is optimized and does not re-compute the part of *
20 C. * history already available in GCVOLU. *
22 C. * IER returns non zero in case of fatal error *
24 C. * Called by : 'User', GDRVOL *
25 C. * Authors : S.Banerjee, F.Bruyant, A.McPherson *
27 C. ******************************************************************
29 #include "geant321/gcbank.inc"
30 #include "geant321/gconsp.inc"
31 #include "geant321/gcunit.inc"
32 #include "geant321/gcvolu.inc"
34 INTEGER LNUM(*), LNAM(*), IDTYP(3,12)
35 DIMENSION LVOLS(NLVMAX), LINDX(NLVMAX)
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,
44 C. ------------------------------------------------------------------
48 IF (NLEVL.LE.0.OR.NLEVL.GT.NLVMAX) GO TO 910
50 CALL MZBOOK (IXCONS, JGPAR, JGPAR, 1, 'GPAR', NLVMAX, 0,
53 IF (NLEVEL.EQ.0) GO TO 20
55 * *** Scan tree from top to bottom to
56 * check if some levels are already filled
58 NLMX = MIN (NLEVL, NLEVEL)
61 IF (LNAM(I).NE.NAMES(I)) GO TO 15
62 IF (LNUM(I).NE.NUMBER(I)) GO TO 15
65 IF (NLEVL.GT.NLEVEL) GO TO 95
67 15 IF (NLEVEL.NE.0) GO TO 95
69 * *** Special case, first volume
71 20 IF (JVOLUM.EQ.0) GO TO 920
72 IF (IQ(JVOLUM+1).EQ.LNAM(1)) THEN
75 #if defined(CERNLIB_DEBUG)
76 WRITE (CHMAIL, 7000) LNAM(1)
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
86 WRITE (CHMAIL, 8000) LNAM(1)
93 NAMES(NLEVEL) = IQ(JVOLUM+IVO)
94 NUMBER(NLEVEL) = LNUM(1)
96 IF (LQ(JVO).EQ.0) THEN
105 IQ(JGPAR+NLEVEL) = Q(JVO+5)
106 LQ(JGPAR-NLEVEL) = JVO + 6
108 CALL UHTOC(NAMES,4,KNAME,4)
109 CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
111 JVOM = LQ(JVOLUM-LVOLS(NLDM))
114 LINDEX(NLEVEL) = LNUM(1)
119 IF (IFIX(Q(JIN+2)).NE.LVOLUM(1)) GO TO 70
120 IF (IFIX(Q(JIN+3)).NE.LNUM(1)) GO TO 70
126 75 JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
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))
141 IF (JPAR.EQ.0) GO TO 77
145 IF (LINDEX(1).GT.NDIV) THEN
147 NAME = IQ(JVOLUM+LVOLS(NLDM))
150 IF (IQ(JPAR-3).GT.1) THEN
151 IF (LINDEX(1).GT.0) THEN
152 JPAR = LQ(JPAR-LINDEX(1))
160 IQ(JGPAR+NLEVEL) = IQ(JPAR+5)
161 LQ(JGPAR-NLEVEL) = JPAR + 5
164 IF (NPAR.EQ.0.AND.NIN.GT.0) THEN
165 IQ(JGPAR+NLEVEL) = Q(JIN+9)
166 LQ(JGPAR-NLEVEL) = JIN+9
168 IQ(JGPAR+NLEVEL) = NPAR
169 LQ(JGPAR-NLEVEL) = JVO + 6
174 IQ(JGPAR+NLEVEL) = Q(JVO+5)
175 LQ(JGPAR-NLEVEL) = JVO + 6
196 * *** Check if there are volumes up in the tree where development
199 95 IF (LVOLUM(1).EQ.1.OR.NLDEV(1).EQ.1) THEN
202 CALL UHTOC(NAMES,4,KNAME,4)
203 CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
213 IF (NIN.EQ.0) GO TO 930
218 * * Content obtained by positioning
223 IF (IQ(JVOLUM+IVOT).NE.LNAM(NL1)) GO TO 110
225 IF (INUM.EQ.LNUM(NL1)) GO TO 115
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
236 JPAR = LQ(JPAR-LINDEX(ILEV+1))
238 IF (JPAR.EQ.0) GO TO 125
239 ELSE IF (IQ(JPAR-3).GT.1) THEN
240 JPAR = LQ(JPAR-LINDEX(ILEV+1))
248 ELSE IF (NLDM.GT.0) THEN
249 JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
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))
263 IF (IQ(JPAR+1).EQ.0) THEN
264 IF (ILEV.EQ.NL1) THEN
267 JPAR = LQ(JPAR-LINDEX(ILEV))
269 IF (JPAR.EQ.0) GO TO 125
270 ELSE IF (IQ(JPAR-3).GT.1) THEN
271 JPAR = LQ(JPAR-LINDEX(ILEV))
281 125 JVOT = LQ(JVOLUM-IVOT)
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))
298 * * This section for divided objects
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))
316 IF (ILEV.EQ.NLEVEL-1) THEN
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)))
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))
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))
348 IF (ILEV.EQ.NLEVEL) THEN
363 IF (IN.LT.1.OR.IN.GT.NDIV) THEN
369 IF (IQ(JPAR-3).GT.1) THEN
380 GONLY(NL1) = GONLY(NLEVEL)
384 IDT = IDTYP(IAXIS,ISH)
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)
394 IF (GRMAT(10,NLEVEL).EQ.0.0) THEN
396 152 GTRAN(I,NL1) = GTRAN(I,NLEVEL)+XC(I)
398 153 GRMAT(I,NL1) = GRMAT(I,NLEVEL)
400 CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), XC, 0,
401 + GTRAN(1,NL1), GRMAT(1,NL1))
404 ELSE IF (IDT.EQ.3.OR.IDT.EQ.4) THEN
406 PH0 = DEGRAD * (ORIG + (IN - 0.5) * STEP)
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)
422 IF (PH0.EQ.0.0.AND.GRMAT(10,NLEVEL).EQ.0.0) THEN
430 155 GTRAN(I,NL1) = GTRAN(I,NLEVEL)
432 156 GRMAT(I,NL1) = GRMAT(I,NLEVEL)
438 NAMES(NL1) = LNAM(NL1)
439 NUMBER(NL1) = LNUM(NL1)
441 IF (LQ(LQ(JVOLUM-IVOT)).EQ.0) THEN
449 IF (NLEVEL.EQ.NLEVL) GO TO 990
455 WRITE (CHMAIL, 1000) NLEV
460 WRITE (CHMAIL, 2000) LNAM(1)
465 WRITE (CHMAIL, 3000) NLEVEL,NLEV,NAMES(NLEVEL)
470 WRITE (CHMAIL, 4000) LNAM(NL1),NL1,NAMES(NLEVEL)
475 WRITE (CHMAIL, 5000) NL1,LNUM(NL1),NAME,NDIV
480 WRITE (CHMAIL, 6000) NL1,LNAM(NL1),IQ(JVOLUM+IVOT)
485 #if defined(CERNLIB_DEBUG)
486 WRITE (CHMAIL, 1001) NLEVEL
490 IF (I2.GT.NLEVEL) I2 = NLEVEL
491 WRITE (CHMAIL, 1003) (NAMES(I),NUMBER(I),LVOLUM(I),LINDEX(I),
496 WRITE (CHMAIL, 1002) (GTRAN(J,I),J=1,3),(GRMAT(J,I),J=1,10)
499 1001 FORMAT (' GLVOLU : NLEVEL =',I3)
500 1003 FORMAT (5(1X,A4,3I3))
501 1002 FORMAT (1X,13F9.4)
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 !')
518 8000 FORMAT (' GLVOLU : Volume ',A4,' Level 1 does not exist')