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