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