*
* $Id$
*
* $Log$
* Revision 1.1  1995/10/24 10:20:50  cernlib
* Initial revision
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/04 18/01/95  19.56.13  by  S.Giani
*-- Author :
      SUBROUTINE GLVOLU (NLEV, LNAM, LNUM, IER)
C.
C.    ******************************************************************
C.    *                                                                *
C.    *   Loads the common block GCVOLU for the volume at lebel NLEV   *
C.    *   as described by the lists of names (LNAM) and numbers (LNUM) *
C.    *                                                                *
C.    *   The routine is optimized and does not re-compute the part of *
C.    *   history already available in GCVOLU.                         *
C.    *                                                                *
C.    *   IER returns non zero in case of fatal error                  *
C.    *                                                                *
C.    *   Called by : 'User', GDRVOL                                   *
C.    *   Authors   : S.Banerjee, F.Bruyant, A.McPherson               *
C.    *                                                                *
C.    ******************************************************************
C.
#include "geant321/gcbank.inc"
#include "geant321/gconsp.inc"
#include "geant321/gcunit.inc"
#include "geant321/gcvolu.inc"
      PARAMETER  (NLVMAX=15)
      INTEGER    LNUM(*), LNAM(*), IDTYP(3,12)
      DIMENSION  LVOLS(NLVMAX), LINDX(NLVMAX)
      REAL       XC(3)
      CHARACTER*4 KNAME
      SAVE IDTYP
C.
      DATA IDTYP / 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 2, 3, 1,
     +             2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 4, 3, 1, 1, 1,
     +             2, 3, 1, 2, 3, 1/
C.
C.    ------------------------------------------------------------------
*
      IER = 0
      NLEVL=NLEV
      IF (NLEVL.LE.0.OR.NLEVL.GT.NLVMAX) GO TO 910
      IF (JGPAR.EQ.0) THEN
         CALL MZBOOK (IXCONS, JGPAR, JGPAR, 1, 'GPAR', NLVMAX, 0,
     +                NLVMAX, 2, 0)
      ENDIF
      IF (NLEVEL.EQ.0)                 GO TO 20
*
* *** Scan tree from top to bottom to
*       check if some levels are already filled
*
      NLMX = MIN (NLEVL, NLEVEL)
      NLEVEL = 0
      DO 10 I = 1,NLMX
         IF (LNAM(I).NE.NAMES(I))  GO TO 15
         IF (LNUM(I).NE.NUMBER(I)) GO TO 15
         NLEVEL = NLEVEL +1
   10 CONTINUE
      IF (NLEVL.GT.NLEVEL) GO TO 95
      nlevel=0
   15 IF (NLEVEL.NE.0)    GO TO 95
*
* *** Special case, first volume
*
   20 IF (JVOLUM.EQ.0)    GO TO 920
      IF (IQ(JVOLUM+1).EQ.LNAM(1)) THEN
         IVO = 1
      ELSE
#if defined(CERNLIB_DEBUG)
         WRITE (CHMAIL, 7000) LNAM(1)
         CALL GMAIL (0, 0)
