GEANT321/ggeom/glvolu.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:20:51  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/04 18/01/95  19.56.13  by  S.Giani
  11 *-- Author :
  12       SUBROUTINE GLVOLU (NLEV, LNAM, LNUM, IER)
  13 C.
  14 C.    ******************************************************************
  15 C.    *                                                                *
  16 C.    *   Loads the common block GCVOLU for the volume at lebel NLEV   *
  17 C.    *   as described by the lists of names (LNAM) and numbers (LNUM) *
  18 C.    *                                                                *
  19 C.    *   The routine is optimized and does not re-compute the part of *
  20 C.    *   history already available in GCVOLU.                         *
  21 C.    *                                                                *
  22 C.    *   IER returns non zero in case of fatal error                  *
  23 C.    *                                                                *
  24 C.    *   Called by : 'User', GDRVOL                                   *
  25 C.    *   Authors   : S.Banerjee, F.Bruyant, A.McPherson               *
  26 C.    *                                                                *
  27 C.    ******************************************************************
  28 C.
  29 #include "geant321/gcbank.inc"
  30 #include "geant321/gconsp.inc"
  31 #include "geant321/gcunit.inc"
  32 #include "geant321/gcvolu.inc"
  33       PARAMETER  (NLVMAX=15)
  34       INTEGER    LNUM(*), LNAM(*), IDTYP(3,12)
  35       DIMENSION  LVOLS(NLVMAX), LINDX(NLVMAX)
  36       REAL       XC(3)
  37       CHARACTER*4 KNAME
  38       SAVE IDTYP
  39 C.
  40       DATA IDTYP / 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 2, 3, 1,
  41      +             2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 4, 3, 1, 1, 1,
  42      +             2, 3, 1, 2, 3, 1/
  43 C.
  44 C.    ------------------------------------------------------------------
  45 *
  46       IER = 0
  47       NLEVL=NLEV
  48       IF (NLEVL.LE.0.OR.NLEVL.GT.NLVMAX) GO TO 910
  49       IF (JGPAR.EQ.0) THEN
  50          CALL MZBOOK (IXCONS, JGPAR, JGPAR, 1, 'GPAR', NLVMAX, 0,
  51      +                NLVMAX, 2, 0)
  52       ENDIF
  53       IF (NLEVEL.EQ.0)                 GO TO 20
  54 *
  55 * *** Scan tree from top to bottom to
  56 *       check if some levels are already filled
  57 *
  58       NLMX = MIN (NLEVL, NLEVEL)
  59       NLEVEL = 0
  60       DO 10 I = 1,NLMX
  61          IF (LNAM(I).NE.NAMES(I))  GO TO 15
  62          IF (LNUM(I).NE.NUMBER(I)) GO TO 15
  63          NLEVEL = NLEVEL +1
  64    10 CONTINUE
  65       IF (NLEVL.GT.NLEVEL) GO TO 95
  66       nlevel=0
  67    15 IF (NLEVEL.NE.0)    GO TO 95
  68 *
  69 * *** Special case, first volume
  70 *
  71    20 IF (JVOLUM.EQ.0)    GO TO 920
  72       IF (IQ(JVOLUM+1).EQ.LNAM(1)) THEN
  73          IVO = 1
  74       ELSE
  75 #if defined(CERNLIB_DEBUG)
  76          WRITE (CHMAIL, 7000) LNAM(1)
  77          CALL GMAIL (0, 0)
  78 #endif
  79          IF (IQ(JVOLUM-1).LE.1) GO TO 920
  80          DO 25 IV=2,IQ(JVOLUM-1)
  81             IF (IQ(JVOLUM+IV).EQ.LNAM(1)) THEN
  82                IVO = IV
  83                GO TO 30
  84             ENDIF
  85    25    CONTINUE
  86          WRITE (CHMAIL, 8000) LNAM(1)
  87          CALL GMAIL (0, 0)
  88          GO TO 999
  89       ENDIF
  90    30 NLEVEL = 1
  91       JVO = LQ(JVOLUM-IVO)
  92       LVOLUM(NLEVEL) = IVO
  93       NAMES(NLEVEL)  = IQ(JVOLUM+IVO)
  94       NUMBER(NLEVEL) = LNUM(1)
  95       GONLY(NLEVEL)  = 1.
  96       IF (LQ(JVO).EQ.0) THEN
  97          NLDEV(1) = NLVMAX
  98       ELSE
  99          NLDEV(1) = 1
 100       ENDIF
 101       IF (IVO.EQ.1) THEN
 102          LINDEX(NLEVEL) = 1
 103          LINMX (NLEVEL) = 1
 104          NLDM = 0
 105          IQ(JGPAR+NLEVEL) = Q(JVO+5)
 106          LQ(JGPAR-NLEVEL) = JVO + 6
 107       ELSE
 108          CALL UHTOC(NAMES,4,KNAME,4)
 109          CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
 110          IF (NLDM.GT.0) THEN
 111             JVOM = LQ(JVOLUM-LVOLS(NLDM))
 112             NIN  = Q(JVOM+3)
 113             IF (NIN.LT.0) THEN
 114                LINDEX(NLEVEL) = LNUM(1)
 115             ELSE
 116                LINMX(NLEVEL)  = NIN
 117                DO 70 IN = 1, NIN
 118                   JIN  = LQ(JVOM-IN)
 119                   IF (IFIX(Q(JIN+2)).NE.LVOLUM(1)) GO TO 70
 120                   IF (IFIX(Q(JIN+3)).NE.LNUM(1))   GO TO 70
 121                   LINDEX(NLEVEL) = IN
 122                   GO TO 75
 123    70          CONTINUE
 124                GO TO 920
 125             ENDIF
 126    75       JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
 127             IF (NLDM.GT.1) THEN
 128                DO 76 ILEV = 2, NLDM
 129                   IF (IQ(JPAR+1).EQ.0) THEN
 130                      JPAR = LQ(JPAR-LINDX(ILEV))
 131                      IF (JPAR.EQ.0) GO TO 77
 132                   ELSE IF (IQ(JPAR-3).GT.1) THEN
 133                      JPAR = LQ(JPAR-LINDX(ILEV))
 134                   ELSE
 135                      JPAR = LQ(JPAR-1)
 136                   ENDIF
 137    76          CONTINUE
 138             ENDIF
 139             IF (NIN.GT.0) THEN
 140                JPAR = LQ(JPAR-IN)
 141                IF (JPAR.EQ.0) GO TO 77
 142             ELSE
 143                NDIV = IQ(JPAR+1)
 144                LINMX(NLEVEL) = NDIV
 145                IF (LINDEX(1).GT.NDIV) THEN
 146                   NL1  = 1
 147                   NAME = IQ(JVOLUM+LVOLS(NLDM))
 148                   GO TO 950
 149                ENDIF
 150                IF (IQ(JPAR-3).GT.1) THEN
 151                   IF (LINDEX(1).GT.0) THEN
 152                      JPAR = LQ(JPAR-LINDEX(1))
 153                   ELSE
 154                      JPAR = LQ(JPAR-1)
 155                   ENDIF
 156                ELSE
 157                   JPAR = LQ(JPAR-1)
 158                ENDIF
 159             ENDIF
 160             IQ(JGPAR+NLEVEL) = IQ(JPAR+5)
 161             LQ(JGPAR-NLEVEL) = JPAR + 5
 162             GO TO 78
 163    77       NPAR = Q(JVO+5)
 164             IF (NPAR.EQ.0.AND.NIN.GT.0) THEN
 165                IQ(JGPAR+NLEVEL) = Q(JIN+9)
 166                LQ(JGPAR-NLEVEL) = JIN+9
 167             ELSE
 168                IQ(JGPAR+NLEVEL) = NPAR
 169                LQ(JGPAR-NLEVEL) = JVO + 6
 170             ENDIF
 171          ELSE
 172             LINDEX(NLEVEL) = 1
 173             LINMX(NLEVEL)  = 1
 174             IQ(JGPAR+NLEVEL) = Q(JVO+5)
 175             LQ(JGPAR-NLEVEL) = JVO + 6
 176          ENDIF
 177       ENDIF
 178    78 CONTINUE
 179 *
 180       DO 90 I = 1,3
 181          GTRAN(I,1) = 0.
 182          DO 80 J = 1,3
 183             K = (I-1)*3 +J
 184             GRMAT(K,1) = 0.
 185    80    CONTINUE
 186          K = I*4 -3
 187          GRMAT(K,1) = 1.
 188    90 CONTINUE
 189       GRMAT(10,1) = 0.
 190       IF (NLEVL.GT.1) THEN
 191          GO TO 100
 192       ELSE
 193          GO TO 990
 194       ENDIF
 195 *
 196 * *** Check if there are volumes up in the tree where development
 197 *           structure exists
 198 *
 199    95 IF (LVOLUM(1).EQ.1.OR.NLDEV(1).EQ.1) THEN
 200          NLDM = 0
 201       ELSE
 202          CALL UHTOC(NAMES,4,KNAME,4)
 203          CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
 204       ENDIF
 205 *
 206 *  ** Next level
 207 *
 208   100 CONTINUE
 209       IVO = LVOLUM(NLEVEL)
 210       JVO = LQ(JVOLUM-IVO)
 211       NLD = NLDEV(NLEVEL)
 212       NIN = Q(JVO+3)
 213       IF (NIN.EQ.0) GO TO 930
 214       NL1 = NLEVEL +1
 215 *
 216       IF (NIN.GT.0) THEN
 217 *
 218 *  *     Content obtained by positioning
 219 *
 220          DO 110 IN=1,NIN
 221             JIN=LQ(JVO-IN)
 222             IVOT=Q(JIN+2)
 223             IF (IQ(JVOLUM+IVOT).NE.LNAM(NL1)) GO TO 110
 224             INUM = Q(JIN+3)
 225             IF (INUM.EQ.LNUM(NL1)) GO TO 115
 226   110    CONTINUE
 227          GO TO 940
 228   115    IF (NLEVEL.GE.NLD) THEN
 229 *           (case with JVOLUM structure locally developed)
 230             JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
 231             DO 120 ILEV = NLD, NLEVEL
 232                IF (IQ(JPAR+1).EQ.0) THEN
 233                   IF (ILEV.EQ.NLEVEL) THEN
 234                      JPAR = LQ(JPAR-IN)
 235                   ELSE
 236                      JPAR = LQ(JPAR-LINDEX(ILEV+1))
 237                   ENDIF
 238                   IF (JPAR.EQ.0) GO TO 125
 239                ELSE IF (IQ(JPAR-3).GT.1) THEN
 240                   JPAR = LQ(JPAR-LINDEX(ILEV+1))
 241                ELSE
 242                   JPAR = LQ(JPAR-1)
 243                ENDIF
 244   120       CONTINUE
 245             JPAR = JPAR + 5
 246             NPAR = IQ(JPAR)
 247             GO TO 130
 248          ELSE IF (NLDM.GT.0) THEN
 249             JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
 250             IF (NLDM.GT.1) THEN
 251                DO 121 ILEV = 2, NLDM
 252                   IF (IQ(JPAR+1).EQ.0) THEN
 253                      JPAR = LQ(JPAR-LINDX(ILEV))
 254                      IF (JPAR.EQ.0)   GO TO 125
 255                   ELSE IF (IQ(JPAR-3).GT.1) THEN
 256                      JPAR = LQ(JPAR-LINDX(ILEV))
 257                   ELSE
 258                      JPAR = LQ(JPAR-1)
 259                   ENDIF
 260   121          CONTINUE
 261             ENDIF
 262             DO 122 ILEV = 1, NL1
 263                IF (IQ(JPAR+1).EQ.0) THEN
 264                   IF (ILEV.EQ.NL1) THEN
 265                      JPAR = LQ(JPAR-IN)
 266                   ELSE
 267                      JPAR = LQ(JPAR-LINDEX(ILEV))
 268                   ENDIF
 269                   IF (JPAR.EQ.0) GO TO 125
 270                ELSE IF (IQ(JPAR-3).GT.1) THEN
 271                   JPAR = LQ(JPAR-LINDEX(ILEV))
 272                ELSE
 273                   JPAR = LQ(JPAR-1)
 274                ENDIF
 275   122       CONTINUE
 276             JPAR = JPAR + 5
 277             NPAR = IQ(JPAR)
 278             GO TO 130
 279          ENDIF
 280 *        (normal case)
 281   125    JVOT = LQ(JVOLUM-IVOT)
 282          NPAR = Q(JVOT+5)
 283          IF (NPAR.EQ.0) THEN
 284             JPAR = JIN + 9
 285             NPAR = Q(JPAR)
 286          ELSE
 287             JPAR = JVOT + 6
 288          ENDIF
 289 *
 290   130    IROTT = Q(JIN+4)
 291          NINSK = NIN
 292          GONLY(NL1) = Q(JIN+8)
 293          CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), Q(JIN+5), IROTT
 294      +,               GTRAN(1,NL1), GRMAT(1,NL1))
 295 *
 296       ELSE
 297 *
 298 *  *     This section for divided objects
 299 *
 300          JDIV = LQ(JVO-1)
 301          IVOT = Q(JDIV+2)
 302          IF (LNAM(NL1).NE.IQ(JVOLUM+IVOT)) GO TO 960
 303          JVOT = LQ(JVOLUM-IVOT)
 304          IF (NLEVEL.GT.NLD) THEN
 305 *           (case with JVOLUM structure locally developed)
 306             JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
 307             DO 135 ILEV = NLD, NLEVEL-1
 308                IF (IQ(JPAR+1).EQ.0) THEN
 309                   JPAR = LQ(JPAR-LINDEX(ILEV+1))
 310                   IF (JPAR.EQ.0) GO TO 140
 311                ELSE IF (IQ(JPAR-3).GT.1) THEN
 312                   JPAR = LQ(JPAR-LINDEX(ILEV+1))
 313                ELSE
 314                   JPAR = LQ(JPAR-1)
 315                ENDIF
 316                IF (ILEV.EQ.NLEVEL-1) THEN
 317                   NDIV = IQ(JPAR+1)
 318                   ORIG =  Q(JPAR+2)
 319                   STEP =  Q(JPAR+3)
 320                ENDIF
 321   135       CONTINUE
 322             GO TO 145
 323          ELSE IF (NLD.EQ.NLEVEL) THEN
 324             JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
 325          ELSE IF (NLDM.GT.0) THEN
 326             JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
 327             IF (NLDM.GT.1) THEN
 328                DO 136 ILEV = 2, NLDM
 329                   IF (IQ(JPAR+1).EQ.0) THEN
 330                      JPAR = LQ(JPAR-LINDX(ILEV))
 331                      IF (JPAR.EQ.0) GO TO 140
 332                   ELSE IF (IQ(JPAR-3).GT.1) THEN
 333                      JPAR = LQ(JPAR-LINDX(ILEV))
 334                   ELSE
 335                      JPAR = LQ(JPAR-1)
 336                   ENDIF
 337   136          CONTINUE
 338             ENDIF
 339             DO 137 ILEV = 1, NLEVEL
 340                IF (IQ(JPAR+1).EQ.0) THEN
 341                   JPAR = LQ(JPAR-LINDEX(ILEV))
 342                   IF (JPAR.EQ.0) GO TO 140
 343                ELSE IF (IQ(JPAR-3).GT.1) THEN
 344                   JPAR = LQ(JPAR-LINDEX(ILEV))
 345                ELSE
 346                   JPAR = LQ(JPAR-1)
 347                ENDIF
 348                IF (ILEV.EQ.NLEVEL) THEN
 349                   NDIV = IQ(JPAR+1)
 350                   ORIG =  Q(JPAR+2)
 351                   STEP =  Q(JPAR+3)
 352                ENDIF
 353   137       CONTINUE
 354             GO TO 145
 355          ELSE
 356             JPAR = 0
 357          ENDIF
 358 *        (normal case)
 359   140    NDIV = Q(JDIV+3)
 360          ORIG = Q(JDIV+4)
 361          STEP = Q(JDIV+5)
 362   145    IN   = LNUM(NL1)
 363          IF (IN.LT.1.OR.IN.GT.NDIV) THEN
 364             NAME = NAMES(NLEVEL)
 365             GO TO 950
 366          ENDIF
 367 *
 368          IF (JPAR.NE.0) THEN
 369             IF (IQ(JPAR-3).GT.1) THEN
 370                JPAR = LQ(JPAR-IN)
 371             ELSE
 372                JPAR = LQ(JPAR-1)
 373             ENDIF
 374             JPAR = JPAR + 5
 375             NPAR = IQ(JPAR)
 376          ELSE
 377             NPAR = Q(JVOT+5)
 378             JPAR = JVOT + 6
 379          ENDIF
 380          GONLY(NL1) = GONLY(NLEVEL)
 381 *
 382          IAXIS = Q(JDIV+1)
 383          ISH   = Q(JVO+2)
 384          IDT   = IDTYP(IAXIS,ISH)
 385          NINSK = NDIV
 386 *
 387          IF (IDT.EQ.1) THEN
 388             DO 151 I = 1, 3
 389   151       XC(I) = 0.
 390             XC(IAXIS) = ORIG + (IN - 0.5) * STEP
 391             IF (ISH.EQ.4.OR.(ISH.EQ.10.AND.IAXIS.NE.1)) THEN
 392                CALL GCENT (IAXIS, XC)
 393             ENDIF
 394             IF (GRMAT(10,NLEVEL).EQ.0.0) THEN
 395                DO 152 I = 1, 3
 396   152          GTRAN(I,NL1) = GTRAN(I,NLEVEL)+XC(I)
 397                DO 153 I = 1, 10
 398   153          GRMAT(I,NL1) = GRMAT(I,NLEVEL)
 399             ELSE
 400                CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), XC, 0,
 401      +                      GTRAN(1,NL1), GRMAT(1,NL1))
 402             ENDIF
 403 *
 404          ELSE IF (IDT.EQ.3.OR.IDT.EQ.4) THEN
 405             IF (IDT.EQ.3) THEN
 406                PH0  = DEGRAD * (ORIG + (IN - 0.5) * STEP)
 407                CPHR = COS (PH0)
 408                SPHR = SIN (PH0)
 409             ELSE
 410                PH0  = 0.0
 411                CPHR = 1.0
 412                SPHR = 0.0
 413             ENDIF
 414             DO 154 I = 1, 3
 415                GTRAN(I  ,NL1) = GTRAN(I  ,NLEVEL)
 416                GRMAT(I  ,NL1) = GRMAT(I  ,NLEVEL)*CPHR
 417      +                        + GRMAT(I+3,NLEVEL)*SPHR
 418                GRMAT(I+3,NL1) = GRMAT(I+3,NLEVEL)*CPHR
 419      +                        - GRMAT(I  ,NLEVEL)*SPHR
 420                GRMAT(I+6,NL1) = GRMAT(I+6,NLEVEL)
 421   154       CONTINUE
 422             IF (PH0.EQ.0.0.AND.GRMAT(10,NLEVEL).EQ.0.0) THEN
 423                GRMAT(10,NL1) = 0.0
 424             ELSE
 425                GRMAT(10,NL1) = 1.0
 426             ENDIF
 427 *
 428          ELSE
 429             DO 155 I = 1, 3
 430   155       GTRAN(I,NL1) = GTRAN(I,NLEVEL)
 431             DO 156 I = 1, 10
 432   156       GRMAT(I,NL1) = GRMAT(I,NLEVEL)
 433          ENDIF
 434       ENDIF
 435 *
 436   200 LINDEX(NL1) = IN
 437       LVOLUM(NL1) = IVOT
 438       NAMES(NL1)  = LNAM(NL1)
 439       NUMBER(NL1) = LNUM(NL1)
 440       LINMX(NL1)  = NINSK
 441       IF (LQ(LQ(JVOLUM-IVOT)).EQ.0) THEN
 442          NLDEV(NL1) = NLD
 443       ELSE
 444          NLDEV(NL1) = NL1
 445       ENDIF
 446       IQ(JGPAR+NL1) = NPAR
 447       LQ(JGPAR-NL1) = JPAR
 448       NLEVEL = NL1
 449       IF (NLEVEL.EQ.NLEVL) GO TO 990
 450       GO TO 100
 451 *
 452 * *** Error messages
 453 *
 454   910 IER = 1
 455       WRITE (CHMAIL, 1000) NLEV
 456       CALL GMAIL (0, 0)
 457       GO TO 999
 458 *
 459   920 IER = 2
 460       WRITE (CHMAIL, 2000) LNAM(1)
 461       CALL GMAIL (0, 0)
 462       GO TO 999
 463 *
 464   930 IER = 3
 465       WRITE (CHMAIL, 3000) NLEVEL,NLEV,NAMES(NLEVEL)
 466       CALL GMAIL (0, 0)
 467       GO TO 999
 468 *
 469   940 IER = 4
 470       WRITE (CHMAIL, 4000) LNAM(NL1),NL1,NAMES(NLEVEL)
 471       CALL GMAIL (0, 0)
 472       GO TO 999
 473 *
 474   950 IER = 5
 475       WRITE (CHMAIL, 5000) NL1,LNUM(NL1),NAME,NDIV
 476       CALL GMAIL (0, 0)
 477       GO TO 999
 478 *
 479   960 IER = 6
 480       WRITE (CHMAIL, 6000) NL1,LNAM(NL1),IQ(JVOLUM+IVOT)
 481       CALL GMAIL (0, 0)
 482       GO TO 999
 483 *
 484   990 CONTINUE
 485 #if defined(CERNLIB_DEBUG)
 486       WRITE (CHMAIL, 1001) NLEVEL
 487       CALL GMAIL (0, 0)
 488       DO 991 I1=1,NLEVEL,5
 489          I2 = I1 + 4
 490          IF (I2.GT.NLEVEL) I2 = NLEVEL
 491          WRITE (CHMAIL, 1003) (NAMES(I),NUMBER(I),LVOLUM(I),LINDEX(I),
 492      +   I=I1,I2)
 493          CALL GMAIL (0, 0)
 494   991 CONTINUE
 495       DO 992 I= 1,NLEVEL
 496          WRITE (CHMAIL, 1002) (GTRAN(J,I),J=1,3),(GRMAT(J,I),J=1,10)
 497          CALL GMAIL (0, 0)
 498   992 CONTINUE
 499  1001 FORMAT (' GLVOLU : NLEVEL =',I3)
 500  1003 FORMAT (5(1X,A4,3I3))
 501  1002 FORMAT (1X,13F9.4)
 502 #endif
 503 *
 504  1000 FORMAT (' GLVOLU : called with useless Level # ',I5)
 505  2000 FORMAT (' GLVOLU : Volume ',A4,' not top of tree, or no tree')
 506  3000 FORMAT (' GLVOLU : at Level ',I3,' of ',I3,' there are no',
 507      *        ' contents for Volume ',A4)
 508  4000 FORMAT (' GLVOLU : Volume ',A4,' for Level ',I3,
 509      *        ' does not exist in Volume ',A4)
 510  5000 FORMAT (' GLVOLU : at Level ',I3,' asked for #',I3,
 511      *        ' in divided Volume ',A4,' which has ',I3,' divisions.')
 512  6000 FORMAT (' GLVOLU : at Level ',I3,' user name ',A4,
 513      *        ' not equal to name ',A4,' of division.')
 514 #if defined(CERNLIB_DEBUG)
 515  7000 FORMAT (' GLVOLU : Warning, ',A4,' not top of tree',
 516      *        ' you should reset NLEVEL to 0 before tracking !')
 517 #endif
 518  8000 FORMAT (' GLVOLU : Volume ',A4,' Level 1 does not exist')
 519 *                                                             END GLVOLU
 520   999 END