GEANT321/gdraw/gdspec.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.3  1996/10/01 14:12:05  ravndal
   6 * right units for SPHE specs.
   7 *
   8 * Revision 1.2  1996/09/30 14:54:13  ravndal
   9 * Right units for the spec of PARA
  10 *
  11 * Revision 1.1.1.1  1995/10/24 10:20:28  cernlib
  12 * Geant
  13 *
  14 *
  15 #include "geant321/pilot.h"
  16 *CMZ :  3.21/02 20/07/94  18.08.26  by  S.Ravndal
  17 *-- Author :
  18       SUBROUTINE GDSPEC(NAME)
  19 C.
  20 C.    ******************************************************************
  21 C.    *                                                                *
  22 C.    *       This routine draws specifications of volume NAME         *
  23 C.    *                                                                *
  24 C.    *    ==>Called by : <USER>, <GXINT>, GDFSPC                      *
  25 C.    *       Authors : P.Zanarini   *********                         *
  26 C.    *                 A.McPherson  *****                             *
  27 C.    *                                                                *
  28 C.    ******************************************************************
  29 C.
  30 #include "geant321/gcbank.inc"
  31 #include "geant321/gcdraw.inc"
  32 #include "geant321/gcnum.inc"
  33 #include "geant321/gcshno.inc"
  34       CHARACTER*4 ICTUB(11)
  35       CHARACTER*4 NAME,NAMSEE,ISON
  36       CHARACTER*4 IBOX(5),ITRD1(5),ITUBE(5),ITUBS(5)
  37       CHARACTER*4 ITRD2(6),ICON(5),ICONS(7),ISPH(6),ITRAP(11),IPARA(6),
  38      +IPGON(7),IPCON(6),IGTRA(12),IHYPE(4),IELTU(3)
  39       DIMENSION PAR(50),IPAR(12),IPA(3),ISPAR(3)
  40       DIMENSION U0(3),V0(3),THE(3),PHI(3),ISHT(2)
  41       DIMENSION U01(3),V01(3)
  42       DIMENSION NNDM(100),INDM(5,100),ATT(10)
  43       CHARACTER*12 CHTEXT
  44       SAVE IBOX,ITRD1,ITRD2,ITRAP,ITUBE,ITUBS,ICON,ICONS,ISPH,IPARA
  45       SAVE IPGON,IPCON,IGTRA,ICTUB,IHYPE,IELTU
  46       SAVE NNDM,INDM,U01,V01,THE,PHI,XMAN1,YMAN1
  47 C
  48       DATA IBOX /'DX  ','DY  ','DZ  ','    ','    '/
  49       DATA ITRD1/'DX1 ','DX2 ','DY  ','DZ  ','    '/
  50       DATA ITRD2/'DX1 ','DX2 ','DY1 ','DY2 ','DZ  ','    '/
  51       DATA ITRAP/'DZ  ','THET','PHI ','H1  ','BL1 ','TL1 ','ALP1',
  52      +'H2  ','BL2 ','TL2 ','ALP2'/
  53       DATA ITUBE/'RMIN','RMAX','DZ  ','    ','    '/
  54       DATA ITUBS/'RMIN','RMAX','DZ  ','PHI1','PHI2'/
  55       DATA ICON /'DZ  ','RMN1','RMX1','RMN2','RMX2'/
  56       DATA ICONS/'DZ  ','RMN1','RMX1','RMN2','RMX2','PHI1','PHI2'/
  57       DATA ISPH /'RMIN','RMAX','THE1','THE2','PHI1','PHI2'/
  58       DATA IPARA/'DX  ','DY  ','DZ  ','ALPH','THET','PHI '/
  59       DATA IPGON/'PHI1','DPHI','NPDV','NZ  ','Z   ','RMIN','RMAX'/
  60       DATA IPCON/'PHI1','DPHI','NZ  ','Z   ','RMIN','RMAX'/
  61       DATA IHYPE/'RMIN','RMAX','DZ  ','TWST'/
  62       DATA IGTRA/'DZ  ','THET','PHI ','TWIS','H1  ','BL1 ','TL1 ',
  63      +'ALP1','H2  ','BL2 ','TL2 ','ALP2'/
  64       DATA ICTUB/'RMIN','RMAX','DZ  ','PHI1','PHI2','LXL ','LYL ',
  65      +           'LZL ','LXH ','LYH ','LZH '/
  66       DATA IELTU /'A   ','B   ','DZ  '/
  67 C
  68       DATA NNDM/0,0,0,4,0,2,0,2,4,3,4,3,0,0,13*0,5,72*0/
  69       DATA INDM/0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 2,3,7,11,0, 0,0,0,0,0,
  70      +          4,5,0,0,0, 0,0,0,0,0, 6,7,0,0,0, 3,4,5,6,0, 4,5,6,0,0,
  71      +          1,2,3,4,0, 1,2,3,0,0, 0,0,0,0,0, 70*0, 2,3,4,8,12,
  72      +          360*0/
  73 C
  74       DATA U01/14.5,5.5,14.5/
  75       DATA V01/14.,5.,5./
  76       DATA THE/45.,0.,90./
  77       DATA PHI/135.,0.,180./
  78       DATA XMAN1/8.8/
  79       DATA YMAN1/11.6/
  80 C.
  81 C.    ------------------------------------------------------------------
  82 C.
  83 C             Is NAME an existing volume ?
  84 C
  85 ***      CALL IGRNG(20.,20.)
  86       CALL HPLFRA(0.,20.,0.,20.,'AB')
  87       CALL GLOOK(NAME,IQ(JVOLUM+1),NVOLUM,IVO)
  88       IF (IVO.LE.0) GO TO 999
  89 C
  90 C             Normalize to PLTRNX,PLTRNY
  91 C
  92       DO 10 I=1,3
  93          U0(I)=U01(I)*PLTRNX/20.
  94          V0(I)=V01(I)*PLTRNY/20.
  95    10 CONTINUE
  96       XMAN=XMAN1*PLTRNX/20.
  97       YMAN=YMAN1*PLTRNY/20.
  98 C
  99 C             Save GDRAW calling parameters
 100 C             and ZOOM internal parameters
 101 C
 102       SAVTHE=GTHETA
 103       SAVPHI=GPHI
 104       SAVPSI=GPSI
 105       SAVU0=GU0
 106       SAVV0=GV0
 107       SAVSCU=GSCU
 108       SAVSCV=GSCV
 109       SVGZUA=GZUA
 110       SVGZVA=GZVA
 111       SVGZUB=GZUB
 112       SVGZVB=GZVB
 113       SVGZUC=GZUC
 114       SVGZVC=GZVC
 115       GZUA=1
 116       GZVA=1
 117       GZUB=0
 118       GZVB=0
 119       GZUC=0
 120       GZVC=0
 121 C
 122 C             Get shape type
 123 C
 124       JVO=LQ(JVOLUM-IVO)
 125       ISHAPE=Q(JVO+2)
 126 C
 127 C             Get user parameters
 128 C
 129       CALL GFPARA(NAME,1,0,NPAR,NATT,PAR,ATT)
 130       IF(NPAR.LE.0) GO TO 250
 131 C
 132 C
 133 C             Check parameter sizes
 134 C
 135       PARMAX=-1.
 136       DO 40 I=1,NPAR
 137          IF(NNDM(ISHAPE).LE.0) GO TO 30
 138          NDM=NNDM(ISHAPE)
 139          DO 20 IDM=1,NDM
 140             IF(I.EQ.INDM(IDM,ISHAPE)) GO TO 40
 141    20    CONTINUE
 142    30    ABSPAR=ABS(PAR(I))
 143          PARMAX=MAX(PARMAX,ABSPAR)
 144    40 CONTINUE
 145 C
 146       GSCU=MIN(PLTRNX,PLTRNY)/(7.*PARMAX)
 147       GSCV=GSCU
 148       AXSIZ=PARMAX*0.35
 149 C
 150 C             Draw header
 151 C
 152       CALL GDHEAD(-1,NAME,0.)
 153 C
 154 C             Draw parameters list
 155 C
 156       DY=0.4
 157       IF(NPAR.GT.20) NPAR=20
 158       IF(NPAR.GT.10) DY=5.0/NPAR
 159       H=DY*0.7
 160 C
 161       DO 210 I=1,NPAR
 162          CALL UCTOH(' = <',ISPAR(2),4,4)
 163          CALL UCTOH('CM $',ISPAR(3),4,4)
 164          IF (ISHAPE.NE.1) GO TO 50
 165          CALL UCTOH('B<OX',ISHT(1),4,4)
 166          CALL UCTOH('   $',ISHT(2),4,4)
 167          CALL UCTOH(IBOX(I),ISPAR(1),4,4)
 168          GO TO 200
 169    50    IF (ISHAPE.NE.2) GO TO 60
 170          CALL UCTOH('T<RD',ISHT(1),4,4)
 171          CALL UCTOH('>1 $',ISHT(2),4,4)
 172          CALL UCTOH(ITRD1(I),ISPAR(1),4,4)
 173          GO TO 200
 174    60    IF(ISHAPE.NE.3) GO TO 70
 175          CALL UCTOH('T<RD',ISHT(1),4,4)
 176          CALL UCTOH('>2 $',ISHT(2),4,4)
 177          CALL UCTOH(ITRD2(I),ISPAR(1),4,4)
 178          GO TO 200
 179    70    IF(ISHAPE.NE.4) GO TO 80
 180          CALL UCTOH('T<RA',ISHT(1),4,4)
 181          CALL UCTOH('P  $',ISHT(2),4,4)
 182          CALL UCTOH(ITRAP(I),ISPAR(1),4,4)
 183          IF(I.EQ.2.OR.I.EQ.3.OR.I.EQ.7.OR.I.EQ.11)THEN
 184             CALL UCTOH(' = <',ISPAR(2),4,4)
 185             CALL UCTOH('DEG$',ISPAR(3),4,4)
 186          ENDIF
 187          GO TO 200
 188    80    IF (ISHAPE.NE.5) GO TO 90
 189          CALL UCTOH('T<UB',ISHT(1),4,4)
 190          CALL UCTOH('E  $',ISHT(2),4,4)
 191          CALL UCTOH(ITUBE(I),ISPAR(1),4,4)
 192          GO TO 200
 193    90    IF (ISHAPE.NE.6) GO TO 100
 194          CALL UCTOH('T<UB',ISHT(1),4,4)
 195          CALL UCTOH('S  $',ISHT(2),4,4)
 196          CALL UCTOH(ITUBS(I),ISPAR(1),4,4)
 197          IF(I.GT.3)THEN
 198             CALL UCTOH(' = <',ISPAR(2),4,4)
 199             CALL UCTOH('DEG$',ISPAR(3),4,4)
 200          ENDIF
 201          GO TO 200
 202   100    IF(ISHAPE.NE.7) GO TO 110
 203          CALL UCTOH('C<ON',ISHT(1),4,4)
 204          CALL UCTOH('E  $',ISHT(2),4,4)
 205          CALL UCTOH(ICON(I),ISPAR(1),4,4)
 206          GO TO 200
 207   110    IF(ISHAPE.NE.8) GO TO 120
 208          CALL UCTOH('C<ON',ISHT(1),4,4)
 209          CALL UCTOH('S  $',ISHT(2),4,4)
 210          CALL UCTOH(ICONS(I),ISPAR(1),4,4)
 211          IF(I.GT.5)THEN
 212             CALL UCTOH(' = <',ISPAR(2),4,4)
 213             CALL UCTOH('DEG$',ISPAR(3),4,4)
 214          ENDIF
 215          GO TO 200
 216   120    IF(ISHAPE.NE.9) GO TO 130
 217          CALL UCTOH('S<PH',ISHT(1),4,4)
 218          CALL UCTOH('E  $',ISHT(2),4,4)
 219          CALL UCTOH(ISPH(I),ISPAR(1),4,4)
 220          IF(I.GT.2)THEN
 221             CALL UCTOH(' = <',ISPAR(2),4,4)
 222             CALL UCTOH('DEG$',ISPAR(3),4,4)
 223          ENDIF
 224          GO TO 200
 225   130    IF(ISHAPE.NE.10) GO TO 140
 226          CALL UCTOH('P<AR',ISHT(1),4,4)
 227          CALL UCTOH('A  $',ISHT(2),4,4)
 228          CALL UCTOH(IPARA(I),ISPAR(1),4,4)
 229          IF(I.GT.3)THEN
 230             CALL UCTOH(' = <',ISPAR(2),4,4)
 231             CALL UCTOH('DEG$',ISPAR(3),4,4)
 232          ENDIF
 233          GO TO 200
 234   140    IF(ISHAPE.NE.11.AND.ISHAPE.NE.12) GO TO 170
 235          CALL UCTOH('P<GO',ISHT(1),4,4)
 236          CALL UCTOH('N  $',ISHT(2),4,4)
 237          IU=I
 238          IF(IU.LT.8) GO TO 150
 239          I2=I-5
 240          I3=I2/3
 241          I4=I2-I3*3
 242          IU=I4+5
 243   150    CALL UCTOH(IPGON(IU),ISPAR(1),4,4)
 244          IF(I.LT.3)THEN
 245             CALL UCTOH(' = <',ISPAR(2),4,4)
 246             CALL UCTOH('DEG$',ISPAR(3),4,4)
 247          ENDIF
 248          IF(I.EQ.3.OR.I.EQ.4)CALL UCTOH('   $', ISPAR(3),4,4)
 249          IF(ISHAPE.EQ.11) GO TO 200
 250          CALL UCTOH('P<CO',ISHT(1),4,4)
 251          IU=I
 252          IF(IU.LT.7) GO TO 160
 253          I2=I-4
 254          I3=I2/3
 255          I4=I2-I3*3
 256          IU=I4+4
 257   160    CALL UCTOH(IPCON(IU),ISPAR(1),4,4)
 258          IF(I.EQ.4) CALL UCTOH('CM $',ISPAR(3),4,4)
 259 C
 260          GO TO 200
 261   170    CONTINUE
 262          IF(ISHAPE.NE.13) GO TO 180
 263          CALL UCTOH('E<LT',ISHT(1),4,4)
 264          CALL UCTOH('U  $',ISHT(2),4,4)
 265          CALL UCTOH(IELTU(I),ISPAR(1),4,4)
 266          GO TO 200
 267   180    CONTINUE
 268          IF(ISHAPE .NE. 14) GO TO 190
 269          CALL UCTOH('H<YP',ISHT(1),4,4)
 270          CALL UCTOH('E  $',ISHT(2),4,4)
 271          CALL UCTOH(IHYPE(I),ISPAR(1),4,4)
 272          IF(I .GT. 3) THEN
 273             CALL UCTOH(' = <',ISPAR(2),4,4)
 274             CALL UCTOH('DEG$',ISPAR(3),4,4)
 275          ENDIF
 276          GO TO 200
 277 C
 278   190    CONTINUE
 279 C
 280 C             Cut tube
 281 C
 282          IF (ISHAPE.EQ.NSCTUB) THEN
 283             CALL UCTOH('CT<U',ISHT(1),4,4)
 284             CALL UCTOH('B  $',ISHT(2),4,4)
 285             CALL UCTOH(ICTUB(I),ISPAR(1),4,4)
 286             IF(I.GE.4.AND.I.LE.5)THEN
 287                CALL UCTOH(' = <',ISPAR(2),4,4)
 288                CALL UCTOH('DEG$',ISPAR(3),4,4)
 289             ELSE IF(I.GE.6)THEN
 290                CALL UCTOH(' =  ',ISPAR(2),4,4)
 291                CALL UCTOH('  $ ',ISPAR(3),4,4)
 292             END IF
 293             GO TO 200
 294          ENDIF
 295 C
 296 C             General twisted trapezoid.
 297 C
 298          IF(ISHAPE.NE.28) GO TO 230
 299          CALL UCTOH('G>TR',ISHT(1),4,4)
 300          CALL UCTOH('A  $',ISHT(2),4,4)
 301          CALL UCTOH(IGTRA(I),ISPAR(1),4,4)
 302          IF(I.EQ.2.OR.I.EQ.3.OR.I.EQ.4.OR.I.EQ.8.OR. I.EQ.12) CALL
 303      +   UCTOH('DEG$',ISPAR(3),4,4)
 304 C
 305   200    CONTINUE
 306          IF (I.EQ.1) THEN
 307             XTEXT=4.*PLTRNX/20.
 308             YTEXT=16.5*PLTRNY/20.
 309             CSIZE=DY*MIN(PLTRNX,PLTRNY)/20.
 310             CALL UHTOC(ISHT,4,CHTEXT,12)
 311             CALL GDRAWT(XTEXT,YTEXT,CHTEXT,CSIZE,0.,1,-1)
 312          ENDIF
 313          Y=16.5-(I+0.5)*DY
 314          XTEXT=3.*PLTRNX/20.
 315          YTEXT=Y*PLTRNY/20.
 316          CSIZE=H*MIN(PLTRNX,PLTRNY)/20.
 317          CALL UHTOC(ISPAR,4,CHTEXT,12)
 318          CALL GDRAWT(XTEXT,YTEXT,CHTEXT,CSIZE,0.,1,-1)
 319          CALL HBCDF(PAR(I),8,IPAR)
 320          IF (PAR(I).EQ.0.) CALL UCTOH('0',IPAR(1),1,1)
 321          CALL UCTOH('$',IPAR(9),1,1)
 322          CALL UBUNCH(IPAR,IPA,9)
 323          XTEXT=(H*10.+3.)*PLTRNX/20.
 324          YTEXT=Y*PLTRNY/20.
 325          CSIZE=H*MIN(PLTRNX,PLTRNY)/20.
 326          CALL UHTOC(IPA,4,CHTEXT,12)
 327          CALL GDRAWT(XTEXT,YTEXT,CHTEXT,CSIZE,0.,1,-1)
 328   210 CONTINUE
 329 C
 330 C             Draw views
 331 C
 332       CALL GFATT(NAME,'SEEN',KSEEN)
 333 C
 334 C             Add local value SEEN 1 to starting node of tree
 335 C
 336       KSEEN=KSEEN+110
 337       ISEEN=KSEEN
 338       CALL GSATT(NAME,'SEEN',ISEEN)
 339 C
 340       CALL GSATT(NAME,'COLO',2)
 341       CALL GDNSON(NAME,NSON,IDIV)
 342       DO 220 N=1,NSON
 343          CALL GDSON(N,NAME,ISON)
 344          CALL GFATT(ISON,'SEEN',KSEEN)
 345 C
 346 C             ISON is a volume with multiplicity;
 347 C             first occurrence has already been set
 348 C
 349          IF (KSEEN.GT.50) GO TO 220
 350 C
 351 C             Add local value SEEN -2 to each one-level-down node
 352 C
 353          KSEEN=KSEEN+80
 354          ISEEN=KSEEN
 355          CALL GSATT(ISON,'SEEN',ISEEN)
 356 C
 357          CALL GSATT(ISON,'COLO',4)
 358   220 CONTINUE
 359 C
 360       CALL GDCOL(3)
 361       XSCAL=PLTRNX/4.
 362       YSCAL=PLTRNY/2.
 363       CALL GDSCAL(XSCAL,YSCAL)
 364 **    IF (GSCU.LE.0.05) CALL GDMAN(XMAN,YMAN)
 365       IF (GSCU.LE.0.05) CALL GDWMN1(XMAN,YMAN)
 366 C
 367       CALL GDRAW(NAME,THE(1),PHI(1),0.,U0(1),V0(1),GSCU,GSCV)
 368       CALL GDAXIS(0.,0.,0.,AXSIZ)
 369       CALL GDRAWC(NAME,3,0.005,U0(2),V0(2),GSCU,GSCV)
 370       CALL GDAXIS(0.,0.,0.,AXSIZ)
 371       CALL GDRAWC(NAME,1,0.005,U0(3),V0(3),GSCU,GSCV)
 372       CALL GDAXIS(0.,0.,0.,AXSIZ)
 373 C
 374   230 CALL GDCOL(0)
 375 C
 376 C             Reset global SEEN values
 377 C
 378       DO 240 IVO=1,NVOLUM
 379          CALL UHTOC(IQ(JVOLUM+IVO),4,NAMSEE,4)
 380          CALL GFATT(NAMSEE,'SEEN',KSEEN)
 381          IF (KSEEN.LT.50) GO TO 240
 382          ISEENL=KSEEN/10.+0.5
 383          ISEENG=KSEEN-ISEENL*10.
 384          CALL GSATT(NAMSEE,'SEEN',ISEENG)
 385   240 CONTINUE
 386 C
 387   250 CONTINUE
 388 C
 389 C             Restore GDRAW calling parameters
 390 C             and ZOOM internal parameters
 391 C
 392       GTHETA=SAVTHE
 393       GPHI=SAVPHI
 394       GPSI=SAVPSI
 395       GU0=SAVU0
 396       GV0=SAVV0
 397       GSCU=SAVSCU
 398       GSCV=SAVSCV
 399       NGVIEW=0
 400       GZUA=SVGZUA
 401       GZVA=SVGZVA
 402       GZUB=SVGZUB
 403       GZVB=SVGZVB
 404       GZUC=SVGZUC
 405       GZVC=SVGZVC
 406       CALL ISELNT(1)
 407   999 END