#endif
         IF (IQ(JVOLUM-1).LE.1) GO TO 920
         DO 25 IV=2,IQ(JVOLUM-1)
            IF (IQ(JVOLUM+IV).EQ.LNAM(1)) THEN
               IVO = IV
               GO TO 30
            ENDIF
   25    CONTINUE
         WRITE (CHMAIL, 8000) LNAM(1)
         CALL GMAIL (0, 0)
         GO TO 999
      ENDIF
   30 NLEVEL = 1
      JVO = LQ(JVOLUM-IVO)
      LVOLUM(NLEVEL) = IVO
      NAMES(NLEVEL)  = IQ(JVOLUM+IVO)
      NUMBER(NLEVEL) = LNUM(1)
      GONLY(NLEVEL)  = 1.
      IF (LQ(JVO).EQ.0) THEN
         NLDEV(1) = NLVMAX
      ELSE
         NLDEV(1) = 1
      ENDIF
      IF (IVO.EQ.1) THEN
         LINDEX(NLEVEL) = 1
         LINMX (NLEVEL) = 1
         NLDM = 0
         IQ(JGPAR+NLEVEL) = Q(JVO+5)
         LQ(JGPAR-NLEVEL) = JVO + 6
      ELSE
         CALL UHTOC(NAMES,4,KNAME,4)
         CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
         IF (NLDM.GT.0) THEN
            JVOM = LQ(JVOLUM-LVOLS(NLDM))
            NIN  = Q(JVOM+3)
            IF (NIN.LT.0) THEN
               LINDEX(NLEVEL) = LNUM(1)
            ELSE
               LINMX(NLEVEL)  = NIN
               DO 70 IN = 1, NIN
                  JIN  = LQ(JVOM-IN)
                  IF (IFIX(Q(JIN+2)).NE.LVOLUM(1)) GO TO 70
                  IF (IFIX(Q(JIN+3)).NE.LNUM(1))   GO TO 70
                  LINDEX(NLEVEL) = IN
                  GO TO 75
   70          CONTINUE
               GO TO 920
            ENDIF
   75       JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
            IF (NLDM.GT.1) THEN
               DO 76 ILEV = 2, NLDM
                  IF (IQ(JPAR+1).EQ.0) THEN
                     JPAR = LQ(JPAR-LINDX(ILEV))
                     IF (JPAR.EQ.0) GO TO 77
                  ELSE IF (IQ(JPAR-3).GT.1) THEN
                     JPAR = LQ(JPAR-LINDX(ILEV))
                  ELSE
                     JPAR = LQ(JPAR-1)
                  ENDIF
   76          CONTINUE
            ENDIF
            IF (NIN.GT.0) THEN
               JPAR = LQ(JPAR-IN)
               IF (JPAR.EQ.0) GO TO 77
            ELSE
               NDIV = IQ(JPAR+1)
               LINMX(NLEVEL) = NDIV
               IF (LINDEX(1).GT.NDIV) THEN
                  NL1  = 1
                  NAME = IQ(JVOLUM+LVOLS(NLDM))
                  GO TO 950
               ENDIF
               IF (IQ(JPAR-3).GT.1) THEN
                  IF (LINDEX(1).GT.0) THEN
                     JPAR = LQ(JPAR-LINDEX(1))
                  ELSE
                     JPAR = LQ(JPAR-1)
                  ENDIF
               ELSE
                  JPAR = LQ(JPAR-1)
               ENDIF
            ENDIF
            IQ(JGPAR+NLEVEL) = IQ(JPAR+5)
            LQ(JGPAR-NLEVEL) = JPAR + 5
            GO TO 78
   77       NPAR = Q(JVO+5)
            IF (NPAR.EQ.0.AND.NIN.GT.0) THEN
               IQ(JGPAR+NLEVEL) = Q(JIN+9)
               LQ(JGPAR-NLEVEL) = JIN+9
            ELSE
               IQ(JGPAR+NLEVEL) = NPAR
               LQ(JGPAR-NLEVEL) = JVO + 6
            ENDIF
         ELSE
            LINDEX(NLEVEL) = 1
            LINMX(NLEVEL)  = 1
            IQ(JGPAR+NLEVEL) = Q(JVO+5)
            LQ(JGPAR-NLEVEL) = JVO + 6
         ENDIF
      ENDIF
   78 CONTINUE
*
      DO 90 I = 1,3
         GTRAN(I,1) = 0.
         DO 80 J = 1,3
            K = (I-1)*3 +J
            GRMAT(K,1) = 0.
   80    CONTINUE
         K = I*4 -3
         GRMAT(K,1) = 1.
   90 CONTINUE
      GRMAT(10,1) = 0.
      IF (NLEVL.GT.1) THEN
         GO TO 100
      ELSE
         GO TO 990
      ENDIF
*
* *** Check if there are volumes up in the tree where development
*           structure exists
*
   95 IF (LVOLUM(1).EQ.1.OR.NLDEV(1).EQ.1) THEN
         NLDM = 0
      ELSE
         CALL UHTOC(NAMES,4,KNAME,4)
         CALL GLMOTH (KNAME, NUMBER, NLDM, LVOLS, LINDX)
      ENDIF
*
*  ** Next level
*
  100 CONTINUE
      IVO = LVOLUM(NLEVEL)
      JVO = LQ(JVOLUM-IVO)
      NLD = NLDEV(NLEVEL)
      NIN = Q(JVO+3)
      IF (NIN.EQ.0) GO TO 930
      NL1 = NLEVEL +1
*
      IF (NIN.GT.0) THEN
