]> git.uio.no Git - u/mrichter/AliRoot.git/blame - GEANT321/gdraw/gdcgob.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix needed on Sun and Alpha
[u/mrichter/AliRoot.git] / GEANT321 / gdraw / gdcgob.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
d43b40e2 5* Revision 1.1.1.1 1999/05/18 15:55:03 fca
6* AliRoot sources
7*
fe4da5cc 8* Revision 1.2 1996/02/27 10:02:05 ravndal
9* Drawing of PCON's optimized for 'HIDE ON'
10*
11* Revision 1.1.1.1 1995/10/24 10:20:20 cernlib
12* Geant
13*
14*
15#include "geant321/pilot.h"
16*CMZ : 3.21/04 13/12/94 17.13.38 by S.Giani
17*-- Author :
18*
19 SUBROUTINE GDCGOB(ITASK,ISHAPE,PAR,NOBJ,NWWS,IVOLNA,
20 +LSTEP)
21C.
22C. ******************************************************************
23C. * *
24C. * Make the CG-Object with shape ISHAPE of parameters PAR *
25C. * with the same logic as GDRAWS. 1992 *
26C. * *
27C. * Input Parameters : *
28C. * *
29C. * ITASK: Number for indicating the task to be performed *
30C. * *
31C. * *
32C. * = 0 Counting task *
33C. * = 1 Slicing + Counting *
34C. * = 2 Clipping + Counting *
35C. * = 3 Insert into the H.S. + Convert to Wire *
36C. * = 4 Slicing + Insert into the H.S. + Convert *
37C. * to Wire *
38C. * = 5 Clipping + Insert into the H.S. + Convert *
39C. * to Wire *
40C. * *
41C. * SHAPE SHAPE SHAPE *
42C. * NUMBER TYPE PARAMETERS *
43C. * -------------------------------------------------------------- *
44C. * *
45C. * 1 BOX DX,DY,DZ *
46C. * 2 TRD1 DX1,DX2,DY,DZ *
47C. * 3 TRD2 DX1,DX2,DY1,DY2,DZ *
48C. * 4 TRAP DZ,TX,TY,H1,BL1,TL1,TTH1,H2,BL2,TL2,TTH2 *
49C. * *
50C. * 5 TUBE RMIN,RMAX,DZ *
51C. * 6 TUBS RMIN,RMAX,DZ,PHIMIN,PHIMAX *
52C. * 7 CONE DZ,RMIN1,RMAX1,RMIN2,RMAX2 *
53C. * 8 CONS DZ,RMIN1,RMAX1,RMIN2,RMAX2,PHIMIN,PHIMAX *
54C. * *
55C. * 9 SPHE RMIN,RMAX,THEMIN,THEMAX,PHIMIN,PHIMAX *
56C. * *
57C. * 10 PARA DX,DY,DZ,TXY,TXZ,TYZ *
58C. * 11 PGON PHIMIN,DPHI,NDIV,NZ,Z(1),RMIN(1),RMAX(1),...*
59C. * 12 PCON PHIMIN,DPHI,NZ,Z(1),RMIN(1),RMAX(1),Z(2),...*
60C. * *
61C. * NOBJ = Counter of cg objects *
62C. * NWWS = Size of Wire structure *
63C. * IVOLNA = Name of volume *
64C. * LSTEP = Number of CG objects forming each volume *
65C. * *
66C. * ==>Called by : GDRAW *
67C. * Author : P.Zanarini, J.Salt, S.Giani ********* *
68C. * *
69C. ******************************************************************
70C.
71#include "geant321/gcbank.inc"
72#include "geant321/gcunit.inc"
73#include "geant321/gcvolu.inc"
74#include "geant321/gcgobj.inc"
75#include "geant321/gcmutr.inc"
76#include "geant321/gcdraw.inc"
77#include "geant321/gchiln.inc"
78#include "geant321/gcspee.inc"
79#include "geant321/gconsp.inc"
80 SAVE NWPROD
81 COMMON /QUEST/IQUEST(100)
d43b40e2 82 DIMENSION PAR(100),P(3,8)
fe4da5cc 83*SG
84 DIMENSION RRMIN(3),RRMAX(3)
85 DIMENSION SLI1(4),SLI2(4),SPI1(4),SPI2(4)
86*SG
87 DIMENSION XZ(2,4),ZR(18),RMIR(18),RMAR(18),AMIRMA(18),AMARMA(18)
88 DIMENSION T(4,3)
89C. ------------------------------------------------------------------
90C.
91**SG
92 CALL UCTOH('PERS',IPERS,4,4)
93 T(4,1)=0.
94 T(4,2)=0.
95 T(4,3)=0.
96 LINSTY=IBITS(LINATT,10,3)
97 IF(LINSTY.EQ.7)THEN
98 APPROS=30.
99 ELSE
100 APPROS=15.
101 ENDIF
102 IF(ISUBLI.LT.IOLDSU)THEN
103 PORGX=0
104 PORGY=0
105 PORGZ=0
106 DO 10 J=1,15
107 POX(J)=0
108 POY(J)=0
109 POZ(J)=0
110 10 CONTINUE
111 ENDIF
112 IOLDSU=ISUBLI
113*
114* LHC flag 'ON' (default)
115*
116* CALL UCTOH('ON ',LHIF,4,4)
117* IF(LEP.EQ.LHIF)THEN
118* VITE=1
119* ELSE
120* VITE=0
121* ENDIF
122*
123* Flag for GDCGHI resetted for each CG object
124 ISG=0
125 ICGP=0
126 LINFIL=IBITS(LINATT,13,3)
127**SG
128 IVCLOS=0
129 IVFUN=1
130 IWORK=ITASK
131 CALL UCTOH('ON ',IFLH,4,4)
132*JS
133 IF (ISHAPE.EQ.1) THEN
134C
135C BOX
136C
137 DX1=PAR(1)
138 DY1=PAR(2)
139 DX2=DX1
140 DY2=DY1
141 DZ=PAR(3)
142 GO TO 20
143C
144 ELSEIF (ISHAPE.EQ.2) THEN
145C
146C TRD1
147C
148 DX1=PAR(1)
149 DX2=PAR(2)
150 DY1=PAR(3)
151 DY2=DY1
152 DZ=PAR(4)
153 GO TO 20
154C
155 ELSEIF (ISHAPE.EQ.3) THEN
156C
157C TRD2
158C
159 DX1=PAR(1)
160 DX2=PAR(2)
161 DY1=PAR(3)
162 DY2=PAR(4)
163 DZ=PAR(5)
164 GO TO 20
165C
166 ELSEIF (ISHAPE.EQ.4) THEN
167C
168C TRAP
169C
170 DZ=PAR(1)
171 TX=PAR(2)
172 TY=PAR(3)
173 H1=PAR(4)
174 BL1=PAR(5)
175 TL1=PAR(6)
176 TTH1=PAR(7)
177 H2=PAR(8)
178 BL2=PAR(9)
179 TL2=PAR(10)
180 TTH2=PAR(11)
181 GO TO 30
182C
183 ELSEIF (ISHAPE.EQ.5) THEN
184C
185C TUBE
186C
187 AFINV=1./COS(PI/APPROS)
188 FINV=ABS(AFINV)
189 RMIN1=PAR(1)*FINV
190 RMAX1=PAR(2)*FINV
191 RMIN2=RMIN1
192 RMAX2=RMAX1
193 Z2=PAR(3)
194* Z1=-Z2
195 PHIMIN=0.
196 PHIMAX=360.
197 IF((LINFIL.EQ.2.OR.LINFIL.EQ.3)
198 + .AND.RMIN1.NE.0)PHIMIN=5.
199*SG
200 ANG1=PHIMIN
201 ANG2=PHIMAX
202 AANG=ABS(ANG2-ANG1)
203 AZLAT=AANG*APPROS
204 ZLAT=AZLAT/360
205 NANG=ZLAT
206 IF(NANG.EQ.0)NANG=1
207 AZ=ZLAT-NANG
208 IF(AZ.GT..5)NANG=NANG+1
209*SG
210 GO TO 70
211C
212 ELSEIF (ISHAPE.EQ.6.OR.ISHAPE.EQ.29) THEN
213C
214C TUBS
215C
216 AFINV=1./COS(PI/APPROS)
217 FINV=ABS(AFINV)
218 RMIN1=PAR(1)*FINV
219 RMAX1=PAR(2)*FINV
220 RMIN2=RMIN1
221 RMAX2=RMAX1
222 AZ2=PAR(3)
223 Z2=ABS(AZ2)
224* Z1=-Z2
225 PHIMIN=PAR(4)
226 PHIMAX=PAR(5)
227**SG
228 ANG1=PHIMIN
229 ANG2=PHIMAX
230 AANG=ABS(ANG2-ANG1)
231 AZLAT=AANG*APPROS
232 ZLAT=AZLAT/360
233 NANG=ZLAT
234 IF(NANG.EQ.0)NANG=1
235 AZ=ZLAT-NANG
236 IF(AZ.GT..5)NANG=NANG+1
237 IF(ISHAPE.EQ.29)NANG=APPROS
238**SG
239 GO TO 70
240C
241 ELSEIF (ISHAPE.EQ.7) THEN
242C
243C CONE
244C
245 AFINV=1./COS(PI/APPROS)
246 FINV=ABS(AFINV)
247 RMIN1=PAR(2)*FINV
248 RMAX1=PAR(3)*FINV
249 RMIN2=PAR(4)*FINV
250 RMAX2=PAR(5)*FINV
251 Z2=PAR(1)
252* Z1=-Z2
253 PHIMIN=0.
254 PHIMAX=360.
255 IF((LINFIL.EQ.2.OR.LINFIL.EQ.3).AND.RMIN2.NE.0)PHIMIN=5.
256*SG
257 ANG1=PHIMIN
258 ANG2=PHIMAX
259 AANG=ABS(ANG2-ANG1)
260 AZLAT=AANG*APPROS
261 ZLAT=AZLAT/360
262 NANG=ZLAT
263 IF(NANG.EQ.0)NANG=1
264 AZ=ZLAT-NANG
265 IF(AZ.GT..5)NANG=NANG+1
266*SG
267 GO TO 70
268C
269 ELSEIF (ISHAPE.EQ.8) THEN
270C
271C CONS
272C
273 AFINV=1./COS(PI/APPROS)
274 FINV=ABS(AFINV)
275 RMIN1=PAR(2)*FINV
276 RMAX1=PAR(3)*FINV
277 RMIN2=PAR(4)*FINV
278 RMAX2=PAR(5)*FINV
279 Z2=PAR(1)
280* Z1=-Z2
281 PHIMIN=PAR(6)
282 PHIMAX=PAR(7)
283**SG
284 ANG1=PHIMIN
285 ANG2=PHIMAX+.1
286 AANG=ABS(ANG2-ANG1)
287 AZLAT=AANG*APPROS
288 ZLAT=AZLAT/360
289 NANG=ZLAT
290 IF(NANG.EQ.0)NANG=1
291 AZ=ZLAT-NANG
292 IF(AZ.GT..5)NANG=NANG+1
293**SG
294 GO TO 70
295C
296 ELSEIF (ISHAPE.EQ.9) THEN
297C
298C SPHE
299C
300* RMIN=PAR(1)
301 RMAX=PAR(2)
302 GO TO 120
303C
304 ELSEIF (ISHAPE.EQ.10) THEN
305C
306C PARA
307C
308 DX=PAR(1)
309 DY=PAR(2)
310 DZ=PAR(3)
311 TXY=PAR(4)
312 TXZ=PAR(5)
313 TYZ=PAR(6)
314C
315 TX=TXZ
316 TY=TYZ
317 H1=DY
318 BL1=DX
319 TL1=DX
320 TTH1=TXY
321 H2=DY
322 BL2=DX
323 TL2=DX
324 TTH2=TXY
325 GO TO 30
326C
327 ELSEIF (ISHAPE.EQ.11) THEN
328C
329C PGON
330C
331 PHIMIN=PAR(1)
332 IF((LINFIL.EQ.2.OR.LINFIL.EQ.3).AND.PAR(2).GT.359.)PAR(2)=359.
333 PHIMAX=PHIMIN+PAR(2)
334 NDIVAN=PAR(3)
335 NZ=PAR(4)
336C
337C Z(1)=PAR(5) - RMIN(1)=PAR(6) - RMAX(1)=PAR(7) - Z(2)=PAR(8
338C
339 GO TO 150
340C
341 ELSEIF (ISHAPE.EQ.12) THEN
342C
343C PCON
344C
345 PHIMIN=PAR(1)
346 IF((LINFIL.EQ.2.OR.LINFIL.EQ.3).AND.PAR(2).GT.359.)PAR(2)=359.
347 PHIMAX=PHIMIN+PAR(2)
348 NZ=PAR(3)
349C
350C Z(1)=PAR(4) - RMIN(1)=PAR(5) - RMAX(1)=PAR(6) - Z(2)=PAR(7
351C
352 GO TO 230
353 ELSE
354 GO TO 999
355 ENDIF
356C
357* GO TO 150
358C
359 20 CONTINUE
360C
361C Rectilinear shapes: BOX,TRD1,TRD2
362C
363 X1=0.
364 Y1=0.
365 X2=0.
366 Y2=0.
367 IF(DZ.LT.0.001)DZ=0.001
368 Z1=-DZ
369 Z2=DZ
370C
371C Calculate the 8 vertex for rectilinear shapes
372C
373 IF(DX1.EQ.0.)DX1=0.0001
374 IF(DY1.EQ.0.)DY1=0.0001
375 IF(DX2.EQ.0.)DX2=0.0001
376 IF(DY2.EQ.0.)DY2=0.0001
377 P(1,1)=X1+DX1
378 P(2,1)=Y1+DY1
379 P(3,1)=Z1
380 P(1,2)=X1-DX1
381 P(2,2)=Y1+DY1
382 P(3,2)=Z1
383 P(1,3)=X1-DX1
384 P(2,3)=Y1-DY1
385 P(3,3)=Z1
386 P(1,4)=X1+DX1
387 P(2,4)=Y1-DY1
388 P(3,4)=Z1
389 P(1,5)=X2+DX2
390 P(2,5)=Y2+DY2
391 P(3,5)=Z2
392 P(1,6)=X2-DX2
393 P(2,6)=Y2+DY2
394 P(3,6)=Z2
395 P(1,7)=X2-DX2
396 P(2,7)=Y2-DY2
397 P(3,7)=Z2
398 P(1,8)=X2+DX2
399 P(2,8)=Y2-DY2
400 P(3,8)=Z2
401*
402 GOTO 40
403C
404 30 CONTINUE
405C
406C TRAP,PARA
407C
408C Calculate the 8 vertex
409C
410 P(1,1)=-DZ*TX+TTH1*H1+TL1
411 P(2,1)=+H1-DZ*TY
412 P(3,1)=-DZ
413 P(1,2)=-DZ*TX+TTH1*H1-TL1
414 P(2,2)=+H1-DZ*TY
415 P(3,2)=-DZ
416 P(1,3)=-DZ*TX-TTH1*H1-BL1
417 P(2,3)=-H1-DZ*TY
418 P(3,3)=-DZ
419 P(1,4)=-DZ*TX-TTH1*H1+BL1
420 P(2,4)=-H1-DZ*TY
421 P(3,4)=-DZ
422 P(1,5)=+DZ*TX+TTH2*H2+TL2
423 P(2,5)=+H2+DZ*TY
424 P(3,5)=+DZ
425 P(1,6)=+DZ*TX+TTH2*H2-TL2
426 P(2,6)=+H2+DZ*TY
427 P(3,6)=+DZ
428 P(1,7)=+DZ*TX-TTH2*H2-BL2
429 P(2,7)=-H2+DZ*TY
430 P(3,7)=+DZ
431 P(1,8)=+DZ*TX-TTH2*H2+BL2
432 P(2,8)=-H2+DZ*TY
433 P(3,8)=+DZ
434C
435 40 CONTINUE
436C
437C BOX,TRD1,TRD2,TRAP,PARA --->> call CGBOX
438C
439 IVCLOS=1
440*SG
441* Size evaluation
442*
443 IF(IWORK.LE.2.AND.IVFUN.NE.0)THEN
444* NWB = n. words for each box
445 NCGVOL=NCGVOL+NWB
446 GOTO 999
447 ENDIF
448 ICPOIN=JCGOBJ+1
449* Creating object
450*SG
451 RMIN1=0
452 RMIN2=0
453 RMAX1=0
454 RMAX2=0
455 CALL CGBOX(P,4,4,300,Q(ICPOIN))
456 DO 50 J=1,3
457 T(J,1)=GRMAT(3*J-2,NLEVEL)
458 T(J,2)=GRMAT(3*J-1,NLEVEL)
459 T(J,3)=GRMAT(3*J,NLEVEL)
460 50 CONTINUE
461 CALL CGRIFL(T,Q(ICPOIN))
462 CGERR=Q(ICPOIN)
463 IF(CGERR.LE.0)THEN
464 CALL GDCGER(CGERR)
465 IF(KCGST.EQ.-2) GOTO 999
466 IF(KCGST.EQ.-3) THEN
467 KCGST=0
468 WRITE(CHMAIL,10000)ISHAPE,NAMES(NLEVEL)
469 CALL GMAIL(0,0)
470 GOTO 999
471 ENDIF
472 ENDIF
473 CALL CGCEV(1,Q(ICPOIN))
474 DO 60 J=1,3
475 T(J,1)=GRMAT(3*J-2,NLEVEL)
476 T(J,2)=GRMAT(3*J-1,NLEVEL)
477 T(J,3)=GRMAT(3*J,NLEVEL)
478 60 CONTINUE
479 CALL CGAFFI(T,Q(ICPOIN))
480 XV=GTRAN(1,NLEVEL)
481 YV=GTRAN(2,NLEVEL)
482 ZV=GTRAN(3,NLEVEL)
483 CALL CGSHIF(XV,YV,ZV,Q(ICPOIN))
484***SG
485* Shifting object
486 IF(KSHIFT.GT.0)THEN
487 CALL GDSHIF(IVOLNA,ICPOIN)
488 ENDIF
489*
490 IF(GBOOM.NE.0)THEN
491 CALL GDBOMB(ICPOIN,ISHAPE)
492 IF(ITSTCU.EQ.0)GOTO 999
493 ENDIF
494*
495*
496*
497* Hidden Volume Removal:
498* Computing volumes visibility and skipping
499* the unvisible ones; a great increase in speed
500* and a great reduction in n. of words used can be
501* obtained in this way.
502*
503 CALL CGMNMX(Q(ICPOIN),RRMIN,RRMAX)
504 IF(ISUBLI.EQ.1)THEN
505 AA1=RRMIN(1)-S1
506 AA2=RRMIN(2)-S2
507 AA3=RRMIN(3)-S3
508 BB1=RRMAX(1)-SS1
509 BB2=RRMAX(2)-SS2
510 BB3=RRMAX(3)-SS3
511 IF(AA1.GT.0.001.AND.AA2.GT.0.001.AND.AA3.GT.0.001.AND. BB1.LT.
512 + 0.001.AND.BB2.LT.0.001.AND.BB3.LT.0.001)THEN
513 IF(ISCOP.NE.1)THEN
514 IF(IWORK.EQ.0.OR.IWORK.EQ.3)THEN
515 ITSTCU=0
516 NCGVOL=NCGVOL-NWB
517 GOTO 999
518 ENDIF
519 ENDIF
520 ENDIF
521 ENDIF
522 IF(IPORLI.EQ.1)THEN
523 S1=RRMIN(1)
524 S2=RRMIN(2)
525 S3=RRMIN(3)
526 SS1=RRMAX(1)
527 SS2=RRMAX(2)
528 SS3=RRMAX(3)
529 SRAGMX=0
530 SRAGMN=0
531 RAINT1=0
532 RAINT2=0
533 ENDIF
534* Create clipping objects
535 IF(ICUT.NE.0.OR.IHOLE.NE.0)CALL GDCGSL(IVOLNA,ISHAPE)
536* Perspective view
537 IF (IPRJ.EQ.IPERS) THEN
538 CALL CGPERS(Q(ICPOIN))
539 ENDIF
540* Inserting volumes in Hide + Wire Structures
541 CALL GDCGHI(IWORK,NOBJ,NWWS,LSTEP,ISG,NTVOL,ISHAPE)
542 GOTO 999
543***SG
544C
545 70 CONTINUE
546C
547C TUBE,CONE,TUBS,CONS -----> call CGZREV
548C
549*
550* Checking Shape Parameters
551*
552 IF(RMIN1.GT.RMAX1) THEN
553 WRITE(CHMAIL,10100)ISHAPE,NAMES(NLEVEL)
554 CALL GMAIL(0,0)
555 ENDIF
556 IF(RMIN2.GT.RMAX2) THEN
557 WRITE(CHMAIL,10200)ISHAPE,NAMES(NLEVEL)
558 CALL GMAIL(0,0)
559 ENDIF
560 IF(PHIMIN.GT.PHIMAX)THEN
561 WRITE(CHMAIL,10300)ISHAPE,NAMES(NLEVEL)
562 CALL GMAIL(0,0)
563 ENDIF
564*
565*
566* Checking if all Inner Radii are 0. ==> 'Closed' Volume
567*
568 IF(RMIN1.LE.0.00001.AND.RMIN2.LE.0.00001)IVCLOS=1
569*SG
570* Size evaluation
571 IF(IWORK.LE.2.AND.IVFUN.NE.0)THEN
572* NWPROD = n. words for each body of revolution
573 NWPROD=NWREV*(NANG+1)
574 NCGVOL=NCGVOL+NWPROD
575 GOTO 999
576 ENDIF
577* Creating object
578 ICPOIN=JCGOBJ+1
579*SG
580 IF(ISHAPE.EQ.29)THEN
581 SAL=PAR(8)
582 IF(PAR(11).GT.SAL)SAL=PAR(11)
583 PAR3=MAX(PAR(3),0.)
584 Z2=PAR3+1.001*RMAX1*SQRT((1-SAL*SAL)/(SAL*SAL))
585 ENDIF
586 XZ(1,1)=RMIN1
587 XZ(2,1)=-Z2
588 XZ(1,2)=RMAX1
589 XZ(2,2)=-Z2
590 XZ(1,3)=RMAX2
591 XZ(2,3)=Z2
592 XZ(1,4)=RMIN2
593 XZ(2,4)=Z2
594 CALL CGZREV(XZ,ANG1,ANG2,NANG,4000,Q(ICPOIN))
595 DO 80 J=1,3
596 T(J,1)=GRMAT(3*J-2,NLEVEL)
597 T(J,2)=GRMAT(3*J-1,NLEVEL)
598 T(J,3)=GRMAT(3*J,NLEVEL)
599 80 CONTINUE
600 CALL CGRIFL(T,Q(ICPOIN))
601 CGERR=Q(ICPOIN)
602 IF(CGERR.LE.0)THEN
603 CALL GDCGER(CGERR)
604 IF(KCGST.EQ.-2) GOTO 999
605 IF(KCGST.EQ.-3) THEN
606 KCGST=0
607 WRITE(CHMAIL,10000)ISHAPE,NAMES(NLEVEL)
608 CALL GMAIL(0,0)
609 GOTO 999
610 ENDIF
611 ENDIF
612 CALL CGCEV(1,Q(ICPOIN))
613 IF(ISHAPE.EQ.29)THEN
614 SLI1(1)=-PAR(6)
615 SLI1(2)=-PAR(7)
616 SLI1(3)=-PAR(8)
617 SLI1(4)=-PAR(3)*PAR(8)
618 SLI2(1)=-PAR(9)
619 SLI2(2)=-PAR(10)
620 SLI2(3)=-PAR(11)
621 SLI2(4)=+PAR(3)*PAR(11)
622 ISL1=JCGOBJ+4000
623 CALL CGSLIC(Q(ICPOIN),SLI1,4000,Q(ISL1))
624 ISL2=JCGOBJ+8000
625 CALL CGSLIC(Q(ISL1),SLI2,4000,Q(ISL2))
626 ICPOIN=ISL2
627 CALL CGCEV(1,Q(ICPOIN))
628 ENDIF
629 DO 90 J=1,3
630 T(J,1)=GRMAT(3*J-2,NLEVEL)
631 T(J,2)=GRMAT(3*J-1,NLEVEL)
632 T(J,3)=GRMAT(3*J,NLEVEL)
633 90 CONTINUE
634 CALL CGAFFI(T,Q(ICPOIN))
635 XV=GTRAN(1,NLEVEL)
636 YV=GTRAN(2,NLEVEL)
637 ZV=GTRAN(3,NLEVEL)
638 CALL CGSHIF(XV,YV,ZV,Q(ICPOIN))
639***SG
640* Shifting object
641 IF(KSHIFT.GT.0)THEN
642 CALL GDSHIF(IVOLNA,ICPOIN)
643 ENDIF
644*
645 IF(GBOOM.NE.0)THEN
646 CALL GDBOMB(ICPOIN,ISHAPE)
647 IF(ITSTCU.EQ.0)GOTO 999
648 ENDIF
649*
650*
651* Hidden Volume Removal:
652* Computing closed volumes visibility and skipping
653* the unvisible ones; a great increase in speed
654* and a great reduction in n. of words used are obtained
655* in this way.
656*
657 CALL CGMNMX(Q(ICPOIN),RRMIN,RRMAX)
658 IF(ISUBLI.EQ.1)THEN
659 AA1=RRMIN(1)-S1
660 AA2=RRMIN(2)-S2
661 AA3=RRMIN(3)-S3
662 BB1=RRMAX(1)-SS1
663 BB2=RRMAX(2)-SS2
664 BB3=RRMAX(3)-SS3
665 IF(AA1.GT.0.001.AND.AA2.GT.0.001.AND.AA3.GT.0.001.AND. BB1.LT.
666 + -0.001.AND.BB2.LT.-0.001.AND.BB3.LT.-0.001)THEN
667 IF(ISHAPE.EQ.7.OR.ISHAPE.EQ.8)THEN
668 IF((RMAX2.LT.SRAGMX.AND.RMAX1.LT.SRAGMN).OR. (SRAGMX.EQ.
669 + 0))THEN
670 IF((RMIN2.GT.RAINT2.AND.RMIN1.GT.RAINT1).OR. (RAINT2.
671 + EQ.0))THEN
672 IF(IWORK.EQ.0.OR.IWORK.EQ.3)THEN
673 ITSTCU=0
674 NCGVOL=NCGVOL-NWPROD
675 GOTO 999
676 ENDIF
677 ENDIF
678 ENDIF
679 ELSEIF(SRAGMX.NE.0.)THEN
680 DO 100 ITER=1,IPORNT
681 IF(RMAX1.EQ.PORMAR(ITER))GOTO 110
682 IF(RMIN1.EQ.PORMIR(ITER))THEN
683 IF(PORMIR(ITER).NE.0.)GOTO 110
684 ENDIF
685 100 CONTINUE
686 ENDIF
687 IF(IWORK.EQ.0.OR.IWORK.EQ.3)THEN
688 ITSTCU=0
689 NCGVOL=NCGVOL-NWPROD
690 GOTO 999
691 ENDIF
692 ENDIF
693 ENDIF
694 IF(IPORLI.EQ.1)THEN
695 S1=RRMIN(1)
696 S2=RRMIN(2)
697 S3=RRMIN(3)
698 SS1=RRMAX(1)
699 SS2=RRMAX(2)
700 SS3=RRMAX(3)
701 SRAGMX=RMAX2
702 SRAGMN=RMAX1
703 RAINT1=RMIN1
704 RAINT2=RMIN2
705 IPORNT=1
706 PORMAR(1)=RMAX2
707 PORMIR(1)=RMIN1
708 ENDIF
709 110 CONTINUE
710* Create clipping objects
711 IF(ICUT.NE.0.OR.IHOLE.NE.0)CALL GDCGSL(IVOLNA,ISHAPE)
712* Perspective view
713 IF (IPRJ.EQ.IPERS) THEN
714 CALL CGPERS(Q(ICPOIN))
715 ENDIF
716* Inserting objects in Hide + Wire structures
717 CALL GDCGHI(IWORK,NOBJ,NWWS,LSTEP,ISG,NTVOL,ISHAPE)
718 GOTO 999
719***SG
720C
721 120 CONTINUE
722C
723C SPHE -----> call CGSPHE
724C
725 IVCLOS=1
726*SG
727* Size evaluation
728 IF(IWORK.LE.2.AND.IVFUN.NE.0)THEN
729* NWS = n. words for each sphere
730 NCGVOL=NCGVOL+NWS
731 GOTO 999
732 ENDIF
733*
734 R=RMAX
735 RMAX2=R
736 RMAX1=0
737 RMIN1=0
738 RMIN2=0
739 NLAT=11
740 NLON=11
741 NWOR=4000
742 IF(IWORK.EQ.3.AND.(PAR(3).EQ.0.AND.(PAR(4).EQ.0.OR.
743 +PAR(4).EQ.180)))THEN
744 NLAT=29
745 NLON=29
746 NWOR=30000
747 ENDIF
748 ICPOIN=JCGOBJ+1
749* Creating object
750 CALL CGSPHE(R,NLAT,NLON,NWOR,Q(ICPOIN))
751 DO 130 J=1,3
752 T(J,1)=GRMAT(3*J-2,NLEVEL)
753 T(J,2)=GRMAT(3*J-1,NLEVEL)
754 T(J,3)=GRMAT(3*J,NLEVEL)
755 130 CONTINUE
756 CALL CGRIFL(T,Q(ICPOIN))
757*SG
758 CGERR=Q(ICPOIN)
759 IF(CGERR.LE.0)THEN
760 CALL GDCGER(CGERR)
761 IF(KCGST.EQ.-2) GOTO 999
762 IF(KCGST.EQ.-3) THEN
763 KCGST=0
764 WRITE(CHMAIL,10000)ISHAPE,NAMES(NLEVEL)
765 CALL GMAIL(0,0)
766 GOTO 999
767 ENDIF
768 ENDIF
769 CALL CGCEV(1,Q(ICPOIN))
770 IF(PAR(3).NE.0.OR.(PAR(4).NE.0.AND.PAR(4).NE.180))THEN
771 ISHAPE=99
772 SPI1(1)=-COS((90-PAR(3))*DEGRAD)
773 SPI1(2)=0
774 SPI1(3)=-COS(PAR(3)*DEGRAD)
775 SPI1(4)=0
776 SPI2(1)=-COS((90-PAR(4))*DEGRAD)
777 SPI2(2)=0
778 SPI2(3)=-COS(PAR(4)*DEGRAD)
779 SPI2(4)=0
780 ISP1=JCGOBJ+4000
781 CALL CGSLIC(Q(ICPOIN),SPI1,4000,Q(ISP1))
782 ISP2=JCGOBJ+8000
783 CALL CGSLIC(Q(ISP1),SPI2,4000,Q(ISP2))
784 ICPOIN=ISP2
785 CALL CGCEV(1,Q(ICPOIN))
786 ENDIF
787 DO 140 J=1,3
788 T(J,1)=GRMAT(3*J-2,NLEVEL)
789 T(J,2)=GRMAT(3*J-1,NLEVEL)
790 T(J,3)=GRMAT(3*J,NLEVEL)
791 140 CONTINUE
792 CALL CGAFFI(T,Q(ICPOIN))
793 XV=GTRAN(1,NLEVEL)
794 YV=GTRAN(2,NLEVEL)
795 ZV=GTRAN(3,NLEVEL)
796 CALL CGSHIF(XV,YV,ZV,Q(ICPOIN))
797***SG
798* Shifting object
799 IF(KSHIFT.GT.0)THEN
800 CALL GDSHIF(IVOLNA,ICPOIN)
801 ENDIF
802*
803 IF(GBOOM.NE.0)THEN
804 CALL GDBOMB(ICPOIN,ISHAPE)
805 IF(ITSTCU.EQ.0)GOTO 999
806 ENDIF
807*
808*
809* Hidden Volume Removal:
810* Computing closed volumes visibility and skipping
811* the unvisible ones; a great increase in speed
812* and a great reduction in n. of words used are obtained
813* in this way.
814*
815 CALL CGMNMX(Q(ICPOIN),RRMIN,RRMAX)
816 IF(ISUBLI.EQ.1)THEN
817 AA1=RRMIN(1)-S1
818 AA2=RRMIN(2)-S2
819 AA3=RRMIN(3)-S3
820 BB1=RRMAX(1)-SS1
821 BB2=RRMAX(2)-SS2
822 BB3=RRMAX(3)-SS3
823 IF(AA1.GT.0.001.AND.AA2.GT.0.001.AND.AA3.GT.0.001.AND. BB1.LT.
824 + -0.001.AND.BB2.LT.-0.001.AND.BB3.LT.-0.001)THEN
825 IF(ISHAPE.NE.99)THEN
826 IF(IWORK.EQ.0.OR.IWORK.EQ.3)THEN
827 ITSTCU=0
828 NCGVOL=NCGVOL-NWS
829 GOTO 999
830 ENDIF
831 ENDIF
832 ENDIF
833 ENDIF
834 IF(IPORLI.EQ.1)THEN
835 S1=RRMIN(1)
836 S2=RRMIN(2)
837 S3=RRMIN(3)
838 SS1=RRMAX(1)
839 SS2=RRMAX(2)
840 SS3=RRMAX(3)
841 SRAGMX=R
842 SRAGMN=0.
843 RAINT1=0.
844 RAINT2=0.
845 IPORNT=1
846 PORMAR(1)=R
847 PORMIR(1)=0.
848 ENDIF
849* Create clipping objects
850 IF(ICUT.NE.0.OR.IHOLE.NE.0)CALL GDCGSL(IVOLNA,ISHAPE)
851* Perspective view
852 IF (IPRJ.EQ.IPERS) THEN
853 CALL CGPERS(Q(ICPOIN))
854 ENDIF
855* Inserting objects in Hide + Wire structures
856 CALL GDCGHI(IWORK,NOBJ,NWWS,LSTEP,ISG,NTVOL,ISHAPE)
857 GOTO 999
858***SG
859*
860 150 CONTINUE
861C
862C PGON ----> call CGZREV
863C
864 NTVOL=NZ-1
865 ANG1=PHIMIN
866 ANG2=PHIMAX
867**SG
868 AANG=ABS(ANG2-ANG1)
869 AZLAT=AANG*APPROS
870 ZLAT=AZLAT/360
871 NANG=ZLAT
872 IF(NANG.EQ.0)NANG=1
873 AZ=ZLAT-NANG
874 IF(AZ.GT..5)NANG=NANG+1
875 IF(NDIVAN.LT.NANG)THEN
876 NANG=NDIVAN
877* WRITE(CHMAIL,10400)NANG,NAMES(NLEVEL)
878* CALL GMAIL(0,0)
879 ENDIF
880 AATMAX=NANG*360./AANG
881 LATMAX=AATMAX
882 ALA=AATMAX-LATMAX
883 IF(ALA.GT..5)LATMAX=LATMAX+1
884**SG
885 AFINV=1./COS(PI/LATMAX)
886 FINV=ABS(AFINV)
887 JSURZ=1
888 ZR(1)=PAR(5)
889 RMIR(1)=PAR(6)*FINV
890 RMAR(1)=PAR(7)*FINV
891*SG
892 RMAR(1)=RMAR(1)+.001
893*SG
894 DO 160 I=1,NTVOL
895* ZA=PAR(5+3*(I-1))
896 ZB=PAR(5+3*I)
897**SG
898 ZB=ZB+.001
899********* DIFZ=ABS(ZB-ZA)
900********* IF(DIFZ.LT.0.001)GOTO 220
901**SG
902 JSURZ=JSURZ+1
903 ZR(JSURZ)=ZB
904 RMIR(JSURZ)=PAR(6+3*I)*FINV
905 RMAR(JSURZ)=PAR(7+3*I)*FINV
906**SG
907 RMAR(JSURZ)=RMAR(JSURZ)+.001
908*
909 160 CONTINUE
910*
911* Checking if all Inner Radii are 0. ==> 'Closed' Volume
912*
913* NRAD=NTVOL+1
914* DO 230 I=1,NRAD
915* IF(RMIR(I).GT.0.00001)GOTO 240
916* 230 CONTINUE
917* IVCLOS=1
918* 240 CONTINUE
919*
920* Size evaluation
921 IF(IWORK.LE.2.AND.IVFUN.NE.0)THEN
922 NCGVOL=NCGVOL+NWREV*(NANG+1)*NTVOL
923 GOTO 999
924 ENDIF
925 IF(IPORLI.EQ.1)THEN
926 SRAGMN=10000.
927 RAINT1=10000.
928 ENDIF
929*
930 DO 220 IVOL=1,NTVOL
931 ISG=ISG+1
932 IVCLOS=1
933 IF((RMIR(IVOL).GT.0.00001).OR.(RMIR(IVOL+1).GT.
934 + 0.00001))IVCLOS=0
935 XZ(1,1)=RMIR(IVOL)
936 XZ(2,1)=ZR(IVOL)
937 XZ(1,2)=RMAR(IVOL)
938 XZ(2,2)=ZR(IVOL)
939 XZ(1,3)=RMAR(IVOL+1)
940 XZ(2,3)=ZR(IVOL+1)
941 XZ(1,4)=RMIR(IVOL+1)
942 XZ(2,4)=ZR(IVOL+1)
943 ZR(IVOL+1)=ZR(IVOL+1)+.001
944 ICPOIN=JCGOBJ+1
945* Creating object
946**SG
947 CALL CGZREV(XZ,ANG1,ANG2,NANG,4000,Q(ICPOIN))
948 DO 170 J=1,3
949 T(J,1)=GRMAT(3*J-2,NLEVEL)
950 T(J,2)=GRMAT(3*J-1,NLEVEL)
951 T(J,3)=GRMAT(3*J,NLEVEL)
952 170 CONTINUE
953 CALL CGRIFL(T,Q(ICPOIN))
954 CGERR=Q(ICPOIN)
955 IF(CGERR.LE.0)THEN
956 CALL GDCGER(CGERR)
957 IF(KCGST.EQ.-2) GOTO 999
958 IF(KCGST.EQ.-3) THEN
959 KCGST=0
960 WRITE(CHMAIL,10000)ISHAPE,NAMES(NLEVEL)
961 CALL GMAIL(0,0)
962 WRITE(CHMAIL,10400)(PAR(I),I=1,4)
963 CALL GMAIL(0,0)
964 DO 180 J=1,NZ
965 ZPR=PAR(5+(J-1)*3)
966 RMIPR=PAR(6+(J-1)*3)
967 RMAPR=PAR(7+(J-1)*3)
968 WRITE(CHMAIL,10600)J,ZPR,RMIPR,RMAPR
969 CALL GMAIL(0,0)
970 180 CONTINUE
971 GOTO 999
972 ENDIF
973 ENDIF
974 CALL CGCEV(1,Q(ICPOIN))
975 DO 190 J=1,3
976 T(J,1)=GRMAT(3*J-2,NLEVEL)
977 T(J,2)=GRMAT(3*J-1,NLEVEL)
978 T(J,3)=GRMAT(3*J,NLEVEL)
979 190 CONTINUE
980 CALL CGAFFI(T,Q(ICPOIN))
981 XV=GTRAN(1,NLEVEL)
982 YV=GTRAN(2,NLEVEL)
983 ZV=GTRAN(3,NLEVEL)
984 CALL CGSHIF(XV,YV,ZV,Q(ICPOIN))
985***SG
986* Shifting object
987 IF(KSHIFT.GT.0)THEN
988 CALL GDSHIF(IVOLNA,ICPOIN)
989 ENDIF
990*
991 IF(GBOOM.NE.0)THEN
992 CALL GDBOMB(ICPOIN,ISHAPE)
993 IF(ITSTCU.EQ.0)GOTO 220
994 ENDIF
995*
996*
997* Hidden Volume Removal:
998* Computing closed volumes visibility and skipping
999* the unvisible ones; a great increase in speed
1000* and a great reduction in n. of words used are obtained
1001* in this way.
1002*
1003 CALL CGMNMX(Q(ICPOIN),RRMIN,RRMAX)
1004 IF(ISUBLI.EQ.1)THEN
1005 AA1=RRMIN(1)-S1
1006 AA2=RRMIN(2)-S2
1007 AA3=RRMIN(3)-S3
1008 BB1=RRMAX(1)-SS1
1009 BB2=RRMAX(2)-SS2
1010 BB3=RRMAX(3)-SS3
1011 IF(AA1.GT.0.001.AND.AA2.GT.0.001.AND.AA3.GT.0.001.AND.
1012 + BB1.LT.-0.001.AND.BB2.LT.-0.001.AND.BB3.LT.-0.001)THEN
1013 AMARMA(IVOL) =MIN(RMAR(IVOL),RMAR(IVOL+1))
1014 AMARMA(IVOL+1)=MAX(RMAR(IVOL),RMAR(IVOL+1))
1015 AMIRMA(IVOL) =MIN(RMIR(IVOL),RMIR(IVOL+1))
1016 AMIRMA(IVOL+1)=MAX(RMIR(IVOL),RMIR(IVOL+1))
1017 RMAX1=AMARMA(IVOL)
1018 RMAX2=AMARMA(IVOL+1)
1019 RMIN1=AMIRMA(IVOL)
1020 RMIN2=AMIRMA(IVOL+1)
1021 IF(SRAGMX.NE.0.)THEN
1022 DO 200 ITER=1,IPORNT
1023 IF(RMAX1.EQ.PORMAR(ITER).OR.RMAX2.EQ.PORMAR(ITER))
1024 + GOTO 210
1025 IF(RMIN1.EQ.PORMIR(ITER).OR.RMIN2.EQ.PORMIR(ITER))
1026 + THEN
1027 IF(PORMIR(ITER).NE.0.)GOTO 210
1028 ENDIF
1029 200 CONTINUE
1030 ENDIF
1031 IF(ISCOP.EQ.1)THEN
1032 IF((AMARMA(IVOL+1).GE.SRAGMX.OR.AMARMA(IVOL) .GT.SRAG
1033 + MN))GOTO 210
1034 IF((AMIRMA(IVOL+1).LE.RAINT2.OR.AMIRMA(IVOL)
1035 + .LE.RAINT1).AND.(RAINT2.NE.0))GOTO 210
1036 ENDIF
1037 IF(IWORK.EQ.0.OR.IWORK.EQ.3)THEN
1038 ITSTCU=0
1039 NCGVOL=NCGVOL-NWPROD
1040 GOTO 220
1041 ENDIF
1042 ENDIF
1043 ENDIF
1044 IF(IPORLI.EQ.1)THEN
1045 IF(RRMIN(1).LT.S1)S1=RRMIN(1)
1046 IF(RRMIN(2).LT.S2)S2=RRMIN(2)
1047 IF(RRMIN(3).LT.S3)S3=RRMIN(3)
1048 IF(RRMAX(1).GT.SS1)SS1=RRMAX(1)
1049 IF(RRMAX(2).GT.SS2)SS2=RRMAX(2)
1050 IF(RRMAX(3).GT.SS3)SS3=RRMAX(3)
1051 IF(RMAR(IVOL).GT.SRAGMX)SRAGMX=RMAR(IVOL)
1052 IF(RMAR(IVOL).LT.SRAGMN)SRAGMN=RMAR(IVOL)
1053 IF(RMAR(IVOL+1).GT.SRAGMX)SRAGMX=RMAR(IVOL+1)
1054 IF(RMAR(IVOL+1).LT.SRAGMN)SRAGMN=RMAR(IVOL+1)
1055 IF(RMIR(IVOL).GT.RAINT2)RAINT2=RMIR(IVOL)
1056 IF(RMIR(IVOL).LT.RAINT1)RAINT1=RMIR(IVOL)
1057 IF(RMIR(IVOL+1).GT.RAINT2)RAINT2=RMIR(IVOL+1)
1058 IF(RMIR(IVOL+1).LT.RAINT1)RAINT1=RMIR(IVOL+1)
1059 PORMAR(IVOL)=RMAR(IVOL)
1060 PORMIR(IVOL)=RMIR(IVOL)
1061 IPORNT =NTVOL
1062 ENDIF
1063 210 CONTINUE
1064* Create clipping objects
1065 IF(ICUT.NE.0.OR.IHOLE.NE.0)CALL GDCGSL(IVOLNA,ISHAPE)
1066* Perspective view
1067 IF (IPRJ.EQ.IPERS) THEN
1068 CALL CGPERS(Q(ICPOIN))
1069 ENDIF
1070* Inserting objects in Hide + Wire structures
1071 CALL GDCGHI(IWORK,NOBJ,NWWS,LSTEP,ISG,NTVOL,ISHAPE)
1072***SG
1073 220 CONTINUE
1074 GOTO 999
1075*
1076 230 CONTINUE
1077C
1078C PCON ----> call CGZREV
1079C
1080 NTVOL=NZ-1
1081 ANG1=PHIMIN
1082 ANG2=PHIMAX
1083**SG
1084 AANG=ABS(ANG2-ANG1)
1085 AZLAT=AANG*APPROS
1086 ZLAT=AZLAT/360
1087 NANG=ZLAT
1088 IF(NANG.EQ.0)NANG=1
1089 AZ=ZLAT-NANG
1090 IF(AZ.GT..5)NANG=NANG+1
1091**SG
1092 AFINV=1./COS(PI/APPROS)
1093 FINV=ABS(AFINV)
1094 JSURZ=1
1095 ZR(1)=PAR(4)
1096 RMIR(1)=PAR(5)*FINV
1097 RMAR(1)=PAR(6)*FINV
1098*SG
1099 RMAR(1)=RMAR(1)+.1
1100*SG
1101 DO 240 I=1,NTVOL
1102* ZA=PAR(4+3*(I-1))
1103 ZB=PAR(4+3*I)
1104**SG
1105 ZB=ZB+.001
1106******** DIFZ=ABS(ZB-ZA)
1107******** IF(DIFZ.LT.0.001)GOTO 290
1108**SG
1109 JSURZ=JSURZ+1
1110 ZR(JSURZ)=ZB
1111 RMIR(JSURZ)=PAR(5+3*I)*FINV
1112 RMAR(JSURZ)=PAR(6+3*I)*FINV
1113**SG
1114 RMAR(JSURZ)=RMAR(JSURZ)+.1
1115*
1116 240 CONTINUE
1117*
1118* Checking if all Inner Radii are 0. ==> 'Closed' Volume
1119*
1120* NRAD=NTVOL+1
1121* DO 300 I=1,NRAD
1122* IF(RMIR(I).GT.0.00001)GOTO 310
1123* 300 CONTINUE
1124* IVCLOS=1
1125* 310 CONTINUE
1126*
1127*
1128* Size evaluation
1129 IF(IWORK.LE.2.AND.IVFUN.NE.0)THEN
1130 NCGVOL=NCGVOL+NWREV*(NANG+1)*NTVOL
1131 GOTO 999
1132 ENDIF
1133 IF(IPORLI.EQ.1)THEN
1134 SRAGMN=10000.
1135 RAINT1=10000.
1136 ENDIF
1137*
1138 DO 300 IVOL=1,NTVOL
1139 ISG=ISG+1
1140 IVCLOS=1
1141 IF((RMIR(IVOL).GT.0.00001).OR.(RMIR(IVOL+1).GT.
1142 + 0.00001))IVCLOS=0
1143 XZ(1,1)=RMIR(IVOL)
1144 XZ(2,1)=ZR(IVOL)
1145 XZ(1,2)=RMAR(IVOL)
1146 XZ(2,2)=ZR(IVOL)
1147 XZ(1,3)=RMAR(IVOL+1)
1148 XZ(2,3)=ZR(IVOL+1)
1149 XZ(1,4)=RMIR(IVOL+1)
1150 XZ(2,4)=ZR(IVOL+1)
1151 ZR(IVOL+1)=ZR(IVOL+1)+.1
1152 ICPOIN=JCGOBJ+1
1153* Creating object
1154**SG
1155 CALL CGZREV(XZ,ANG1,ANG2,NANG,4000,Q(ICPOIN))
1156 DO 250 J=1,3
1157 T(J,1)=GRMAT(3*J-2,NLEVEL)
1158 T(J,2)=GRMAT(3*J-1,NLEVEL)
1159 T(J,3)=GRMAT(3*J,NLEVEL)
1160 250 CONTINUE
1161 CALL CGRIFL(T,Q(ICPOIN))
1162 CALL CGCEV(-1,Q(ICPOIN))
1163 CGERR=Q(ICPOIN)
1164 IF(CGERR.LE.0)THEN
1165 CALL GDCGER(CGERR)
1166 IF(KCGST.EQ.-2) GOTO 999
1167 IF(KCGST.EQ.-3) THEN
1168 KCGST=0
1169 WRITE(CHMAIL,10000)ISHAPE,NAMES(NLEVEL)
1170 CALL GMAIL(0,0)
1171 WRITE(CHMAIL,10500)(PAR(I),I=1,3)
1172 CALL GMAIL(0,0)
1173 DO 260 J=1,NZ
1174 ZPR=PAR(4+(J-1)*3)
1175 RMIPR=PAR(5+(J-1)*3)
1176 RMAPR=PAR(6+(J-1)*3)
1177 WRITE(CHMAIL,10600)J,ZPR,RMIPR,RMAPR
1178 CALL GMAIL(0,0)
1179 260 CONTINUE
1180 GOTO 999
1181 ENDIF
1182 ENDIF
1183 CALL CGCEV(1,Q(ICPOIN))
1184 DO 270 J=1,3
1185 T(1,J)=GRMAT(3*J-2,NLEVEL)
1186 T(2,J)=GRMAT(3*J-1,NLEVEL)
1187 T(3,J)=GRMAT(3*J,NLEVEL)
1188 T(4,J)=0.
1189 270 CONTINUE
1190 CALL CGAFFI(T,Q(ICPOIN))
1191 XV=GTRAN(1,NLEVEL)
1192 YV=GTRAN(2,NLEVEL)
1193 ZV=GTRAN(3,NLEVEL)
1194 CALL CGSHIF(XV,YV,ZV,Q(ICPOIN))
1195*
1196***SG
1197* Shifting object
1198 IF(KSHIFT.GT.0)THEN
1199 CALL GDSHIF(IVOLNA,ICPOIN)
1200 ENDIF
1201*
1202 IF(GBOOM.NE.0)THEN
1203 CALL GDBOMB(ICPOIN,ISHAPE)
1204 IF(ITSTCU.EQ.0)GOTO 300
1205 ENDIF
1206*
1207*
1208* Hidden Volume Removal:
1209* Computing closed volumes visibility and skipping
1210* the unvisible ones; a great increase in speed
1211* and a great reduction in n. of words used are obtained
1212* in this way.
1213*
1214 CALL CGMNMX(Q(ICPOIN),RRMIN,RRMAX)
1215 IF(ISUBLI.EQ.1)THEN
1216 AA1=RRMIN(1)-S1
1217 AA2=RRMIN(2)-S2
1218 AA3=RRMIN(3)-S3
1219 BB1=RRMAX(1)-SS1
1220 BB2=RRMAX(2)-SS2
1221 BB3=RRMAX(3)-SS3
1222 IF(AA1.GT.0.001.AND.AA2.GT.0.001.AND.AA3.GT.0.001.AND.
1223 + BB1.LT.-0.001.AND.BB2.LT.-0.001.AND.BB3.LT.-0.001)THEN
1224 AMARMA(IVOL) =MIN(RMAR(IVOL),RMAR(IVOL+1))
1225 AMARMA(IVOL+1)=MAX(RMAR(IVOL),RMAR(IVOL+1))
1226 AMIRMA(IVOL) =MIN(RMIR(IVOL),RMIR(IVOL+1))
1227 AMIRMA(IVOL+1)=MAX(RMIR(IVOL),RMIR(IVOL+1))
1228 RMAX1=AMARMA(IVOL)
1229 RMAX2=AMARMA(IVOL+1)
1230 RMIN1=AMIRMA(IVOL)
1231 RMIN2=AMIRMA(IVOL+1)
1232 IF(SRAGMX.NE.0.)THEN
1233 DO 280 ITER=1,IPORNT
1234 IF(RMAX1.EQ.PORMAR(ITER).OR.RMAX2.EQ.PORMAR(ITER))
1235 + GOTO 290
1236 IF(RMIN1.EQ.PORMIR(ITER).OR.RMIN2.EQ.PORMIR(ITER))
1237 + THEN
1238 IF(PORMIR(ITER).NE.0)GOTO 290
1239 ENDIF
1240 280 CONTINUE
1241 ENDIF
1242 IF(ISCOP.EQ.1)THEN
1243 IF((AMARMA(IVOL+1).GE.SRAGMX.OR.AMARMA(IVOL) .GE.SRAG
1244 + MN))GOTO 290
1245 IF((AMIRMA(IVOL+1).LE.RAINT2.AND.AMIRMA(IVOL)
1246 + .LE.RAINT1).AND.(RAINT2.NE.0))GOTO 290
1247 ENDIF
1248 IF(IWORK.EQ.0.OR.IWORK.EQ.3)THEN
1249 NCGVOL=NCGVOL-NWPROD
1250 ITSTCU=0
1251 GOTO 300
1252 ENDIF
1253 ENDIF
1254 ENDIF
1255 IF(IPORLI.EQ.1)THEN
1256 IF(RRMIN(1).LT.S1)S1=RRMIN(1)
1257 IF(RRMIN(2).LT.S2)S2=RRMIN(2)
1258 IF(RRMIN(3).LT.S3)S3=RRMIN(3)
1259 IF(RRMAX(1).GT.SS1)SS1=RRMAX(1)
1260 IF(RRMAX(2).GT.SS2)SS2=RRMAX(2)
1261 IF(RRMAX(3).GT.SS3)SS3=RRMAX(3)
1262 IF(RMAR(IVOL).GT.SRAGMX)SRAGMX=RMAR(IVOL)
1263 IF(RMAR(IVOL).LT.SRAGMN)SRAGMN=RMAR(IVOL)
1264 IF(RMAR(IVOL+1).GT.SRAGMX)SRAGMX=RMAR(IVOL+1)
1265 IF(RMAR(IVOL+1).LT.SRAGMN)SRAGMN=RMAR(IVOL+1)
1266 IF(RMIR(IVOL).GT.RAINT2)RAINT2=RMIR(IVOL)
1267 IF(RMIR(IVOL).LT.RAINT1)RAINT1=RMIR(IVOL)
1268 IF(RMIR(IVOL+1).GT.RAINT2)RAINT2=RMIR(IVOL+1)
1269 IF(RMIR(IVOL+1).LT.RAINT1)RAINT1=RMIR(IVOL+1)
1270 PORMAR(IVOL)=RMAR(IVOL)
1271 PORMIR(IVOL)=RMIR(IVOL)
1272 IPORNT =NTVOL
1273 ENDIF
1274 290 CONTINUE
1275* Create clipping objects
1276 IF(ICUT.NE.0.OR.IHOLE.NE.0)CALL GDCGSL(IVOLNA,ISHAPE)
1277* Perspective view
1278 IF (IPRJ.EQ.IPERS) THEN
1279 CALL CGPERS(Q(ICPOIN))
1280 ENDIF
1281* Inserting object in Hide + Wire structures
1282 CALL GDCGHI(IWORK,NOBJ,NWWS,LSTEP,ISG,NTVOL,ISHAPE)
1283 300 CONTINUE
1284 GOTO 999
1285*
1286***SG
1287*
128810000 FORMAT(' Check Parameters of Shape ',I3,' in volume ',A4)
128910100 FORMAT(' Warning >>> RMIN1 greater than RMAX1 for shape '
1290 + ,I3,' in volume ',A4)
129110200 FORMAT(' Warning >>> RMIN2 greater than RMAX2 for shape '
1292 + ,I3,' in volume ',A4)
129310300 FORMAT(' Warning >>> PHIMIN greater than PHIMAX for shape'
1294 + ,I3,' in volume ',A4)
1295*10400 FORMAT(' PGON with NPDV = ',I5,' in volume ',A4,' NPDV very
1296* + large . It must be < 30 . Volume will not be drawn. ')
129710400 FORMAT(' PHI1 = ',F8.3,' DPHI = ',F8.3,' NPDV = ',F8.1
1298 + ,' NZ = ',F8.1)
129910500 FORMAT(' PHI1 = ',F8.3,' DPHI = ',F8.3,' NZ = ',F8.1)
130010600 FORMAT(' J = ',I5,' Z = ',F8.3,' RMIN = ',F8.3
1301 + ,' RMAX = ',F8.3)
1302*10800 FORMAT(' Please, increase size of Zebra store by ',I10,
1303* + ' words')
1304*
1305***SG
1306 999 END