This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / GEANT321 / geocad / gdexca.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1995/10/24 10:20:46  cernlib
6 * Geant
7 *
8 *
9 #include "geant321/pilot.h"
10 *CMZ :  3.21/03 13/09/94  18.53.20  by  S.Ravndal
11 *-- Author :
12       SUBROUTINE GDEXCA(NAME,NBINS)
13 C.
14 C.    ******************************************************************
15 C.    *                                                                *
16 C.    *    Based on GDRAW, calculates parameters of each volume        *
17 C.    *    Areas marked JV + NH                                        *
18 C.    *                                                                *
19 C.    *    Called by GTXSET                                            *
20 C.    *                                                                *
21 C.    *       Authors : R.Brun, A.McPherson, P.Zanarini,   *********   *
22 C.    *                 J.Salt, S.Giani , J. Vuoskoski,  N. Hoimyr     *
23 C.    ******************************************************************
24 C.
25 C JV
26 #include "geant321/gcsetf.inc"
27 C
28 #include "geant321/gcbank.inc"
29 #include "geant321/gcvolu.inc"
30 #include "geant321/gcunit.inc"
31 #include "geant321/gcdraw.inc"
32 #include "geant321/gconst.inc"
33 #include "geant321/gcnum.inc"
34 #include "geant321/gcdlin.inc"
35 #include "geant321/gcmutr.inc"
36 *JS
37 #include "geant321/gcgobj.inc"
38 C+SEQ,CGHPAR.
39 #include "geant321/gchiln.inc"
40 #include "geant321/gcspee.inc"
41 *JS
42 *
43 *
44 C   this by jv
45       DIMENSION PARMJV(9), POSJV(3)
46 C         if volume is divided jdvinf(level) is 1
47       DIMENSION JDVINF(0:15)
48       CHARACTER*4 JVVOLU,JVVOLD, NAME,NAMEE2
49       CHARACTER*10 VOLNAM
50       DIMENSION X(3),ATT(10)
51       DIMENSION LVOLS(15),LINDX(15),LNAMES(15)
52       DIMENSION GPAR(50,15)
53 *     INTEGER START, OLDOLD, PASS
54 C
55       IF(JCADNT.EQ.0) THEN
56          CALL MZBOOK(IXSTOR,JCADNT,JCADNT,1,'CADI',1,1,0,2,-1)
57          CALL MZBOOK(IXSTOR,JBUF1,
58      +               JCADNT,-1,'CAD1',0,0,NVOLUM,2,-1)
59       ENDIF
60       DO 10 JV=1,NVOLUM
61          IQ(JBUF1+JV)=0
62    10 CONTINUE
63       JDVINF(0)=0
64       JLEVEL=0
65       MYSEEN=1
66       JVVOLU='----'
67 C
68 C            Set IOBJ to VOLUME
69 C
70       IOBJ=1
71 C
72 C             Save /GCVOLU/ if necessary
73 C
74       IFCVOL=0
75       IF (NLEVEL.NE.0) THEN
76          CALL GSCVOL
77          IFCVOL=1
78       ENDIF
79       IF (NLEVEL.LT.0) NLEVEL=IABS(NLEVEL)
80 C
81 C             Start of general code
82 C
83       CALL GLOOK(NAME,IQ(JVOLUM+1),NVOLUM,IVO)
84       IF(IVO.LE.0)GO TO 210
85 C
86 C             Theta, phi and psi angles are normalized in [0-360[ range
87 C
88 *
89       JVO=LQ(JVOLUM-IVO)
90 C
91 C             Initialize JIN to switch correctly CALL GFPARA/GFIPAR
92 C
93       JIN=0
94 C
95       LEVSEE=1000
96 C
97       IF (IDRNUM.NE.0) GO TO 30
98 C
99 C             Initialize for new geometry structure
100 C
101       IF (JGPAR.EQ.0) CALL GMEDIN
102       CALL GLMOTH(NAME,1,NLEV,LVOLS,LINDX)
103       DO 20 J=1, NLEV
104          LNAMES(J)=IQ(JVOLUM+LVOLS(J))
105    20 CONTINUE
106       NLEV=NLEV+1
107       CALL UCTOH(NAME,LNAMES(NLEV),4,4)
108       LINDX(NLEV)=1
109       CALL GLVOLU(NLEV, LNAMES, LINDX, IER)
110 C
111       NLVTOP=NLEVEL
112 C
113    30 CONTINUE
114 C
115       NLMIN=NLEVEL
116       NLMAX=NLEVEL
117 C
118       IF (IDRNUM.NE.0) GO TO 70
119 C
120       CALL GFPARA(NAME,1,1,NPAR,NATT,GPAR(1,NLEVEL),ATT)
121 C
122       IF (NPAR.LE.0) GO TO 220
123 C
124       DO 60  LLL=1,NLEVEL
125          DO 50 I=1,3
126             GTRAN(I,LLL)=0.0
127             X(I)=0.0
128             DO 40 J=1,3
129                K=(I-1)*3+J
130                GRMAT(K,LLL)=0.0
131    40       CONTINUE
132             K=I*4-3
133             GRMAT(K,LLL)=1.0
134    50    CONTINUE
135          GRMAT(10,LLL)=0.0
136    60 CONTINUE
137 C
138 C             Ready for general case code
139 C
140    70 CONTINUE
141 *SG
142 *    Taking volume name and shape from Zebra Structure
143 *
144       IVOLNA=IQ(JVOLUM+IVO)
145       ISHAPE=Q(JVO+2)
146 *SG
147 C
148       IF (IDRNUM.NE.0) GO TO 80
149 C
150       IF (NLEVEL.EQ.NLVTOP) GO TO 90
151 C
152    80 CONTINUE
153 C
154       IF (IDRNUM.NE.0.AND.JIN.EQ.0) THEN
155          CALL UHTOC(NAMES(NLEVEL),4,NAMEE2,4)
156          CALL GFPARA(NAMEE2,NUMBER(NLEVEL),1,NPAR,
157      +            NATT,GPAR(1,NLEVEL),ATT)
158       ELSE
159          NPAR=Q(JVO+5)
160          NATT=Q(JVO+6)
161          JATT=JVO+7+NPAR
162          CALL UCOPY(Q(JATT),ATT,NATT)
163       ENDIF
164 C
165    90 CONTINUE
166 C
167       WORK=ATT(1)
168       SEEN=ATT(2)
169  
170 *
171       LINSTY=ATT(3)
172       LINWID=ATT(4)
173       LINCOL=ATT(5)
174       LINFIL=ATT(6)
175       CALL MVBITS(LINCOL,0,4,LINATT,7)
176       CALL MVBITS(LINWID,0,3,LINATT,11)
177       CALL MVBITS(LINSTY,0,3,LINATT,14)
178       CALL MVBITS(LINFIL,0,3,LINATT,17)
179 *
180 ***SG
181 *
182 *    New logic scanning the geometrical tree:
183 *    A volume can set bounds OR be compared with bounds;
184 *    this can happen only IF a relationship mother-daughters exists.
185 *
186 *    Optimization for Hidden Volume Removal:
187 *    POS and DIV cases are considered at the same time.
188 *
189 *     IF(START.EQ.1)THEN
190 *
191 *        IF(NLEVEL.GT.OLDOLD)THEN
192 *           IF(PASS.NE.0)THEN
193 *              S1=0
194 *              S2=0
195 *              S3=0
196 *              SS1=0
197 *              SS2=0
198 *              SS3=0
199 *              SRAGMX=0
200 *              SRAGMN=0
201 *              PASS=0
202 *              IF(SEEN.EQ.0.OR.SEEN.EQ.-1)PASS=1
203 *              OLDOLD=NLEVEL
204 *           ENDIF
205 *
206 *        ELSE IF(NLEVEL.LE.OLDOLD)THEN
207 *           S1=0
208 *           S2=0
209 *           S3=0
210 *           SS1=0
211 *           SS2=0
212 *           SS3=0
213 *           SRAGMX=0
214 *           SRAGMN=0
215 *           PASS=0
216 *           IF(SEEN.EQ.0.OR.SEEN.EQ.-1)PASS=1
217 *           OLDOLD=NLEVEL
218 *        ENDIF
219 *     ENDIF
220 *
221 *     IF(OLDOLD.EQ.0.AND.(SEEN.EQ.1.OR.SEEN.EQ.-2))THEN
222 *        START=1
223 *        PASS=0
224 *        OLDOLD=NLEVEL
225 *     ENDIF
226 C
227 C             WORK attribute enabled ?
228 C
229       IF(WORK.LE.0.)GO TO 200
230 C
231 C             SEEN attribute processing
232 C
233       IF (SEEN.LT.50.) GO TO 100
234       ISEENL=SEEN/10.+0.5
235       SEEN=ISEENL-10
236   100 CONTINUE
237 C
238       IF(NLEVEL.LE.LEVSEE)LEVSEE=1000
239       IF(SEEN.EQ.-1.)GO TO 200
240       IF (NLEVEL.GT.LEVSEE) GO TO 200
241       IF(SEEN.EQ.0.)GO TO 150
242       IF (SEEN.EQ.-2.) LEVSEE=NLEVEL
243 C
244 *              Standard Mode: Output to SET
245 *
246 C-----------------------JV----Mod NH---------------------------
247 C        Get positioning variables
248 C
249       IF(NLEVEL.LT.JLEVEL)THEN
250          CALL GSATT(JVVOLU,'SEEN',MYSEEN)
251          Q(JBUF1+MYIVO)=0
252       ENDIF
253       JVO=LQ(JVOLUM-IVO)
254       NIN=Q(JVO+3)
255       IF(NIN.LT.0) THEN
256          JDVINF(NLEVEL)=1
257       ELSE
258          JDVINF(NLEVEL)=0
259       ENDIF
260 C
261 C            if division
262       IF (JDVINF(NLEVEL-1).EQ.1) THEN
263 C
264          IF (IQ(JBUF1+IVO).LT.NBINS) THEN
265             DO 110 JV=1, 9
266                PARMJV(JV)=GRMAT(JV,NLEVEL)
267   110       CONTINUE
268 C
269             DO 120 JV=1, 3
270                POSJV(JV)=GTRAN(JV,NLEVEL)
271   120       CONTINUE
272 C
273 C        Appends new name VOLNAM to each volume, with index.
274 C
275             IQ(JBUF1+IVO)=IQ(JBUF1+IVO)+1
276             WRITE(VOLNAM(1:5),10200)IVOLNA
277             WRITE(VOLNAM(6:10),'(I4.0)')IQ(JBUF1+IVO)
278 C
279 C        Call SHAPE to SET routines
280 C
281 C        Updates SET block sequence number:
282             N1=N1+1
283             CALL GETSHP(ISHAPE,GPAR(1,NLEVEL))
284 C
285 C        Position the volumes
286 C
287             N1=N1+1
288             CALL GPOSI(PARMJV,POSJV,VOLNAM,LINCOL)
289 C
290          ELSE
291             JVVOLD=JVVOLU
292             CALL UHTOC(IVOLNA,4,JVVOLU,4)
293             IF(JVVOLD.NE.JVVOLU)MYSEEN=ATT(2)
294             CALL GSATT(JVVOLU,'SEEN',-1)
295             JLEVEL=NLEVEL
296             MYIVO=IVO
297             GOTO 200
298          ENDIF
299 C
300 C       normal volumes
301       ELSE
302          DO 130 JV=1, 9
303             PARMJV(JV)=GRMAT(JV,NLEVEL)
304   130    CONTINUE
305 C
306          DO 140 JV=1, 3
307             POSJV(JV)=GTRAN(JV,NLEVEL)
308   140    CONTINUE
309 C
310 C        Appends new name VOLNAM to each volume, with index.
311 C
312          IQ(JBUF1+IVO)=IQ(JBUF1+IVO)+1
313          WRITE(VOLNAM(1:5),10200)IVOLNA
314          WRITE(VOLNAM(6:10),'(I4.0)')IQ(JBUF1+IVO)
315 C
316 C        Call SHAPE to SET routines
317 C
318 C        Updates SET block sequence number:
319          N1=N1+1
320          CALL GETSHP(ISHAPE,GPAR(1,NLEVEL))
321 C
322 C        Position the volumes
323 C
324          N1=N1+1
325          CALL GPOSI(PARMJV,POSJV,VOLNAM,LINCOL)
326       ENDIF
327 C------------------------------------------------------------------------
328 C         Output of material list
329 C
330       IF (IQ(JBUF1+IVO).EQ.1) THEN
331          NTRMED=Q(JVO+4)
332          CALL GPTSET (IVOLNA, NTRMED)
333       ENDIF
334 C------------------------------END JV------------------------------------
335 C
336 *JS
337 *
338 *     Logic has been modified  >>>>>
339 *
340 *
341 *JS
342       IF(SEEN.EQ.-2.)GO TO 200
343 C
344   150 CONTINUE
345 C
346 ***   IF (IDRNUM.NE.0) GO TO 999
347 C
348 C             Skip User shapes (not yet implemented)
349 C
350 **      ISEARC=Q(JVO+1)
351 C
352 C             Now go down the tree
353 C
354       NIN=Q(JVO+3)
355       IF(NIN.EQ.0) GO TO 200
356       IF(NIN.LT.0) GO TO 170
357 C
358 C             Contents placed by GSPOS
359 C
360       IN=0
361       IF(NLMAX.GT.NLEVEL) IN=LINDEX(NLEVEL+1)
362       IN=IN+1
363       IF(IN.GT.NIN.AND.NLEVEL.EQ.NLMIN) GO TO 230
364 *
365       IF(IN.GT.NIN) GO TO 190
366 *
367       CALL GMEPOS(JVO,IN,X,0)
368 *
369       NPAR=IQ(JGPAR+NLEVEL)
370       DO 160 I=1,NPAR
371          GPAR(I,NLEVEL)=Q(LQ(JGPAR-NLEVEL)+I)
372   160 CONTINUE
373 *
374       IVO=LVOLUM(NLEVEL)
375       JVO=LQ(JVOLUM-IVO)
376       NLMAX=NLEVEL
377       GO TO 70
378 C
379   170 CONTINUE
380 C
381 C             Contents by division
382 C
383       IN=0
384       IF(NLMAX.GT.NLEVEL) IN=LINDEX(NLEVEL+1)
385       IN=IN+1
386       CALL GMEDIV(JVO,IN,X,0)
387 *
388       IF (IN.EQ.0) GO TO 190
389 *
390       NPAR=IQ(JGPAR+NLEVEL)
391       DO 180 I=1,NPAR
392          GPAR(I,NLEVEL)=Q(LQ(JGPAR-NLEVEL)+I)
393   180 CONTINUE
394 *
395       IF (IN.EQ.0) GO TO 190
396 *
397       IVO=LVOLUM(NLEVEL)
398       JVO=LQ(JVOLUM-IVO)
399       NLMAX=NLEVEL
400       GO TO 70
401 C
402   190 CONTINUE
403       NLMAX=NLEVEL
404   200 CONTINUE
405       NLEVEL=NLEVEL-1
406       IF(NLEVEL.LT.NLMIN) GO TO 230
407       IVO=LVOLUM(NLEVEL)
408       JVO=LQ(JVOLUM-IVO)
409       GO TO 150
410 C
411   210 WRITE(CHMAIL,10000)NAME
412       CALL GMAIL(0,0)
413       GO TO 230
414 C
415   220 CONTINUE
416 C
417 C             TOP OF THE TREE HAS PARAMETERS SET BY GSPOSP.
418 C             BUT GDRAW DOES NOT HAVE ACCESS TO THE IN BANK
419 C             WHICH PLACED IT IN ITS MOTHER.
420 C
421       WRITE(CHMAIL,10100) NAME
422       CALL GMAIL(0,0)
423 C
424   230 CONTINUE
425 *
426 ***SG
427 *
428 *JS
429       IF(KCGST.EQ.-9)THEN
430          KSHIFT=0
431          IF(JCG.NE.0)CALL MZDROP(IXSTOR,JCG,' ')
432          IF(JCGOBJ.NE.0)CALL MZDROP(IXSTOR,JCGOBJ,' ')
433          CALL GDCGRS
434          IF(JCGCOL.NE.0)CALL MZDROP(IXSTOR,JCGCOL,' ')
435          LARECG(1)=0
436          CALL MZGARB(IXSTOR+1,0)
437          NCLAS2=0
438          NCLAS3=0
439       ENDIF
440       ICUT=0
441       IF (IFCVOL.EQ.1) THEN
442          CALL GFCVOL
443       ELSE
444          NLEVEL=0
445       ENDIF
446 C
447 C             Restore permanent value of color and return
448 C
449       CALL GDCOL(0)
450       IOBJ=0
451 C
452 10000 FORMAT(' *** GDEXCA *** : Volume ',A4,' does not exist')
453 10100 FORMAT(' *** GDEXCA *** : Top of tree ',A4,' parameters defined',
454      +       '  by GSPOSP - info not available to GDEXCA.')
455 10200 FORMAT(A4,'_')
456       END