*
*  *     Content obtained by positioning
*
         DO 110 IN=1,NIN
            JIN=LQ(JVO-IN)
            IVOT=Q(JIN+2)
            IF (IQ(JVOLUM+IVOT).NE.LNAM(NL1)) GO TO 110
            INUM = Q(JIN+3)
            IF (INUM.EQ.LNUM(NL1)) GO TO 115
  110    CONTINUE
         GO TO 940
  115    IF (NLEVEL.GE.NLD) THEN
*           (case with JVOLUM structure locally developed)
            JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
            DO 120 ILEV = NLD, NLEVEL
               IF (IQ(JPAR+1).EQ.0) THEN
                  IF (ILEV.EQ.NLEVEL) THEN
                     JPAR = LQ(JPAR-IN)
                  ELSE
                     JPAR = LQ(JPAR-LINDEX(ILEV+1))
                  ENDIF
                  IF (JPAR.EQ.0) GO TO 125
               ELSE IF (IQ(JPAR-3).GT.1) THEN
                  JPAR = LQ(JPAR-LINDEX(ILEV+1))
               ELSE
                  JPAR = LQ(JPAR-1)
               ENDIF
  120       CONTINUE
            JPAR = JPAR + 5
            NPAR = IQ(JPAR)
            GO TO 130
         ELSE IF (NLDM.GT.0) THEN
            JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
            IF (NLDM.GT.1) THEN
               DO 121 ILEV = 2, NLDM
                  IF (IQ(JPAR+1).EQ.0) THEN
                     JPAR = LQ(JPAR-LINDX(ILEV))
                     IF (JPAR.EQ.0)   GO TO 125
                  ELSE IF (IQ(JPAR-3).GT.1) THEN
                     JPAR = LQ(JPAR-LINDX(ILEV))
                  ELSE
                     JPAR = LQ(JPAR-1)
                  ENDIF
  121          CONTINUE
            ENDIF
            DO 122 ILEV = 1, NL1
               IF (IQ(JPAR+1).EQ.0) THEN
                  IF (ILEV.EQ.NL1) THEN
                     JPAR = LQ(JPAR-IN)
                  ELSE
                     JPAR = LQ(JPAR-LINDEX(ILEV))
                  ENDIF
                  IF (JPAR.EQ.0) GO TO 125
               ELSE IF (IQ(JPAR-3).GT.1) THEN
                  JPAR = LQ(JPAR-LINDEX(ILEV))
               ELSE
                  JPAR = LQ(JPAR-1)
               ENDIF
  122       CONTINUE
            JPAR = JPAR + 5
            NPAR = IQ(JPAR)
            GO TO 130
         ENDIF
*        (normal case)
  125    JVOT = LQ(JVOLUM-IVOT)
         NPAR = Q(JVOT+5)
         IF (NPAR.EQ.0) THEN
            JPAR = JIN + 9
            NPAR = Q(JPAR)
         ELSE
            JPAR = JVOT + 6
         ENDIF
*
  130    IROTT = Q(JIN+4)
         NINSK = NIN
         GONLY(NL1) = Q(JIN+8)
         CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), Q(JIN+5), IROTT
     +,               GTRAN(1,NL1), GRMAT(1,NL1))
*
      ELSE
*
*  *     This section for divided objects
*
         JDIV = LQ(JVO-1)
         IVOT = Q(JDIV+2)
         IF (LNAM(NL1).NE.IQ(JVOLUM+IVOT)) GO TO 960
         JVOT = LQ(JVOLUM-IVOT)
         IF (NLEVEL.GT.NLD) THEN
