This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / GEANT321 / geocad / gweucl.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1995/10/24 10:20:47  cernlib
6 * Geant
7 *
8 *
9 #include "geant321/pilot.h"
10 *CMZ :  3.21/02 29/03/94  15.41.32  by  S.Giani
11 *-- Author :
12       SUBROUTINE GWEUCL (LUN,FILNAM,TOPVOL,NUMBER,NLEVEL)
13 *
14 *
15 *     ******************************************************************
16 *     *                                                                *
17 *     *  Write out the geometry of the detector in EUCLID file format  *
18 *     *                                                                *
19 *     *       filnam : will be with the extension .euclid              *
20 *     *       topvol : volume name of the starting node                *
21 *     *       number : copy number of topvol (relevant for gsposp)     *
22 *     *       nlevel : number of  levels in the tree structure         *
23 *     *                to be written out, starting from topvol         *
24 *     *                                                                *
25 *     *       Author : M. Maire                                        *
26 *     *                                                                *
27 *     ******************************************************************
28 *
29 *
30 #include "geant321/gcbank.inc"
31 #include "geant321/gcnum.inc"
32 #include "geant321/gcunit.inc"
33 *
34       CHARACTER*(*) FILNAM
35       CHARACTER*80  FILEXT
36       CHARACTER    CARD*80
37       CHARACTER*4  TOPVOL
38       CHARACTER*20 NATMED, NAMATE
39       CHARACTER*4  NAME, MOTHER, SHAPE(16), KONLY
40 *
41       DIMENSION PAR(50), ATT(20)
42 *
43       DATA SHAPE/'BOX ','TRD1','TRD2','TRAP','TUBE','TUBS','CONE',
44      +           'CONS','SPHE','PARA','PGON','PCON','ELTU','HYPE',
45      +           'GTRA','CTUB'/
46 *
47 *
48 * *** The output filnam name will be with extension '.euclid'
49       IF(INDEX(FILNAM,'.').EQ.0) THEN
50          IT=LNBLNK(FILNAM)
51       ELSE
52          IT=INDEX(FILNAM,'.')-1
53       ENDIF
54 #if !defined(CERNLIB_IBM)
55       FILEXT=FILNAM(1:IT)//'.euclid'
56 #endif
57 #if defined(CERNLIB_IBM)
58       FILEXT='/'//FILNAM(1:MIN(IT,8))//' EUCLID A1'
59       CALL CLTOU(FILEXT)
60 #endif
61 *
62       OPEN (UNIT=LUN,FILE=FILEXT,STATUS='UNKNOWN',FORM='FORMATTED')
63 *
64 * *** Initialisation of the working space
65       IADVOL = NVOLUM
66       IADTMD = IADVOL + NVOLUM
67       IADROT = IADTMD + NTMED
68       IF(JROTM.GT.0) THEN
69          NROTM  = IQ(JROTM-2)
70       ELSE
71          NROTM = 0
72       ENDIF
73       NWTOT  = IADROT + NROTM
74       CALL GWORK (NWTOT)
75       CALL VZERO (IWS(1),NWTOT)
76       MLEVEL = NLEVEL
77       IF (NLEVEL.LE.0) MLEVEL = 20
78 *
79 * *** find the top volume and put it in the stak
80       NUMBR = NUMBER
81       IF (NUMBER.LE.0) NUMBR = 1
82       CALL GFPARA (TOPVOL,NUMBR,1,NPAR,NATT,PAR,ATT)
83       IF (NPAR.LE.0) THEN
84          WRITE (CHMAIL,11100) TOPVOL,NUMBR
85          CALL GMAIL (0,0)
86          RETURN
87       ENDIF
88 *
89 *     authorized shape ?
90       CALL GLOOK (TOPVOL,IQ(JVOLUM+1),NVOLUM,IVO)
91       JVO = LQ(JVOLUM - IVO)
92       ISH =  Q(JVO + 2)
93       IF (ISH.GT.12) THEN
94          WRITE (CHMAIL,11100) TOPVOL,NUMBR
95          CALL GMAIL (0,0)
96          RETURN
97       ENDIF
98 *
99       LEVEL  = 1
100       NVSTAK = 1
101       IWS(NVSTAK)     = IVO
102       IWS(IADVOL+IVO) = LEVEL
103       IVSTAK = 0
104 *
105 * *** Flag all volumes and fill the stak
106 *
107    10 CONTINUE
108 *
109 *     pick the next volume in stak
110       IVSTAK = IVSTAK + 1
111       IVO   = ABS(IWS(IVSTAK))
112       JVO   = LQ(JVOLUM - IVO)
113 *
114 *     flag the tracking medium
115       NUMED =  Q(JVO + 4)
116       IWS(IADTMD + NUMED) = 1
117 *
118 *     get the daughters ...
119       LEVEL = IWS(IADVOL+IVO)
120       IF (LEVEL.LT.MLEVEL) THEN
121          LEVEL = LEVEL + 1
122          NIN = Q(JVO + 3)
123 *
124 *        from division ...
125          IF (NIN.LT.0) THEN
126             JDIV = LQ(JVO  - 1)
127             IVIN =  Q(JDIV + 2)
128             NVSTAK = NVSTAK + 1
129             IWS(NVSTAK)      = -IVIN
130             IWS(IADVOL+IVIN) =  LEVEL
131 *
132 *        from position ...
133          ELSE IF (NIN.GT.0) THEN
134             DO 20 IN=1,NIN
135                JIN  = LQ(JVO - IN)
136                IVIN =  Q(JIN + 2 )
137                JVIN = LQ(JVOLUM - IVIN)
138                ISH  =  Q(JVIN + 2)
139 *              authorized shape ?
140                IF (ISH.LE.12) THEN
141 *                 not yet flagged ?
142                   IF (IWS(IADVOL+IVIN).EQ.0) THEN
143                      NVSTAK = NVSTAK + 1
144                      IWS(NVSTAK)      = IVIN
145                      IWS(IADVOL+IVIN) = LEVEL
146                   ENDIF
147 *                 flag the rotation matrix
148                   IROT =  Q(JIN + 4 )
149                   IF (IROT.GT.0) IWS(IADROT+IROT) = 1
150                ENDIF
151    20       CONTINUE
152          ENDIF
153       ENDIF
154 *
155 *     next volume in stak ?
156       IF (IVSTAK.LT.NVSTAK) GO TO 10
157 *
158 * *** Write down the tracking medium definition
159 *
160       CARD = '!       Tracking medium'
161       WRITE (LUN,10000) CARD
162 *
163       DO 30 ITM = 1,NTMED
164          IF (IWS(IADTMD+ITM).GT.0) THEN
165             JTM  = LQ(JTMED-ITM)
166             CALL UHTOC (IQ(JTM+1),4,NATMED,20)
167             IMAT =  Q(JTM+6)
168             JMA  = LQ(JMATE-IMAT)
169             IF(JMA.LE.0) THEN
170                NAMATE = ' '
171                WRITE(CHMAIL,11300) ITM, NATMED(1:LNBLNK(NATMED))
172                CALL GMAIL(1,1)
173             ELSE
174                CALL UHTOC (IQ(JMA+1),4,NAMATE,20)
175             ENDIF
176             CARD = ' '
177             WRITE (CARD,10100) ITM,NATMED,IMAT,NAMATE
178             WRITE (LUN,'(A)') CARD
179          ENDIF
180    30 CONTINUE
181 *
182 * *** Write down the rotation matrix
183 *
184       CARD = '!       Reperes'
185       WRITE (LUN,10000) CARD
186 *
187       DO 40 IRM = 1,NROTM
188          IF (IWS(IADROT+IRM).GT.0) THEN
189             JRM  = LQ(JROTM-IRM)
190             CARD = ' '
191             WRITE (CARD,10200) IRM,(Q(JRM+K),K=11,16)
192             WRITE (LUN,'(A)') CARD
193          ENDIF
194    40 CONTINUE
195 *
196 * *** Write down the volume definition
197 *
198       CARD = '!       Volumes'
199       WRITE (LUN,10000) CARD
200 *
201       DO 50 IVSTAK = 1,NVSTAK
202          IVO = IWS(IVSTAK)
203          IF (IVO.GT.0) THEN
204             CALL UHTOC (IQ(JVOLUM+IVO),4,NAME,4)
205             JVO  = LQ(JVOLUM-IVO)
206             ISH   = Q(JVO+2)
207             NMED  = Q(JVO+4)
208             IF (IVSTAK.GT.1) NPAR  = Q(JVO+5)
209             CARD = ' '
210             IF (NPAR.GT.0) THEN
211                IF (IVSTAK.GT.1) CALL UCOPY (Q(JVO+7),PAR(1),NPAR)
212                CALL GCKPAR (ISH,NPAR,PAR)
213                WRITE (CARD,10300) NAME,SHAPE(ISH),NMED,NPAR
214                WRITE (LUN,'(A)') CARD
215                WRITE (LUN,10400) (PAR(K),K=1,NPAR)
216             ELSE
217                WRITE (CARD,10300) NAME,SHAPE(ISH),NMED,NPAR
218                WRITE (LUN,'(A)') CARD
219             ENDIF
220          ENDIF
221    50 CONTINUE
222 *
223 * *** Write down the division of volumes
224 *
225       CARD = '!       Divisions'
226       WRITE (LUN,10000) CARD
227 *
228       DO 60 IVSTAK = 1,NVSTAK
229          IVO = ABS(IWS(IVSTAK))
230          JVO  = LQ(JVOLUM-IVO)
231          ISH  =  Q(JVO+2)
232          NIN  =  Q(JVO+3)
233 *        this volume is divided ...
234          IF (NIN.LT.0) THEN
235             JDIV = LQ(JVO-1)
236             IAXE =  Q(JDIV+1)
237             IVIN =  Q(JDIV+2)
238             NDIV =  Q(JDIV+3)
239             C0   =  Q(JDIV+4)
240             STEP =  Q(JDIV+5)
241             JVIN = LQ(JVOLUM-IVIN)
242             NMED =  Q(JVIN+4)
243             CALL UHTOC (IQ(JVOLUM+IVO ),4,MOTHER,4)
244             CALL UHTOC (IQ(JVOLUM+IVIN),4,NAME  ,4)
245             CARD = ' '
246             IF ((STEP.LE.0.).OR.(ISH.GE.11)) THEN
247 *              volume with negative parameter or gsposp or PGON ...
248                WRITE (CARD,10500) NAME,MOTHER,NDIV,IAXE
249             ELSEIF ((NDIV.LE.0).OR.(ISH.EQ.10)) THEN
250 *              volume with negative parameter or gsposp or PARA ...
251                NDVMX = ABS(NDIV)
252                WRITE (CARD,10600) NAME,MOTHER,STEP,IAXE,NMED,NDVMX
253             ELSE
254 *              normal volume : all kind of division are equivalent
255                WRITE (CARD,10700) NAME,MOTHER,STEP,IAXE,C0,NMED,NDIV
256             ENDIF
257             WRITE (LUN,'(A)') CARD
258          ENDIF
259    60 CONTINUE
260 *
261 * *** Write down the the positionnement of volumes
262 *
263       card = '!       Positionnements'
264       WRITE (LUN,10000) CARD
265 *
266       DO 80 IVSTAK = 1,NVSTAK
267          IVO = ABS(IWS(IVSTAK))
268          CALL UHTOC (IQ(JVOLUM+IVO ),4,MOTHER,4)
269          JVO  = LQ(JVOLUM-IVO)
270          NIN  =  Q(JVO+3)
271 *        this volume has daughters ...
272          IF (NIN.GT.0) THEN
273             DO 70 IN=1,NIN
274                JIN  = LQ(JVO-IN)
275                IVIN =  Q(JIN +2)
276                NUMB =  Q(JIN +3)
277                IROT =  Q(JIN +4)
278                X    =  Q(JIN +5)
279                Y    =  Q(JIN +6)
280                Z    =  Q(JIN +7)
281                KONLY = 'ONLY'
282                IF (Q(JIN+8).NE.1.) KONLY = 'MANY'
283                CALL UHTOC (IQ(JVOLUM+IVIN),4,NAME  ,4)
284                JVIN = LQ(JVOLUM-IVIN)
285                ISH  =  Q(JVIN+2)
286                CARD = ' '
287 *              gspos or gsposp ?
288                NDATA = IQ(JIN-1)
289                IF (NDATA.EQ.8) THEN
290                   WRITE (CARD,10800) NAME,NUMB,MOTHER,X,Y,Z,IROT,KONLY
291                   WRITE (LUN,'(A)') CARD
292                ELSE
293                   NPAR =  Q(JIN+9)
294                   CALL UCOPY (Q(JIN+10),PAR(1),NPAR)
295                   CALL GCKPAR (ISH,NPAR,PAR)
296                   WRITE (CARD,10900) NAME,NUMB,MOTHER,X,Y,Z,IROT,KONLY,
297      +            NPAR
298                   WRITE (LUN,'(A)') CARD
299                   WRITE (LUN,10400) (PAR(K),K=1,NPAR)
300                ENDIF
301    70       CONTINUE
302          ENDIF
303    80 CONTINUE
304 *
305       WRITE (LUN,11000)
306       CLOSE (LUN)
307 *
308       WRITE (CHMAIL,11200) FILEXT(1:IT+9)
309       CALL GMAIL (1,1)
310 *
311 10000 FORMAT (1H!,/,A,/,1H!)
312 *
313 10100 FORMAT ('TMED',2(1X,I3,1X,1H',A20,1H'))
314 10200 FORMAT ('ROTM',1X,I3,6(1X,F8.3))
315 10300 FORMAT ('VOLU',2(1X,1H',A4,1H'),2(1X,I3))
316 10400 FORMAT (      (5X,6(1X,F11.5)))
317 10500 FORMAT ('DIVN',2(1X,1H',A4,1H'),2(1X,I3))
318 10600 FORMAT ('DIVT',2(1X,1H',A4,1H'),1X,F11.5,3(1X,I3))
319 10700 FORMAT ('DVT2',2(1X,1H',A4,1H'),1X,F11.5,1X,I3,1X,F11.5,2(1X,I3))
320 10800 FORMAT ('POSI',1X,1H',A4,1H',1X,I3,1X,1H',A4,1H',3(1X,F11.5),1X,I3
321      &              ,1X,1H',A4,1H')
322 10900 FORMAT ('POSP',1X,1H',A4,1H',1X,I3,1X,1H',A4,1H',3(1X,F11.5),1X,I3
323      &              ,1X,1H',A4,1H',1X,I3)
324 11000 FORMAT ('END')
325 *
326 11100 FORMAT (' *** GWEUCL *** top volume : ',A4,' number :',I3,
327      &        ' can not be a valid root')
328 11200 FORMAT (' *** GWEUCL *** file: ',A,' is now written out')
329 11300 FORMAT (' *** GWEUCL *** material not defined for tracking ',
330      +        'medium ',I5,' ',A)
331 *
332       END