--- /dev/null
+*
+* $Id$
+*
+* $Log$
+* Revision 1.3 1998/02/09 16:48:33 japost
+* Simone's fix for MANY volumes in gmedia.
+*
+* Revision 1.2 1996/09/30 14:25:07 ravndal
+* Windows NT related modifications
+*
+* Revision 1.1.1.1 1995/10/24 10:20:51 cernlib
+* Geant
+*
+*
+#include "geant321/pilot.h"
+#if !defined(CERNLIB_OLD)
+*CMZ : 3.21/02 29/03/94 15.24.17 by S.Giani
+*-- Author :
+ SUBROUTINE GMEDIA (X, NUMED)
+C.
+C. ******************************************************************
+C. * *
+C. * Finds in which volume/medium the point X is, and updates the *
+C. * common /GCVOLU/ and the structure JGPAR accordingly. *
+C. * *
+C. * NUMED returns the tracking medium number, or 0 if point is *
+C. * outside the experimental setup. *
+C. * *
+C. * Called by : GTREVE, GLTRAC, 'User' *
+C. * Authors : R.Brun, F.Bruyant, A.McPherson *
+C. * S.Giani. *
+C. * *
+C. * Modified by S.Giani (1993) to perform the search according *
+C. * to the new 'virtual divisions' algorithm and to build the *
+C. * stack of the 'possible overlapping volumes' in the case of *
+C. * MANY volumes. Any kind of boolean operation is now possible.*
+C. * Divisions along arbitrary axis are now possible. *
+C. * *
+C. ******************************************************************
+C.
+#include "geant321/gcflag.inc"
+#include "geant321/gckine.inc"
+#include "geant321/gcbank.inc"
+#include "geant321/gcvolu.inc"
+#include "geant321/gctrak.inc"
+#if defined(CERNLIB_USRJMP)
+#include "geant321/gcjump.inc"
+#endif
+#include "geant321/gcvdma.inc"
+#include "geant321/gchvir.inc"
+C.
+ DIMENSION X(*)
+ REAL XC(6)
+ LOGICAL BTEST
+ CHARACTER*4 NAME
+C.
+C. ------------------------------------------------------------------
+*
+ nvmany=0
+ nfmany=0
+ new2fl=0
+*
+ IF (NLEVEL.EQ.0) CALL GMEDIN
+*
+* SECTION I: The /GCVOLU/ table contains the initial guess for a path
+* in the geometry tree on which X may be found. Look along this
+* path until X is found inside. This is the starting position.
+* If this is an ONLY volume with no daughters, we are done;
+* otherwise reset search record variables, proceed to section II.
+*
+* The information contained in INFROM has to be invalidated
+* because it has no meaning for the subsequent tracking. INFR
+* is a local variable used to optimise the search in the
+* geometry tree.
+*
+ INFROM = 0
+*
+* *** Check if point is in current volume
+*
+ INFR = 0
+ JVIN = 0
+C***** Code Expanded From Routine: GTRNSF
+C
+ 100 IF (GRMAT(10,NLEVEL) .EQ. 0.) THEN
+ XC(1) = X(1) - GTRAN(1,NLEVEL)
+ XC(2) = X(2) - GTRAN(2,NLEVEL)
+ XC(3) = X(3) - GTRAN(3,NLEVEL)
+*
+ ELSE
+ XL1 = X(1) - GTRAN(1,NLEVEL)
+ XL2 = X(2) - GTRAN(2,NLEVEL)
+ XL3 = X(3) - GTRAN(3,NLEVEL)
+ XC(1) = XL1*GRMAT(1,NLEVEL) + XL2*GRMAT(2,NLEVEL) + XL3*GRMAT(3
+ + ,NLEVEL)
+ XC(2) = XL1*GRMAT(4,NLEVEL) + XL2*GRMAT(5,NLEVEL) + XL3*GRMAT(6
+ + ,NLEVEL)
+ XC(3) = XL1*GRMAT(7,NLEVEL) + XL2*GRMAT(8,NLEVEL) + XL3*GRMAT(9
+ + ,NLEVEL)
+
+ ENDIF
+ xc(4)=0.
+ xc(5)=0.
+ xc(6)=0.
+C***** End of Code Expanded From Routine: GTRNSF
+*
+ JVO = LQ(JVOLUM-LVOLUM(NLEVEL))
+ JPAR = LQ(JGPAR-NLEVEL)
+ CALL GINME (XC, Q(JVO+2), Q(JPAR+1), IYES)
+ IF (IYES.EQ.0) THEN
+*
+* ** Point not in current volume, go up the tree
+*
+ IF (NLEVEL.GT.1) THEN
+ NLEVEL = NLEVEL -1
+ JVO = LQ(JVOLUM-LVOLUM(NLEVEL))
+ NIN = Q(JVO+3)
+ IF(NIN.GT.0) THEN
+*
+* Do not set INFR whne going up the tree. GMEDIA can be called
+* by the user and it should not assume that the previous
+* position has something to do with the current search. INFR
+* is otherwise useful when searching in a 'MANY' volume
+* configuration. This statement is commented for the above reason.
+*
+* INFR =LINDEX(NLEVEL+1)
+ ELSE
+ INFR =0
+ ENDIF
+ GO TO 100
+ ELSE
+*
+* * Point is outside setup
+*
+ NUMED = 0
+ GO TO 999
+ ENDIF
+ ENDIF
+*
+* ** Point is in current volume
+*
+ IF(INFR .GT.0) THEN
+ JIN=LQ(JVO-INFR )
+ IQ(JIN) = IBSET(IQ(JIN),4)
+ JVIN = JIN
+ ENDIF
+* To avoid starting from the protuding part of a MANY volume
+ IF(GONLY(NLEVEL).EQ.0.) THEN
+ NLEVEL = NLEVEL -1
+ GO TO 100
+ ENDIF
+ NLMIN = NLEVEL
+ NLMANY = 0
+*
+* SECTION II: X is found inside current node at NLEVEL in /GCVOLU/.
+* Search all contents recursively for any containing X.
+* Take the first one found, if any, and continue at that
+* level, incrementing NLEVEL and extending /GCVOLU/ tables.
+* This is continued until a level is reached where X is not
+* found in any of the contents, or there are no contents.
+* Note: Since Section II is re-entered from Section III, a blocking word
+* is used to mark those contents already checked. Upon exit from Section
+* II, these blocking words are cleared at NLEVEL, but may remain set in
+* levels between NLEVEL-1 and NLMIN, if any. They must be cleared at exit.
+*
+* ** Check contents, if any
+*
+ 200 JVO = LQ(JVOLUM-LVOLUM(NLEVEL))
+ NIN = Q(JVO+3)
+ if(raytra.eq.1..and.imyse.eq.1)then
+ CALL UHTOC(NAMES(NLEVEL),4,NAME,4)
+ CALL GFIND(NAME,'SEEN',ISSEEN)
+ if(isseen.eq.-2.or.isseen.eq.-1)goto 300
+ endif
+*
+* * Case with no contents
+*
+ IF (NIN.EQ.0) THEN
+ GO TO 300
+*
+* * Case with contents defined by division
+*
+ ELSEIF (NIN.LT.0) THEN
+ CALL GMEDIV (JVO, IN, XC, 1)
+ IF (IN.GT.0) THEN
+ INFR = 0
+ GO TO 200
+ ENDIF
+*
+* * Case with contents positioned
+*
+ ELSE
+ if(nin.gt.1)then
+ clmoth=q(jvirt+4*(LVOLUM(NLEVEL)-1)+3)
+ chmoth=q(jvirt+4*(LVOLUM(NLEVEL)-1)+4)
+ ndivto=q(jvirt+4*(LVOLUM(NLEVEL)-1)+2)
+ iaxis =q(jvirt+4*(LVOLUM(NLEVEL)-1)+1)
+ if(iaxis.le.3)then
+ ivdiv=((xc(iaxis)-clmoth)*ndivto/(chmoth-clmoth))+1
+ if(ivdiv.lt.1)then
+ ivdiv=1
+ elseif(ivdiv.gt.ndivto)then
+ ivdiv=ndivto
+ endif
+ else
+ call gfcoor(xc,iaxis,cx)
+ if(iaxis.eq.6)then
+ if((cx-clmoth).lt.-1.)then
+ cx=cx+360.
+ elseif((cx-chmoth).gt.1.)then
+ cx=cx-360.
+ endif
+ if(cx.gt.chmoth)then
+ cx=chmoth
+ elseif(cx.lt.clmoth)then
+ cx=clmoth
+ endif
+ endif
+ ivdiv=((cx-clmoth)*ndivto/(chmoth-clmoth))+1
+ if(ivdiv.lt.1)then
+ ivdiv=1
+ elseif(ivdiv.gt.ndivto)then
+ ivdiv=ndivto
+ endif
+ endif
+ jvdiv=lq(jvirt-LVOLUM(NLEVEL))
+ iofset=iq(jvdiv+ivdiv)
+ ncont=iq(jvdiv+iofset+1)
+ jcont=jvdiv+iofset+1
+ if(ncont.eq.0)goto 260
+ else
+ JCONT = LQ(JVO-NIN-1)+1
+ NCONT = 1
+ endif
+*
+* For each selected content in turn, check if point is inside
+*
+ DO 259 ICONT=1,NCONT
+ if(nin.eq.1)then
+ in=1
+ else
+ IN = IQ(JCONT+ICONT)
+ endif
+ IF(IN.EQ.0) THEN
+*
+* If the value IQ(JCONT+ICONT)=0 then we are back in the mother.
+* So jump to 260, the search is finished. Clean-up should be done
+* only up to ICONT-1, so we set:
+*
+ NCONT=ICONT-1
+ GOTO 260
+ ELSE
+ JIN = LQ(JVO-IN)
+ IF (.NOT.BTEST(IQ(JIN),4)) THEN
+ CALL GMEPOS (JVO, IN, XC, 1)
+ IF (IN.GT.0) THEN
+ new2fl=0
+ IF (GONLY(NLEVEL).NE.0.) THEN
+ NLMANY = 0
+ nvmany = 0
+ nfmany = 0
+ ENDIF
+ INFR = 0
+ GO TO 200
+ ELSE
+ IQ(JIN) = IBSET(IQ(JIN),4)
+ ENDIF
+ ENDIF
+ ENDIF
+ 259 CONTINUE
+*
+ 260 IF(NCONT.EQ.NIN) THEN
+ DO 268 IN=1,NIN
+ JIN = LQ(JVO-IN)
+ IQ(JIN) = IBCLR(IQ(JIN),4)
+ 268 CONTINUE
+ ELSE
+ DO 269 ICONT=1,NCONT
+ if(nin.eq.1)then
+ in=1
+ else
+ IN = IQ(JCONT+ICONT)
+ endif
+ JIN = LQ(JVO-IN)
+ IQ(JIN) = IBCLR(IQ(JIN),4)
+ 269 CONTINUE
+ IF(INFR .GT.0) THEN
+ JIN = LQ(JVO-INFR )
+ IQ(JIN) = IBCLR(IQ(JIN),4)
+ ENDIF
+ ENDIF
+*
+ ENDIF
+*
+* SECTION III: X is found at current node (NLEVEL in /GCVOLU) but not in
+* any of its contents, if any. If this is a MANY volume,
+* save it as a candidate best-choice, and continue the search
+* by backing up the tree one node and proceed to Section II.
+* If this is an ONLY volume, proceed to Section IV.
+*
+* *** Point is in current volume/medium, and not in any content
+*
+ 300 IF (GONLY(NLEVEL).EQ.0.) THEN
+*
+* ** Lowest level is 'NOT ONLY'
+*
+ IF (NLEVEL.GT.NLMANY) THEN
+ CALL GSCVOL
+ NLMANY = NLEVEL
+ nfmany=nvmany+1
+ ENDIF
+ if(new2fl.eq.0)then
+ nvmany=nvmany+1
+ manyle(nvmany)=nlevel
+ do 401 i = 1,nlevel
+ manyna(nvmany,i)=names(i)
+ manynu(nvmany,i)=number(i)
+ 401 continue
+ endif
+*
+* * Go up the tree up to a volume with positioned contents
+*
+ new2fl=-1
+ 310 INFR = LINDEX(NLEVEL)
+ NLEVEL = NLEVEL -1
+ JVO = LQ(JVOLUM-LVOLUM(NLEVEL))
+ NIN = Q(JVO+3)
+ IF (NIN.LT.0) GO TO 310
+*
+C***** Code Expanded From Routine: GTRNSF
+C
+ IF (GRMAT(10,NLEVEL) .EQ. 0.) THEN
+ XC(1) = X(1) - GTRAN(1,NLEVEL)
+ XC(2) = X(2) - GTRAN(2,NLEVEL)
+ XC(3) = X(3) - GTRAN(3,NLEVEL)
+*
+ ELSE
+ XL1 = X(1) - GTRAN(1,NLEVEL)
+ XL2 = X(2) - GTRAN(2,NLEVEL)
+ XL3 = X(3) - GTRAN(3,NLEVEL)
+ XC(1) = XL1*GRMAT(1,NLEVEL) + XL2*GRMAT(2,NLEVEL) + XL3*
+ + GRMAT(3,NLEVEL)
+ XC(2) = XL1*GRMAT(4,NLEVEL) + XL2*GRMAT(5,NLEVEL) + XL3*
+ + GRMAT(6,NLEVEL)
+ XC(3) = XL1*GRMAT(7,NLEVEL) + XL2*GRMAT(8,NLEVEL) + XL3*
+ + GRMAT(9,NLEVEL)
+
+ ENDIF
+C***** End of Code Expanded From Routine: GTRNSF
+*
+ JIN = LQ(JVO-INFR )
+ IQ(JIN) = IBSET(IQ(JIN),4)
+ NLMIN = MIN(NLEVEL,NLMIN)
+ GO TO 200
+ ENDIF
+*
+* SECTION IV: This is the end of the search. The current node (NLEVEL
+* in /GCVOLU/) is the lowest ONLY volume in which X is found.
+* If X was also found in any of its contents, they are MANY
+* volumes: the best-choice is the one among them at the greatest
+* level in the tree, and it is stored. Otherwise the current
+* volume is the solution. Before exit, all of the blocking
+* words leftover in the tree must be reset to zero.
+* Note: A valid structure is assumed, in which no ONLY volumes overlap.
+* If this rule is violated, or if a daughter is not entirely contained
+* within the mother volume, the results are unpredictable.
+*
+ DO 419 NL=NLMIN,NLEVEL-1
+ JVO = LQ(JVOLUM-LVOLUM(NL))
+ NIN = Q(JVO+3)
+ DO 418 IN=1,NIN
+ JIN = LQ(JVO-IN)
+ IQ(JIN) = IBCLR(IQ(JIN),4)
+ 418 CONTINUE
+ 419 CONTINUE
+*
+ if(nlmany.eq.0)then
+ nvmany=0
+ nfmany=0
+ endif
+ IF (NLMANY.GT.0) CALL GFCVOL
+ JVO = LQ(JVOLUM-LVOLUM(NLEVEL))
+ IF(JVIN.NE.0) IQ(JVIN) = IBCLR(IQ(JVIN),4)
+ NUMED = Q(JVO+4)
+* END GMEDIA
+ 999 IF(JGSTAT.NE.0) CALL GFSTAT(2)
+ END
+#endif
git://git.uio.no / u / mrichter / AliRoot.git / blobdiff