*           (case with JVOLUM structure locally developed)
            JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
            DO 135 ILEV = NLD, NLEVEL-1
               IF (IQ(JPAR+1).EQ.0) THEN
                  JPAR = LQ(JPAR-LINDEX(ILEV+1))
                  IF (JPAR.EQ.0) GO TO 140
               ELSE IF (IQ(JPAR-3).GT.1) THEN
                  JPAR = LQ(JPAR-LINDEX(ILEV+1))
               ELSE
                  JPAR = LQ(JPAR-1)
               ENDIF
               IF (ILEV.EQ.NLEVEL-1) THEN
                  NDIV = IQ(JPAR+1)
                  ORIG =  Q(JPAR+2)
                  STEP =  Q(JPAR+3)
               ENDIF
  135       CONTINUE
            GO TO 145
         ELSE IF (NLD.EQ.NLEVEL) THEN
            JPAR = LQ(LQ(JVOLUM-LVOLUM(NLD)))
         ELSE IF (NLDM.GT.0) THEN
            JPAR = LQ(LQ(JVOLUM-LVOLS(1)))
            IF (NLDM.GT.1) THEN
               DO 136 ILEV = 2, NLDM
                  IF (IQ(JPAR+1).EQ.0) THEN
                     JPAR = LQ(JPAR-LINDX(ILEV))
                     IF (JPAR.EQ.0) GO TO 140
                  ELSE IF (IQ(JPAR-3).GT.1) THEN
                     JPAR = LQ(JPAR-LINDX(ILEV))
                  ELSE
                     JPAR = LQ(JPAR-1)
                  ENDIF
  136          CONTINUE
            ENDIF
            DO 137 ILEV = 1, NLEVEL
               IF (IQ(JPAR+1).EQ.0) THEN
                  JPAR = LQ(JPAR-LINDEX(ILEV))
                  IF (JPAR.EQ.0) GO TO 140
               ELSE IF (IQ(JPAR-3).GT.1) THEN
                  JPAR = LQ(JPAR-LINDEX(ILEV))
               ELSE
                  JPAR = LQ(JPAR-1)
               ENDIF
               IF (ILEV.EQ.NLEVEL) THEN
                  NDIV = IQ(JPAR+1)
                  ORIG =  Q(JPAR+2)
                  STEP =  Q(JPAR+3)
               ENDIF
  137       CONTINUE
            GO TO 145
         ELSE
            JPAR = 0
         ENDIF
*        (normal case)
  140    NDIV = Q(JDIV+3)
         ORIG = Q(JDIV+4)
         STEP = Q(JDIV+5)
  145    IN   = LNUM(NL1)
         IF (IN.LT.1.OR.IN.GT.NDIV) THEN
            NAME = NAMES(NLEVEL)
            GO TO 950
         ENDIF
*
         IF (JPAR.NE.0) THEN
            IF (IQ(JPAR-3).GT.1) THEN
               JPAR = LQ(JPAR-IN)
            ELSE
               JPAR = LQ(JPAR-1)
            ENDIF
            JPAR = JPAR + 5
            NPAR = IQ(JPAR)
         ELSE
            NPAR = Q(JVOT+5)
            JPAR = JVOT + 6
         ENDIF
         GONLY(NL1) = GONLY(NLEVEL)
*
         IAXIS = Q(JDIV+1)
         ISH   = Q(JVO+2)
         IDT   = IDTYP(IAXIS,ISH)
         NINSK = NDIV
*
         IF (IDT.EQ.1) THEN
            DO 151 I = 1, 3
  151       XC(I) = 0.
            XC(IAXIS) = ORIG + (IN - 0.5) * STEP
            IF (ISH.EQ.4.OR.(ISH.EQ.10.AND.IAXIS.NE.1)) THEN
               CALL GCENT (IAXIS, XC)
            ENDIF
            IF (GRMAT(10,NLEVEL).EQ.0.0) THEN
               DO 152 I = 1, 3
  152          GTRAN(I,NL1) = GTRAN(I,NLEVEL)+XC(I)
               DO 153 I = 1, 10
  153          GRMAT(I,NL1) = GRMAT(I,NLEVEL)
            ELSE
               CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), XC, 0,
     +                      GTRAN(1,NL1), GRMAT(1,NL1))
            ENDIF
*
         ELSE IF (IDT.EQ.3.OR.IDT.EQ.4) THEN
            IF (IDT.EQ.3) THEN
               PH0  = DEGRAD * (ORIG + (IN - 0.5) * STEP)
               CPHR = COS (PH0)
               SPHR = SIN (PH0)
            ELSE
               PH0  = 0.0
               CPHR = 1.0
               SPHR = 0.0
            ENDIF
            DO 154 I = 1, 3
               GTRAN(I  ,NL1) = GTRAN(I  ,NLEVEL)
               GRMAT(I  ,NL1) = GRMAT(I  ,NLEVEL)*CPHR
     +                        + GRMAT(I+3,NLEVEL)*SPHR
               GRMAT(I+3,NL1) = GRMAT(I+3,NLEVEL)*CPHR
     +                        - GRMAT(I  ,NLEVEL)*SPHR
               GRMAT(I+6,NL1) = GRMAT(I+6,NLEVEL)
  154       CONTINUE
            IF (PH0.EQ.0.0.AND.GRMAT(10,NLEVEL).EQ.0.0) THEN
               GRMAT(10,NL1) = 0.0
            ELSE
               GRMAT(10,NL1) = 1.0
            ENDIF
