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