GEANT321/geocad/gdexca.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:20:46  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/03 13/09/94  18.53.20  by  S.Ravndal
  11 *-- Author :
  12       SUBROUTINE GDEXCA(NAME,NBINS)
  13 C.
  14 C.    ******************************************************************
  15 C.    *                                                                *
  16 C.    *    Based on GDRAW, calculates parameters of each volume        *
  17 C.    *    Areas marked JV + NH                                        *
  18 C.    *                                                                *
  19 C.    *    Called by GTXSET                                            *
  20 C.    *                                                                *
  21 C.    *       Authors : R.Brun, A.McPherson, P.Zanarini,   *********   *
  22 C.    *                 J.Salt, S.Giani , J. Vuoskoski,  N. Hoimyr     *
  23 C.    ******************************************************************
  24 C.
  25 C JV
  26 #include "geant321/gcsetf.inc"
  27 C
  28 #include "geant321/gcbank.inc"
  29 #include "geant321/gcvolu.inc"
  30 #include "geant321/gcunit.inc"
  31 #include "geant321/gcdraw.inc"
  32 #include "geant321/gconst.inc"
  33 #include "geant321/gcnum.inc"
  34 #include "geant321/gcdlin.inc"
  35 #include "geant321/gcmutr.inc"
  36 *JS
  37 #include "geant321/gcgobj.inc"
  38 C+SEQ,CGHPAR.
  39 #include "geant321/gchiln.inc"
  40 #include "geant321/gcspee.inc"
  41 *JS
  42 *
  43 *
  44 C   this by jv
  45       DIMENSION PARMJV(9), POSJV(3)
  46 C         if volume is divided jdvinf(level) is 1
  47       DIMENSION JDVINF(0:15)
  48       CHARACTER*4 JVVOLU,JVVOLD, NAME,NAMEE2
  49       CHARACTER*10 VOLNAM
  50       DIMENSION X(3),ATT(10)
  51       DIMENSION LVOLS(15),LINDX(15),LNAMES(15)
  52       DIMENSION GPAR(50,15)
  53 *     INTEGER START, OLDOLD, PASS
  54 C
  55       IF(JCADNT.EQ.0) THEN
  56          CALL MZBOOK(IXSTOR,JCADNT,JCADNT,1,'CADI',1,1,0,2,-1)
  57          CALL MZBOOK(IXSTOR,JBUF1,
  58      +               JCADNT,-1,'CAD1',0,0,NVOLUM,2,-1)
  59       ENDIF
  60       DO 10 JV=1,NVOLUM
  61          IQ(JBUF1+JV)=0
  62    10 CONTINUE
  63       JDVINF(0)=0
  64       JLEVEL=0
  65       MYSEEN=1
  66       JVVOLU='----'
  67 C
  68 C            Set IOBJ to VOLUME
  69 C
  70       IOBJ=1
  71 C
  72 C             Save /GCVOLU/ if necessary
  73 C
  74       IFCVOL=0
  75       IF (NLEVEL.NE.0) THEN
  76          CALL GSCVOL
  77          IFCVOL=1
  78       ENDIF
  79       IF (NLEVEL.LT.0) NLEVEL=IABS(NLEVEL)
  80 C
  81 C             Start of general code
  82 C
  83       CALL GLOOK(NAME,IQ(JVOLUM+1),NVOLUM,IVO)
  84       IF(IVO.LE.0)GO TO 210
  85 C
  86 C             Theta, phi and psi angles are normalized in [0-360[ range
  87 C
  88 *
  89       JVO=LQ(JVOLUM-IVO)
  90 C
  91 C             Initialize JIN to switch correctly CALL GFPARA/GFIPAR
  92 C
  93       JIN=0
  94 C
  95       LEVSEE=1000
  96 C
  97       IF (IDRNUM.NE.0) GO TO 30
  98 C
  99 C             Initialize for new geometry structure
 100 C
 101       IF (JGPAR.EQ.0) CALL GMEDIN
 102       CALL GLMOTH(NAME,1,NLEV,LVOLS,LINDX)
 103       DO 20 J=1, NLEV
 104          LNAMES(J)=IQ(JVOLUM+LVOLS(J))
 105    20 CONTINUE
 106       NLEV=NLEV+1
 107       CALL UCTOH(NAME,LNAMES(NLEV),4,4)
 108       LINDX(NLEV)=1
 109       CALL GLVOLU(NLEV, LNAMES, LINDX, IER)
 110 C
 111       NLVTOP=NLEVEL
 112 C
 113    30 CONTINUE
 114 C
 115       NLMIN=NLEVEL
 116       NLMAX=NLEVEL
 117 C
 118       IF (IDRNUM.NE.0) GO TO 70
 119 C
 120       CALL GFPARA(NAME,1,1,NPAR,NATT,GPAR(1,NLEVEL),ATT)
 121 C
 122       IF (NPAR.LE.0) GO TO 220
 123 C
 124       DO 60  LLL=1,NLEVEL
 125          DO 50 I=1,3
 126             GTRAN(I,LLL)=0.0
 127             X(I)=0.0
 128             DO 40 J=1,3
 129                K=(I-1)*3+J
 130                GRMAT(K,LLL)=0.0
 131    40       CONTINUE
 132             K=I*4-3
 133             GRMAT(K,LLL)=1.0
 134    50    CONTINUE
 135          GRMAT(10,LLL)=0.0
 136    60 CONTINUE
 137 C
 138 C             Ready for general case code
 139 C
 140    70 CONTINUE
 141 *SG
 142 *    Taking volume name and shape from Zebra Structure
 143 *
 144       IVOLNA=IQ(JVOLUM+IVO)
 145       ISHAPE=Q(JVO+2)
 146 *SG
 147 C
 148       IF (IDRNUM.NE.0) GO TO 80
 149 C
 150       IF (NLEVEL.EQ.NLVTOP) GO TO 90
 151 C
 152    80 CONTINUE
 153 C
 154       IF (IDRNUM.NE.0.AND.JIN.EQ.0) THEN
 155          CALL UHTOC(NAMES(NLEVEL),4,NAMEE2,4)
 156          CALL GFPARA(NAMEE2,NUMBER(NLEVEL),1,NPAR,
 157      +            NATT,GPAR(1,NLEVEL),ATT)
 158       ELSE
 159          NPAR=Q(JVO+5)
 160          NATT=Q(JVO+6)
 161          JATT=JVO+7+NPAR
 162          CALL UCOPY(Q(JATT),ATT,NATT)
 163       ENDIF
 164 C
 165    90 CONTINUE
 166 C
 167       WORK=ATT(1)
 168       SEEN=ATT(2)
 169
 170 *
 171       LINSTY=ATT(3)
 172       LINWID=ATT(4)
 173       LINCOL=ATT(5)
 174       LINFIL=ATT(6)
 175       CALL MVBITS(LINCOL,0,4,LINATT,7)
 176       CALL MVBITS(LINWID,0,3,LINATT,11)
 177       CALL MVBITS(LINSTY,0,3,LINATT,14)
 178       CALL MVBITS(LINFIL,0,3,LINATT,17)
 179 *
 180 ***SG
 181 *
 182 *    New logic scanning the geometrical tree:
 183 *    A volume can set bounds OR be compared with bounds;
 184 *    this can happen only IF a relationship mother-daughters exists.
 185 *
 186 *    Optimization for Hidden Volume Removal:
 187 *    POS and DIV cases are considered at the same time.
 188 *
 189 *     IF(START.EQ.1)THEN
 190 *
 191 *        IF(NLEVEL.GT.OLDOLD)THEN
 192 *           IF(PASS.NE.0)THEN
 193 *              S1=0
 194 *              S2=0
 195 *              S3=0
 196 *              SS1=0
 197 *              SS2=0
 198 *              SS3=0
 199 *              SRAGMX=0
 200 *              SRAGMN=0
 201 *              PASS=0
 202 *              IF(SEEN.EQ.0.OR.SEEN.EQ.-1)PASS=1
 203 *              OLDOLD=NLEVEL
 204 *           ENDIF
 205 *
 206 *        ELSE IF(NLEVEL.LE.OLDOLD)THEN
 207 *           S1=0
 208 *           S2=0
 209 *           S3=0
 210 *           SS1=0
 211 *           SS2=0
 212 *           SS3=0
 213 *           SRAGMX=0
 214 *           SRAGMN=0
 215 *           PASS=0
 216 *           IF(SEEN.EQ.0.OR.SEEN.EQ.-1)PASS=1
 217 *           OLDOLD=NLEVEL
 218 *        ENDIF
 219 *     ENDIF
 220 *
 221 *     IF(OLDOLD.EQ.0.AND.(SEEN.EQ.1.OR.SEEN.EQ.-2))THEN
 222 *        START=1
 223 *        PASS=0
 224 *        OLDOLD=NLEVEL
 225 *     ENDIF
 226 C
 227 C             WORK attribute enabled ?
 228 C
 229       IF(WORK.LE.0.)GO TO 200
 230 C
 231 C             SEEN attribute processing
 232 C
 233       IF (SEEN.LT.50.) GO TO 100
 234       ISEENL=SEEN/10.+0.5
 235       SEEN=ISEENL-10
 236   100 CONTINUE
 237 C
 238       IF(NLEVEL.LE.LEVSEE)LEVSEE=1000
 239       IF(SEEN.EQ.-1.)GO TO 200
 240       IF (NLEVEL.GT.LEVSEE) GO TO 200
 241       IF(SEEN.EQ.0.)GO TO 150
 242       IF (SEEN.EQ.-2.) LEVSEE=NLEVEL
 243 C
 244 *              Standard Mode: Output to SET
 245 *
 246 C-----------------------JV----Mod NH---------------------------
 247 C        Get positioning variables
 248 C
 249       IF(NLEVEL.LT.JLEVEL)THEN
 250          CALL GSATT(JVVOLU,'SEEN',MYSEEN)
 251          Q(JBUF1+MYIVO)=0
 252       ENDIF
 253       JVO=LQ(JVOLUM-IVO)
 254       NIN=Q(JVO+3)
 255       IF(NIN.LT.0) THEN
 256          JDVINF(NLEVEL)=1
 257       ELSE
 258          JDVINF(NLEVEL)=0
 259       ENDIF
 260 C
 261 C            if division
 262       IF (JDVINF(NLEVEL-1).EQ.1) THEN
 263 C
 264          IF (IQ(JBUF1+IVO).LT.NBINS) THEN
 265             DO 110 JV=1, 9
 266                PARMJV(JV)=GRMAT(JV,NLEVEL)
 267   110       CONTINUE
 268 C
 269             DO 120 JV=1, 3
 270                POSJV(JV)=GTRAN(JV,NLEVEL)
 271   120       CONTINUE
 272 C
 273 C        Appends new name VOLNAM to each volume, with index.
 274 C
 275             IQ(JBUF1+IVO)=IQ(JBUF1+IVO)+1
 276             WRITE(VOLNAM(1:5),10200)IVOLNA
 277             WRITE(VOLNAM(6:10),'(I4.0)')IQ(JBUF1+IVO)
 278 C
 279 C        Call SHAPE to SET routines
 280 C
 281 C        Updates SET block sequence number:
 282             N1=N1+1
 283             CALL GETSHP(ISHAPE,GPAR(1,NLEVEL))
 284 C
 285 C        Position the volumes
 286 C
 287             N1=N1+1
 288             CALL GPOSI(PARMJV,POSJV,VOLNAM,LINCOL)
 289 C
 290          ELSE
 291             JVVOLD=JVVOLU
 292             CALL UHTOC(IVOLNA,4,JVVOLU,4)
 293             IF(JVVOLD.NE.JVVOLU)MYSEEN=ATT(2)
 294             CALL GSATT(JVVOLU,'SEEN',-1)
 295             JLEVEL=NLEVEL
 296             MYIVO=IVO
 297             GOTO 200
 298          ENDIF
 299 C
 300 C       normal volumes
 301       ELSE
 302          DO 130 JV=1, 9
 303             PARMJV(JV)=GRMAT(JV,NLEVEL)
 304   130    CONTINUE
 305 C
 306          DO 140 JV=1, 3
 307             POSJV(JV)=GTRAN(JV,NLEVEL)
 308   140    CONTINUE
 309 C
 310 C        Appends new name VOLNAM to each volume, with index.
 311 C
 312          IQ(JBUF1+IVO)=IQ(JBUF1+IVO)+1
 313          WRITE(VOLNAM(1:5),10200)IVOLNA
 314          WRITE(VOLNAM(6:10),'(I4.0)')IQ(JBUF1+IVO)
 315 C
 316 C        Call SHAPE to SET routines
 317 C
 318 C        Updates SET block sequence number:
 319          N1=N1+1
 320          CALL GETSHP(ISHAPE,GPAR(1,NLEVEL))
 321 C
 322 C        Position the volumes
 323 C
 324          N1=N1+1
 325          CALL GPOSI(PARMJV,POSJV,VOLNAM,LINCOL)
 326       ENDIF
 327 C------------------------------------------------------------------------
 328 C         Output of material list
 329 C
 330       IF (IQ(JBUF1+IVO).EQ.1) THEN
 331          NTRMED=Q(JVO+4)
 332          CALL GPTSET (IVOLNA, NTRMED)
 333       ENDIF
 334 C------------------------------END JV------------------------------------
 335 C
 336 *JS
 337 *
 338 *     Logic has been modified  >>>>>
 339 *
 340 *
 341 *JS
 342       IF(SEEN.EQ.-2.)GO TO 200
 343 C
 344   150 CONTINUE
 345 C
 346 ***   IF (IDRNUM.NE.0) GO TO 999
 347 C
 348 C             Skip User shapes (not yet implemented)
 349 C
 350 **      ISEARC=Q(JVO+1)
 351 C
 352 C             Now go down the tree
 353 C
 354       NIN=Q(JVO+3)
 355       IF(NIN.EQ.0) GO TO 200
 356       IF(NIN.LT.0) GO TO 170
 357 C
 358 C             Contents placed by GSPOS
 359 C
 360       IN=0
 361       IF(NLMAX.GT.NLEVEL) IN=LINDEX(NLEVEL+1)
 362       IN=IN+1
 363       IF(IN.GT.NIN.AND.NLEVEL.EQ.NLMIN) GO TO 230
 364 *
 365       IF(IN.GT.NIN) GO TO 190
 366 *
 367       CALL GMEPOS(JVO,IN,X,0)
 368 *
 369       NPAR=IQ(JGPAR+NLEVEL)
 370       DO 160 I=1,NPAR
 371          GPAR(I,NLEVEL)=Q(LQ(JGPAR-NLEVEL)+I)
 372   160 CONTINUE
 373 *
 374       IVO=LVOLUM(NLEVEL)
 375       JVO=LQ(JVOLUM-IVO)
 376       NLMAX=NLEVEL
 377       GO TO 70
 378 C
 379   170 CONTINUE
 380 C
 381 C             Contents by division
 382 C
 383       IN=0
 384       IF(NLMAX.GT.NLEVEL) IN=LINDEX(NLEVEL+1)
 385       IN=IN+1
 386       CALL GMEDIV(JVO,IN,X,0)
 387 *
 388       IF (IN.EQ.0) GO TO 190
 389 *
 390       NPAR=IQ(JGPAR+NLEVEL)
 391       DO 180 I=1,NPAR
 392          GPAR(I,NLEVEL)=Q(LQ(JGPAR-NLEVEL)+I)
 393   180 CONTINUE
 394 *
 395       IF (IN.EQ.0) GO TO 190
 396 *
 397       IVO=LVOLUM(NLEVEL)
 398       JVO=LQ(JVOLUM-IVO)
 399       NLMAX=NLEVEL
 400       GO TO 70
 401 C
 402   190 CONTINUE
 403       NLMAX=NLEVEL
 404   200 CONTINUE
 405       NLEVEL=NLEVEL-1
 406       IF(NLEVEL.LT.NLMIN) GO TO 230
 407       IVO=LVOLUM(NLEVEL)
 408       JVO=LQ(JVOLUM-IVO)
 409       GO TO 150
 410 C
 411   210 WRITE(CHMAIL,10000)NAME
 412       CALL GMAIL(0,0)
 413       GO TO 230
 414 C
 415   220 CONTINUE
 416 C
 417 C             TOP OF THE TREE HAS PARAMETERS SET BY GSPOSP.
 418 C             BUT GDRAW DOES NOT HAVE ACCESS TO THE IN BANK
 419 C             WHICH PLACED IT IN ITS MOTHER.
 420 C
 421       WRITE(CHMAIL,10100) NAME
 422       CALL GMAIL(0,0)
 423 C
 424   230 CONTINUE
 425 *
 426 ***SG
 427 *
 428 *JS
 429       IF(KCGST.EQ.-9)THEN
 430          KSHIFT=0
 431          IF(JCG.NE.0)CALL MZDROP(IXSTOR,JCG,' ')
 432          IF(JCGOBJ.NE.0)CALL MZDROP(IXSTOR,JCGOBJ,' ')
 433          CALL GDCGRS
 434          IF(JCGCOL.NE.0)CALL MZDROP(IXSTOR,JCGCOL,' ')
 435          LARECG(1)=0
 436          CALL MZGARB(IXSTOR+1,0)
 437          NCLAS2=0
 438          NCLAS3=0
 439       ENDIF
 440       ICUT=0
 441       IF (IFCVOL.EQ.1) THEN
 442          CALL GFCVOL
 443       ELSE
 444          NLEVEL=0
 445       ENDIF
 446 C
 447 C             Restore permanent value of color and return
 448 C
 449       CALL GDCOL(0)
 450       IOBJ=0
 451 C
 452 10000 FORMAT(' *** GDEXCA *** : Volume ',A4,' does not exist')
 453 10100 FORMAT(' *** GDEXCA *** : Top of tree ',A4,' parameters defined',
 454      +       '  by GSPOSP - info not available to GDEXCA.')
 455 10200 FORMAT(A4,'_')
 456       END