This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / GEANT321 / cgpack / cgfare.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1995/10/24 10:19:43  cernlib
6 * Geant
7 *
8 *
9 #include "geant321/pilot.h"
10 *CMZ :  3.21/02 29/03/94  15.41.31  by  S.Giani
11 *-- Author :
12       SUBROUTINE CGFARE(NT,FACE,IVIS,ISHAPE)
13 ************************************************************************
14 *                                                                      *
15 *     Name: CGFARE                                                     *
16 *     Author: S. Giani                           Date:    20.05.91     *
17 *                                                Revised:              *
18 *                                                                      *
19 *     Function: HIDDEN FACE REMOVAL algoritm                           *
20 *               and transformation to screen coordinates               *
21 *                                                                      *
22 *     References: none                                                 *
23 *                                                                      *
24 *     Input:  NT - number of transformation to screen coordinates      *
25 *             FACE - face                                              *
26 *                                                                      *
27 *     Output: IVIS - visibility flag                                   *
28 *                    1 - if visible face                               *
29 *                   -1 - if unvisible                                  *
30 *                                                                      *
31 *                                                                      *
32 *                                                                      *
33 ************************************************************************
34 #include "geant321/cgcfac.inc"
35 #include "geant321/cggpar.inc"
36 #include "geant321/cgdelt.inc"
37 #include "geant321/cgctra.inc"
38 #include "geant321/gcspee.inc"
39 #include "geant321/gcmutr.inc"
40 ***SG
41       DIMENSION ACCMI1(6),ACCMI2(6),ACCMI3(6),
42      +          ACCMA1(6),ACCMA2(6),ACCMA3(6)
43       DIMENSION SMI(3),SMA(3),POMI(3),POMA(3)
44       SAVE ACCMI1,ACCMI2,ACCMI3,ACCMA1,ACCMA2,ACCMA3
45       SAVE POMI,POMA,ACCXT1,ACCXT2,ACCNT1,ACCNT2
46 ***SG
47       REAL      FACE(*)
48 #if !defined(CERNLIB_SINGLE)
49       DOUBLE PRECISION  T(4,3),A,B,C,S
50 #endif
51 #if defined(CERNLIB_SINGLE)
52       REAL      T(4,3)
53 #endif
54 *-
55       IVIS   = -1
56       DO 120 I=1,4
57          DO 110 J=1,3
58             T(I,J) = TSCRN(I,J,NT)
59   110    CONTINUE
60   120 CONTINUE
61 *
62 ***SG
63 **         HIDDEN FACE REMOVAL
64 *     Computing face scope and skipping if it's 'covered': this
65 *     can allow a great increase in speed and a great reduction
66 *     in number of memory words used.
67 *
68          J = LCGFAC
69          NTIM=NTIM+1
70          SRFMI1 = FACE(J+KCGX1)
71          SRFMI2 = FACE(J+KCGY1)
72          SRFMI3 = FACE(J+KCGZ1)
73          SRFMA1 = FACE(J+KCGX1)
74          SRFMA2 = FACE(J+KCGY1)
75          SRFMA3 = FACE(J+KCGZ1)
76          NEDGE = FACE(KCGNE)
77          DO 333 NE=1,NEDGE
78             SRFMI1 = MIN(SRFMI1,FACE(J+KCGX1),FACE(J+KCGX2))
79             SRFMI2 = MIN(SRFMI2,FACE(J+KCGY1),FACE(J+KCGY2))
80             SRFMI3 = MIN(SRFMI3,FACE(J+KCGZ1),FACE(J+KCGZ2))
81             SRFMA1 = MAX(SRFMA1,FACE(J+KCGX1),FACE(J+KCGX2))
82             SRFMA2 = MAX(SRFMA2,FACE(J+KCGY1),FACE(J+KCGY2))
83             SRFMA3 = MAX(SRFMA3,FACE(J+KCGZ1),FACE(J+KCGZ2))
84             J = J + LCGEDG
85   333    CONTINUE
86 *        If volume set limits
87          IF(IPORLI.EQ.1)THEN
88 *         If no clipping or shifting or exploding mode
89           IF(NAIN.EQ.0.AND.KSHIFT.EQ.0.AND.GBOOM.EQ.0)THEN
90 *          If volume created by cgbox
91            IF(ISHAPE.LT.5.OR.ISHAPE.EQ.10)THEN
92 *           Set 'faces scope' for sublim faces created by cgbox
93             ACCMI1(NTIM) = SRFMI1
94             ACCMI2(NTIM) = SRFMI2
95             ACCMI3(NTIM) = SRFMI3
96             ACCMA1(NTIM) = SRFMA1
97             ACCMA2(NTIM) = SRFMA2
98             ACCMA3(NTIM) = SRFMA3
99 *           Set 'volume scope' for sublim faces of revolution
100             POMI(1)=S1
101             POMI(2)=S2
102             POMI(3)=S3
103             POMA(1)=SS1
104             POMA(2)=SS2
105             POMA(3)=SS3
106             ACCXT2=SRAGMX
107             ACCXT1=SRAGMN
108             ACCNT1=RAINT1
109             ACCNT2=RAINT2
110 *          If volume of revolution
111            ELSE
112 *           Set 'faces scope' for sublim faces created by cgbox
113             ACCMI1(4)=S1
114             ACCMI1(6)=SS1
115             ACCMI2(3)=SS2
116             ACCMI2(5)=S2
117             ACCMI3(1)=S3
118             ACCMI3(2)=SS3
119             ACCMA1(4)=S1
120             ACCMA1(6)=SS1
121             ACCMA2(3)=SS2
122             ACCMA2(5)=S2
123             ACCMA3(1)=S3
124             ACCMA3(2)=SS3
125 *           Set 'volume scope' and 'radial scope' for sublim faces of revolution
126             POMI(1)=S1
127             POMI(2)=S2
128             POMI(3)=S3
129             POMA(1)=SS1
130             POMA(2)=SS2
131             POMA(3)=SS3
132             ACCXT2=SRAGMX
133             ACCXT1=SRAGMN
134             ACCNT1=RAINT1
135             ACCNT2=RAINT2
136            ENDIF
137 *         If clipping or shifting or exploding mode on
138           ELSE
139 *          Set 'volume scope' for all sublim faces, and 'radial scope' as
140 *          well for sublim faces of revolution
141            POMI(1)=S1
142            POMI(2)=S2
143            POMI(3)=S3
144            POMA(1)=SS1
145            POMA(2)=SS2
146            POMA(3)=SS3
147            ACCXT2=SRAGMX
148            ACCXT1=SRAGMN
149            ACCNT1=RAINT1
150            ACCNT2=RAINT2
151           ENDIF
152 *        If volume is to be compared with limits
153          ELSEIF(ISUBLI.EQ.1)THEN
154 *         If no clipping or shifting or exploding mode
155           IF(NAIN.EQ.0.AND.KSHIFT.EQ.0.AND.GBOOM.EQ.0)THEN
156 *          If volume created by cgbox
157            IF(ISHAPE.LT.5.OR.ISHAPE.EQ.10)THEN
158 *           Comparison face by face
159             IF(NTIM.EQ.1)THEN
160                IF(SRFMI3.GT.ACCMI3(NTIM).AND.SRFMA3
161      +         .GT.ACCMA3(NTIM))GOTO 999
162             ELSEIF(NTIM.EQ.2)THEN
163                IF(SRFMI3.LT.ACCMI3(NTIM).AND.SRFMA3
164      +         .LT.ACCMA3(NTIM))GOTO 999
165             ELSEIF(NTIM.EQ.3)THEN
166                IF(SRFMI2.LT.ACCMI2(NTIM).AND.SRFMA2
167      +         .LT.ACCMA2(NTIM))GOTO 999
168             ELSEIF(NTIM.EQ.5)THEN
169                IF(SRFMI2.GT.ACCMI2(NTIM).AND.SRFMA2
170      +         .GT.ACCMA2(NTIM))GOTO 999
171             ELSEIF(NTIM.EQ.4)THEN
172                IF(SRFMI1.GT.ACCMI1(NTIM).AND.SRFMA1
173      +         .GT.ACCMA1(NTIM))GOTO 999
174             ELSEIF(NTIM.EQ.6)THEN
175                IF(SRFMI1.LT.ACCMI1(NTIM).AND.SRFMA1
176      +         .LT.ACCMA1(NTIM))GOTO 999
177             ENDIF
178             GOTO 888
179 *          If volume of revolution
180            ELSE
181 *           Comparison with mother scopes
182             SMI(1)=SRFMI1
183             SMI(2)=SRFMI2
184             SMI(3)=SRFMI3
185             SMA(1)=SRFMA1
186             SMA(2)=SRFMA2
187             SMA(3)=SRFMA3
188             EXTRA1=RMAX1
189             EXTRA2=RMAX2
190             ENTRA1=RMIN1
191             ENTRA2=RMIN2
192 *           If mother was created by cgbox or if it was of revolution
193             ISP=0
194             DO 127 I=1,3
195              SPMI=SMI(I)-POMI(I)
196              SPMA=SMA(I)-POMA(I)
197              ASPMI=ABS(SPMI)
198              ASPMA=ABS(SPMA)
199              SMIA=SMI(I)-SMA(I)
200              ASMIA=ABS(SMIA)
201              IF(SPMI.GE.-0.001.AND.SPMA.LE.0.001)THEN
202               ISP=ISP+1
203               IF(ASPMI.LE.0.001.OR.ASPMA.LE.0.001)THEN
204                IF(ASMIA.LE.0.001)GOTO 888
205               ENDIF
206              ENDIF
207   127       CONTINUE
208             IF(ISP.EQ.3)THEN
209 *            If mother was of revolution
210              IF(ACCXT2.NE.0)THEN
211               IF(ISCOP.EQ.1.AND.(ISHAPE.EQ.11.OR.ISHAPE.EQ.12
212      +        .OR.ISHAPE.EQ.7.OR.ISHAPE.EQ.8))THEN
213               EXXT1=EXTRA1-ACCXT1
214               EXXT2=EXTRA2-ACCXT2
215               ENNT1=ENTRA1-ACCNT1
216               ENNT2=ENTRA2-ACCNT2
217               IF(EXXT1.LT.-0.001.AND.EXXT2.LT.-0.001.AND.
218      +        ENNT1.GT.0.001.AND.ENNT2.GT.0.001)THEN
219                GOTO 999
220               ELSEIF(EXXT1.LT.-0.001.AND.EXXT2.LT.-0.001.AND.
221      +        ACCNT1.LT.0.001.AND.ACCNT2.LT.0.001)THEN
222                GOTO 999
223               ELSE
224                GOTO 888
225               ENDIF
226               ELSE
227               DO 701 ITER=1,IPORNT
228                 EXXT1=EXTRA1-PORMAR(ITER)
229                 EXXT2=EXTRA2-PORMAR(ITER)
230                 AEXXT1=ABS(EXXT1)
231                 AEXXT2=ABS(EXXT2)
232                 ENNT1=ENTRA1-PORMIR(ITER)
233                 ENNT2=ENTRA2-PORMIR(ITER)
234                 AENNT1=ABS(ENNT1)
235                 AENNT2=ABS(ENNT2)
236                 IF(AEXXT1.LT.0.001.OR.AEXXT2.LT.0.001)GOTO 888
237                 IF(AENNT1.LT.0.001.OR.AENNT2.LT.0.001)THEN
238                   IF(PORMIR(ITER).NE.0.)GOTO 888
239                 ENDIF
240  701          CONTINUE
241               ENDIF
242              ENDIF
243              GOTO 999
244             ELSE
245              GOTO 888
246             ENDIF
247            ENDIF
248 *         If clipping or shifting or exploding mode on
249           ELSE
250 *          Get scopes of the daughter (of each kind)
251            SMI(1)=SRFMI1
252            SMI(2)=SRFMI2
253            SMI(3)=SRFMI3
254            SMA(1)=SRFMA1
255            SMA(2)=SRFMA2
256            SMA(3)=SRFMA3
257            EXTRA1=RMAX1
258            EXTRA2=RMAX2
259            ENTRA1=RMIN1
260            ENTRA2=RMIN2
261 * If mother was clipped, check relative position of daughter and clipping
262 *   volumes; only if they don't interact, hidden face removal can work.
263            DO 111 IJ=1,JPORJJ
264             IFVFUN=0
265             DO 301 J=1,3
266              PMISMA=CLIPMI(J+3*IJ-3)-SMA(J)
267              SMIPMA=SMI(J)-CLIPMA(J+3*IJ-3)
268              APMISM=ABS(PMISMA)
269              ASMIPM=ABS(SMIPMA)
270              SMASMI=SMA(J)-SMI(J)
271              ASMASM=ABS(SMASMI)
272              IF(PMISMA.GE.-0.001.OR.
273      +       SMIPMA.GE.-0.001)THEN
274                IFVFUN=1
275                IF(APMISM.LT.0.001.OR.
276      +         ASMIPM.LT.0.001)THEN
277                 IF(ASMASM.LT.0.0001)GOTO 888
278                ENDIF
279                GO TO 302
280              ENDIF
281   301       CONTINUE
282   302       CONTINUE
283            IF(IFVFUN.EQ.0.AND.NAIN.NE.3)GO TO 888
284   111      CONTINUE
285 *          If mother was created by cgbox or if it was of revolution
286            ISP=0
287            DO 128 I=1,3
288             SPMI=SMI(I)-POMI(I)
289             SPMA=SMA(I)-POMA(I)
290             ASPMI=ABS(SPMI)
291             ASPMA=ABS(SPMA)
292             SMIA=SMI(I)-SMA(I)
293             ASMIA=ABS(SMIA)
294             IF(SPMI.GE.-0.001.AND.SPMA.LE.0.001)THEN
295              ISP=ISP+1
296              IF(ASPMI.LE.0.001.OR.ASPMA.LE.0.001)THEN
297               IF(ASMIA.LE.0.001)GOTO 888
298              ENDIF
299             ENDIF
300   128      CONTINUE
301            IF(ISP.EQ.3)THEN
302 *           If mother was of revolution
303             IF(ACCXT2.NE.0)THEN
304               IF(ISCOP.EQ.1.AND.(ISHAPE.EQ.11.OR.ISHAPE.EQ.12
305      +        .OR.ISHAPE.EQ.7.OR.ISHAPE.EQ.8))THEN
306               EXXT1=EXTRA1-ACCXT1
307               EXXT2=EXTRA2-ACCXT2
308               ENNT1=ENTRA1-ACCNT1
309               ENNT2=ENTRA2-ACCNT2
310               IF(EXXT1.LT.-0.001.AND.EXXT2.LT.-0.001.AND.
311      +        ENNT1.GT.0.001.AND.ENNT2.GT.0.001)THEN
312                GOTO 999
313               ELSEIF(EXXT1.LT.-0.001.AND.EXXT2.LT.-0.001.AND.
314      +        ACCNT1.LT.0.001.AND.ACCNT2.LT.0.001)THEN
315                GOTO 999
316               ELSE
317                GOTO 888
318               ENDIF
319               ELSE
320               DO 702 ITER=1,IPORNT
321                 EXXT1=EXTRA1-PORMAR(ITER)
322                 EXXT2=EXTRA2-PORMAR(ITER)
323                 AEXXT1=ABS(EXXT1)
324                 AEXXT2=ABS(EXXT2)
325                 ENNT1=ENTRA1-PORMIR(ITER)
326                 ENNT2=ENTRA2-PORMIR(ITER)
327                 AENNT1=ABS(ENNT1)
328                 AENNT2=ABS(ENNT2)
329                 IF(AEXXT1.LT.0.001.OR.AEXXT2.LT.0.001)GOTO 888
330                 IF(AENNT1.LT.0.001.OR.AENNT2.LT.0.001)THEN
331                   IF(PORMIR(ITER).NE.0.)GOTO 888
332                 ENDIF
333  702          CONTINUE
334               ENDIF
335             ENDIF
336             IF(ISCOP.EQ.1)THEN
337              IF((ISHAPE.GT.1.AND.ISHAPE.LT.5).OR.ISHAPE.EQ.10)
338      +       GOTO 888
339             ENDIF
340             GOTO 999
341            ELSE
342             GOTO 888
343            ENDIF
344           ENDIF
345          ENDIF
346  888  CONTINUE
347 *
348 ***SG
349 *
350       C      = (T(2,1)*T(3,2) - T(3,1)*T(2,2))*FACE(KCGAA) +
351      +         (T(3,1)*T(1,2) - T(1,1)*T(3,2))*FACE(KCGBB) +
352      +         (T(1,1)*T(2,2) - T(2,1)*T(1,2))*FACE(KCGCC)
353       IF (C .LE. 0.)     GOTO 999
354       B      = (T(2,3)*T(3,1) - T(3,3)*T(2,1))*FACE(KCGAA) +
355      +         (T(3,3)*T(1,1) - T(1,3)*T(3,1))*FACE(KCGBB) +
356      +         (T(1,3)*T(2,1) - T(2,3)*T(1,1))*FACE(KCGCC)
357       A      = (T(2,2)*T(3,3) - T(3,2)*T(2,3))*FACE(KCGAA) +
358      +         (T(3,2)*T(1,3) - T(1,2)*T(3,3))*FACE(KCGBB) +
359      +         (T(1,2)*T(2,3) - T(2,2)*T(1,3))*FACE(KCGCC)
360       S      = 1./SQRT(A*A+B*B+C*C)
361       AABCD(1) = A*S
362       AABCD(2) = B*S
363       AABCD(3) = C*S
364 *
365       F1(KCGAF) = FACE(KCGAF)
366       F1(KCGNE) = FACE(KCGNE)
367       F1(KCGAA) = 0.
368       F1(KCGBB) = 0.
369       F1(KCGCC) = 1.
370       F1(KCGDD) = 0.
371       F1(KCGNE) = FACE(KCGNE)
372 *
373 **           T R A S F E R   P O I N T   C O O R D I N A T E S
374 *
375       NEDGE  = FACE(KCGNE)
376       IF (LCGFAC+NEDGE*LCGEDG .GT. LABC)
377      +       PRINT *, ' Problem in CGFVIS: no space'
378       XGRAV  = 0.
379       YGRAV  = 0.
380       ZGRAV  = 0.
381       J      = LCGFAC
382       DO 200 NE=1,NEDGE
383          F1(J+KCGAE) = FACE(J+KCGAE)
384          X = FACE(J+KCGX1)
385          Y = FACE(J+KCGY1)
386          Z = FACE(J+KCGZ1)
387          F1(J+KCGX1) = T(1,1)*X + T(2,1)*Y + T(3,1)*Z + T(4,1)
388          F1(J+KCGY1) = T(1,2)*X + T(2,2)*Y + T(3,2)*Z + T(4,2)
389          F1(J+KCGZ1) = T(1,3)*X + T(2,3)*Y + T(3,3)*Z + T(4,3)
390          X = FACE(J+KCGX2)
391          Y = FACE(J+KCGY2)
392          Z = FACE(J+KCGZ2)
393          F1(J+KCGX2) = T(1,1)*X + T(2,1)*Y + T(3,1)*Z + T(4,1)
394          F1(J+KCGY2) = T(1,2)*X + T(2,2)*Y + T(3,2)*Z + T(4,2)
395          F1(J+KCGZ2) = T(1,3)*X + T(2,3)*Y + T(3,3)*Z + T(4,3)
396          XGRAV = XGRAV + F1(J+KCGX1) + F1(J+KCGX2)
397          YGRAV = YGRAV + F1(J+KCGY1) + F1(J+KCGY2)
398          ZGRAV = ZGRAV + F1(J+KCGZ1) + F1(J+KCGZ2)
399          J = J + LCGEDG
400   200 CONTINUE
401       XFACT = 1./(2.*NEDGE)
402       XGRAV = XGRAV * XFACT
403       YGRAV = YGRAV * XFACT
404       ZGRAV = ZGRAV * XFACT
405       AABCD(4) =-(AABCD(1)*XGRAV + AABCD(2)*YGRAV + AABCD(3)*ZGRAV)
406 *
407 **           F I N D   F A C E   M I N - M A X
408 *
409       J      = LCGFAC
410       RFMIN(1) = F1(J+KCGX1)
411       RFMIN(2) = F1(J+KCGY1)
412       RFMIN(3) = F1(J+KCGZ1)
413       RFMAX(1) = F1(J+KCGX1)
414       RFMAX(2) = F1(J+KCGY1)
415       RFMAX(3) = F1(J+KCGZ1)
416       DO 300 NE=1,NEDGE
417          RFMIN(1) = MIN(RFMIN(1),F1(J+KCGX1),F1(J+KCGX2))
418          RFMIN(2) = MIN(RFMIN(2),F1(J+KCGY1),F1(J+KCGY2))
419          RFMIN(3) = MIN(RFMIN(3),F1(J+KCGZ1),F1(J+KCGZ2))
420          RFMAX(1) = MAX(RFMAX(1),F1(J+KCGX1),F1(J+KCGX2))
421          RFMAX(2) = MAX(RFMAX(2),F1(J+KCGY1),F1(J+KCGY2))
422          RFMAX(3) = MAX(RFMAX(3),F1(J+KCGZ1),F1(J+KCGZ2))
423          F1(J+KCGZ1) = 0.
424          F1(J+KCGZ2) = 0.
425          J = J + LCGEDG
426   300 CONTINUE
427       DRFACE(1) =-RFMAX(1)
428       DRFACE(2) =-RFMAX(2)
429       DRFACE(3) = RFMIN(1)
430       DRFACE(4) = RFMIN(2)
431       DRFACE(5) = RFMIN(3)
432 *
433 **          C O M P U T E    F A C E    V I S I B L E    A R E A
434 *
435       J      = LCGFAC
436       S      = 0.
437       DLMAX  = 0.
438       DO 400 NE=1,NEDGE
439          S = S + F1(J+KCGX1)*F1(J+KCGY2) - F1(J+KCGX2)*F1(J+KCGY1)
440          DL = ABS(F1(J+KCGX2)-F1(J+KCGX1)) + ABS(F1(J+KCGY2)-F1(J+
441      +   KCGY1))
442          IF (DLMAX .LT. DL) DLMAX = DL
443          J = J + LCGEDG
444   400 CONTINUE
445       IF (DLMAX .LT. EESCR)     GOTO 999
446       IF (S .GT. DLMAX*EESCR)   IVIS = 1
447 *
448   999 RETURN
449       END