5 * Revision 1.1.1.1 1999/05/18 15:55:17 fca
8 * Revision 1.1.1.1 1995/10/24 10:20:47 cernlib
12 #include "geant321/pilot.h"
13 *CMZ : 3.21/02 29/03/94 15.41.32 by S.Giani
15 SUBROUTINE GWEUCL (LUN,FILNAM,TOPVOL,NUMBER,NLEVEL)
18 * ******************************************************************
20 * * Write out the geometry of the detector in EUCLID file format *
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 *
28 * * Author : M. Maire *
30 * ******************************************************************
33 #include "geant321/gcbank.inc"
34 #include "geant321/gcnum.inc"
35 #include "geant321/gcunit.inc"
41 CHARACTER*20 NATMED, NAMATE
42 CHARACTER*4 NAME, MOTHER, SHAPE(16), KONLY
44 DIMENSION PAR(100), ATT(20)
46 DATA SHAPE/'BOX ','TRD1','TRD2','TRAP','TUBE','TUBS','CONE',
47 + 'CONS','SPHE','PARA','PGON','PCON','ELTU','HYPE',
51 * *** The output filnam name will be with extension '.euclid'
52 IF(INDEX(FILNAM,'.').EQ.0) THEN
55 IT=INDEX(FILNAM,'.')-1
57 #if !defined(CERNLIB_IBM)
58 FILEXT=FILNAM(1:IT)//'.euclid'
60 #if defined(CERNLIB_IBM)
61 FILEXT='/'//FILNAM(1:MIN(IT,8))//' EUCLID A1'
65 OPEN (UNIT=LUN,FILE=FILEXT,STATUS='UNKNOWN',FORM='FORMATTED')
67 * *** Initialisation of the working space
69 IADTMD = IADVOL + NVOLUM
70 IADROT = IADTMD + NTMED
76 NWTOT = IADROT + NROTM
78 CALL VZERO (IWS(1),NWTOT)
80 IF (NLEVEL.LE.0) MLEVEL = 20
82 * *** find the top volume and put it in the stak
84 IF (NUMBER.LE.0) NUMBR = 1
85 CALL GFPARA (TOPVOL,NUMBR,1,NPAR,NATT,PAR,ATT)
87 WRITE (CHMAIL,11100) TOPVOL,NUMBR
93 CALL GLOOK (TOPVOL,IQ(JVOLUM+1),NVOLUM,IVO)
94 JVO = LQ(JVOLUM - IVO)
97 WRITE (CHMAIL,11100) TOPVOL,NUMBR
105 IWS(IADVOL+IVO) = LEVEL
108 * *** Flag all volumes and fill the stak
112 * pick the next volume in stak
114 IVO = ABS(IWS(IVSTAK))
115 JVO = LQ(JVOLUM - IVO)
117 * flag the tracking medium
119 IWS(IADTMD + NUMED) = 1
121 * get the daughters ...
122 LEVEL = IWS(IADVOL+IVO)
123 IF (LEVEL.LT.MLEVEL) THEN
133 IWS(IADVOL+IVIN) = LEVEL
136 ELSE IF (NIN.GT.0) THEN
140 JVIN = LQ(JVOLUM - IVIN)
145 IF (IWS(IADVOL+IVIN).EQ.0) THEN
148 IWS(IADVOL+IVIN) = LEVEL
150 * flag the rotation matrix
152 IF (IROT.GT.0) IWS(IADROT+IROT) = 1
158 * next volume in stak ?
159 IF (IVSTAK.LT.NVSTAK) GO TO 10
161 * *** Write down the tracking medium definition
163 CARD = '! Tracking medium'
164 WRITE (LUN,10000) CARD
167 IF (IWS(IADTMD+ITM).GT.0) THEN
169 CALL UHTOC (IQ(JTM+1),4,NATMED,20)
174 WRITE(CHMAIL,11300) ITM, NATMED(1:LNBLNK(NATMED))
177 CALL UHTOC (IQ(JMA+1),4,NAMATE,20)
180 WRITE (CARD,10100) ITM,NATMED,IMAT,NAMATE
181 WRITE (LUN,'(A)') CARD
185 * *** Write down the rotation matrix
188 WRITE (LUN,10000) CARD
191 IF (IWS(IADROT+IRM).GT.0) THEN
194 WRITE (CARD,10200) IRM,(Q(JRM+K),K=11,16)
195 WRITE (LUN,'(A)') CARD
199 * *** Write down the volume definition
202 WRITE (LUN,10000) CARD
204 DO 50 IVSTAK = 1,NVSTAK
207 CALL UHTOC (IQ(JVOLUM+IVO),4,NAME,4)
211 IF (IVSTAK.GT.1) NPAR = Q(JVO+5)
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)
220 WRITE (CARD,10300) NAME,SHAPE(ISH),NMED,NPAR
221 WRITE (LUN,'(A)') CARD
226 * *** Write down the division of volumes
229 WRITE (LUN,10000) CARD
231 DO 60 IVSTAK = 1,NVSTAK
232 IVO = ABS(IWS(IVSTAK))
236 * this volume is divided ...
244 JVIN = LQ(JVOLUM-IVIN)
246 CALL UHTOC (IQ(JVOLUM+IVO ),4,MOTHER,4)
247 CALL UHTOC (IQ(JVOLUM+IVIN),4,NAME ,4)
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 ...
255 WRITE (CARD,10600) NAME,MOTHER,STEP,IAXE,NMED,NDVMX
257 * normal volume : all kind of division are equivalent
258 WRITE (CARD,10700) NAME,MOTHER,STEP,IAXE,C0,NMED,NDIV
260 WRITE (LUN,'(A)') CARD
264 * *** Write down the the positionnement of volumes
266 card = '! Positionnements'
267 WRITE (LUN,10000) CARD
269 DO 80 IVSTAK = 1,NVSTAK
270 IVO = ABS(IWS(IVSTAK))
271 CALL UHTOC (IQ(JVOLUM+IVO ),4,MOTHER,4)
274 * this volume has daughters ...
285 IF (Q(JIN+8).NE.1.) KONLY = 'MANY'
286 CALL UHTOC (IQ(JVOLUM+IVIN),4,NAME ,4)
287 JVIN = LQ(JVOLUM-IVIN)
293 WRITE (CARD,10800) NAME,NUMB,MOTHER,X,Y,Z,IROT,KONLY
294 WRITE (LUN,'(A)') CARD
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,
301 WRITE (LUN,'(A)') CARD
302 WRITE (LUN,10400) (PAR(K),K=1,NPAR)
311 WRITE (CHMAIL,11200) FILEXT(1:IT+9)
314 10000 FORMAT (1H!,/,A,/,1H!)
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
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)
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)