*
         ELSE
            DO 155 I = 1, 3
  155       GTRAN(I,NL1) = GTRAN(I,NLEVEL)
            DO 156 I = 1, 10
  156       GRMAT(I,NL1) = GRMAT(I,NLEVEL)
         ENDIF
      ENDIF
*
  200 LINDEX(NL1) = IN
      LVOLUM(NL1) = IVOT
      NAMES(NL1)  = LNAM(NL1)
      NUMBER(NL1) = LNUM(NL1)
      LINMX(NL1)  = NINSK
      IF (LQ(LQ(JVOLUM-IVOT)).EQ.0) THEN
         NLDEV(NL1) = NLD
      ELSE
         NLDEV(NL1) = NL1
      ENDIF
      IQ(JGPAR+NL1) = NPAR
      LQ(JGPAR-NL1) = JPAR
      NLEVEL = NL1
      IF (NLEVEL.EQ.NLEVL) GO TO 990
      GO TO 100
*
* *** Error messages
*
  910 IER = 1
      WRITE (CHMAIL, 1000) NLEV
      CALL GMAIL (0, 0)
      GO TO 999
*
  920 IER = 2
      WRITE (CHMAIL, 2000) LNAM(1)
      CALL GMAIL (0, 0)
      GO TO 999
*
  930 IER = 3
      WRITE (CHMAIL, 3000) NLEVEL,NLEV,NAMES(NLEVEL)
      CALL GMAIL (0, 0)
      GO TO 999
*
  940 IER = 4
      WRITE (CHMAIL, 4000) LNAM(NL1),NL1,NAMES(NLEVEL)
      CALL GMAIL (0, 0)
      GO TO 999
*
  950 IER = 5
      WRITE (CHMAIL, 5000) NL1,LNUM(NL1),NAME,NDIV
      CALL GMAIL (0, 0)
      GO TO 999
*
  960 IER = 6
      WRITE (CHMAIL, 6000) NL1,LNAM(NL1),IQ(JVOLUM+IVOT)
      CALL GMAIL (0, 0)
      GO TO 999
*
  990 CONTINUE
#if defined(CERNLIB_DEBUG)
      WRITE (CHMAIL, 1001) NLEVEL
      CALL GMAIL (0, 0)
      DO 991 I1=1,NLEVEL,5
         I2 = I1 + 4
         IF (I2.GT.NLEVEL) I2 = NLEVEL
         WRITE (CHMAIL, 1003) (NAMES(I),NUMBER(I),LVOLUM(I),LINDEX(I),
     +   I=I1,I2)
         CALL GMAIL (0, 0)
  991 CONTINUE
      DO 992 I= 1,NLEVEL
         WRITE (CHMAIL, 1002) (GTRAN(J,I),J=1,3),(GRMAT(J,I),J=1,10)
         CALL GMAIL (0, 0)
  992 CONTINUE
 1001 FORMAT (' GLVOLU : NLEVEL =',I3)
 1003 FORMAT (5(1X,A4,3I3))
 1002 FORMAT (1X,13F9.4)
#endif
*
 1000 FORMAT (' GLVOLU : called with useless Level # ',I5)
 2000 FORMAT (' GLVOLU : Volume ',A4,' not top of tree, or no tree')
 3000 FORMAT (' GLVOLU : at Level ',I3,' of ',I3,' there are no',
     *        ' contents for Volume ',A4)
 4000 FORMAT (' GLVOLU : Volume ',A4,' for Level ',I3,
     *        ' does not exist in Volume ',A4)
 5000 FORMAT (' GLVOLU : at Level ',I3,' asked for #',I3,
     *        ' in divided Volume ',A4,' which has ',I3,' divisions.')
 6000 FORMAT (' GLVOLU : at Level ',I3,' user name ',A4,
     *        ' not equal to name ',A4,' of division.')
#if defined(CERNLIB_DEBUG)
 7000 FORMAT (' GLVOLU : Warning, ',A4,' not top of tree',
     *        ' you should reset NLEVEL to 0 before tracking !')
#endif
 8000 FORMAT (' GLVOLU : Volume ',A4,' Level 1 does not exist')
*                                                             END GLVOLU
  999 END
