*CMZ :          16/09/99  09.49.24  by  Girish D. Patel
*CMZU:  3.01/00 28/02/94  07.10.43  by  Stephan Egli
*CMZU:  2.08/04 16/09/92  15.26.04  by  Stephan Egli
*CMZU:  2.05/00 01/11/91  16.31.24  by  Stephan Egli
*CMZ :  2.00/00 10/02/91  09.09.28  by  Stephan Egli
*CMZ :  1.08/02 06/02/91  17.15.18  by  Stephan Egli
*-- Author :
      SUBROUTINE FGEOM
*
*#**********************************************************************
*#                                                                     *
*#     SUBROUTINE FGEOM                                                *
*#                                                                     *
*# PURPOSE: Define Forward Tracker Materials Media and Geometry        *
*#                                                                     *
*# CALLED BY : UGEOM                                                   *
*#                                                                     *
*# INPUT : BOS BANKS FGMX,FGLM,FGME,FGRO,FGDR,FGDP,FGDM,FGAM           *
*#                                                                     *
*# OUTPUT : COMMON /FTROTM/ NFROT(0:LFROT) filled & GEOMETRY defined   *
*#                                                                     *
*# AUTHOR : Girish D. Patel                                            *
*#                                                                     *
*# CHANGED BY: Girish D. Patel     AT: 17/8/89                         *
*# REASON : CALL TO UDFPAR INSERTED  (FGTP bank used)                  *
*# CHANGED BY: Girish D. Patel     AT: 14/3/90                         *
*# REASON : GSORD call for FPSZ commented, not valid in coarse option  *
*# CHANGED BY: Girish D. Patel     AT: 15/09/99                        *
*# REASON : Changes for forward tracker upgrade                        *
*#**********************************************************************
*
*
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEEP,H1OSGO.
      COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12)
*KEND.
*
*KEEP,FROTM.
      PARAMETER (LFROTM = 10 )
      COMMON /FROTM/ NFROT(0:LFROTM)
*KEND.
*
      WRITE(6,*) ' FGEOM CALLED LCONFG = ',LCONFG

*   FORWARD TRACKER IS DETECTOR NUMBER 2
      NFDET = 2
*
*   DEFINE FORWARD TRACKING MATERIAL CONSTANTS FROM FGMA BOS BANK
*
*     CALL UGTBNK( 'FGMA', INDB )
*     IF( INDB.LE.0 )          THEN
*       WRITE(6,*) ' ** SUBR. UGEOFT ** FGMA BANK NOT FOUND ==> STOP '
*       STOP
*     ELSE
*       CALL UDFMAT( INDB )
*     ENDIF
*
*   DEFINE FORWARD TRACKING MATERIAL MIXTURES FROM FGMX BOS BANK
*
      CALL UGTBNK( 'FGMX', INDB )
      IF( INDB.LE.0 )          THEN
        WRITE(6,*) ' ** SUBR. UGEOFT ** FGMX BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFMIX( INDB )
      ENDIF
*
      CALL UGTBNK( 'FGLM', INDB )
      IF( INDB.LE.0 )          THEN
        WRITE(6,*) ' ** SUBR. UGEOFT ** FGLM BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFLMX( INDB )
      ENDIF
*
*   DEFINE FORWARD TRACKING MEDIA PARAMETERS FROM FGME BOS BANK
*
      CALL UGTBNK( 'FGME', INDB )
      IF( INDB.LE.0 )          THEN
        WRITE(6,*) ' ** SUBR. UGEOFT ** FGME BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFMED( INDB )
      ENDIF
*
*   DEFINE SPECIAL TRACKING MEDIA PARAMETERS FROM FGTP BOS BANK
*
      CALL UGTBNK( 'FGTP', INDB )
      IF( INDB.LE.0 )          THEN
         WRITE(6,*) ' ** SUBR. FGEOM ** FGTP BANK NOT FOUND ==> ',
     +                              'Default values will be used'
      ELSE
        CALL UDFPAR( INDB )
      ENDIF
*
*  DEFINE GEANT ROTATION MATRICES FOR FORWARD TRACKER FROM FGRO BOS BANK
*
      CALL UGTBNK( 'FGRO', INDB )
      IF( INDB.LE.0 ) THEN
        WRITE(6,*) ' ** SUBR. UGEOFT **  FGRO BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFROT( INDB, NFROT, LFROTM )
      ENDIF
*
*=======================================================================
*               NOW DEFINE DETECTORS
*=======================================================================
*
      IF(LCONFG.LT.10) THEN

      WRITE(6,*) ' FGEOM CALLED OLD SETUP ',LCONFG

*
*   DEFINE GEOMETRY OF PLANAR SET UP FROM FGDP BOS BANK
*
      CALL UGTBNK( 'FGDP' , INDB )
      IF( INDB.LE.0 ) THEN
        WRITE(6,*) ' ** SUBR. UGEOFT **  FGDP BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFVOL( INDB, NFROT, LFROTM )
      ENDIF
*
*       DEFINE ACTIVE VOLUME STRUCTURE for PLANARS
*
      CALL FPGEOM
*
*   DEFINE GEOMETRY OF MWPC SET UP FROM FGDM BOS BANK
*
      CALL UGTBNK( 'FGDM' , INDB )
      IF( INDB.LE.0 ) THEN
        WRITE(6,*) ' ** SUBR. UGEOFT **  FGDM BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFVOL( INDB, NFROT, LFROTM )
      ENDIF
*
*   DEFINE GEOMETRY OF RADIAL SET UP FROM FGDR BOS BANK
*
      CALL UGTBNK( 'FGDR' , INDB )
      IF( INDB.LE.0 ) THEN
        WRITE(6,*) ' ** SUBR. UGEOFT **  FGDR BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFVOL( INDB, NFROT, LFROTM )
      ENDIF
*
*       DEFINE ACTIVE VOLUME STRUCTURE for RADIALS
*
      CALL FRGEOM
*
*  PERFORM ORDERING OF VOLUMES FOR SPEEDING SEARCH
*
      CALL GSORD('FRAD',3)
*GDP  CALL GSORD('FPSZ',1)
      CALL GSORD('FWPC',3)
      CALL GSORD('FPLN',3)
      CALL GSORD('FWDT',3)
*
      ELSE

      WRITE(6,*) ' FGEOM CALLED UPGRADE SETUP',LCONFG

*
*   DEFINE GEOMETRY OF UPGRADED PLANAR SET UP FROM FGDQ BOS BANK
*
      CALL UGTBNK( 'FGDQ' , INDB )
      IF( INDB.LE.0 ) THEN
        WRITE(6,*) ' ** SUBR. UGEOFT **  FGDQ BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFVOL( INDB, NFROT, LFROTM )
      ENDIF
*
*       DEFINE ACTIVE VOLUME STRUCTURE for UPGRADED/OLD PLANARS
*
      CALL FOGEOM
      CALL FQGEOM

      ENDIF
*
*  DEFINE SENSITIVE DETECTOR VOLUMES
*
      CALL FDET
*
*      CALL BDROP(IW,'FGMAFGMXFGLMFGMEFGTPFGROFGDPFGDMFGDRFGAMFGAP')
*      CALL BDROP(IW,'FGARFGATFGDR')

   99 RETURN
      END
*CMZ :          15/09/99  16.51.52  by  Girish D. Patel
*-- Author : Girish D. Patel
      SUBROUTINE FOGEOM
*#**********************************************************************
*#                                                                     *
*#    VERSION: 02/03/90   Steve Maxfield                               *
*#                                                                     *
*# PURPOSE: Define Active OLD PLANAR Chamber Geometry                  *
*#                                                                     *
*# CALLED BY : FGEOM                                                   *
*#                                                                     *
*# INPUT : BOS BANK FGAO                                               *
*#                                                                     *
*# OUTPUT :                                                            *
*#                                                                     *
*# AUTHOR : Girish D. Patel                                            *
*#                                                                     *
*# CHANGED BY:                                AT:                      *
*# REASON :                                                            *
*#**********************************************************************
*
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
*
*KEEP,FROTM.
      PARAMETER (LFROTM = 10 )
      COMMON /FROTM/ NFROT(0:LFROTM)
*KEND.
*
*KEEP,H1DETC.
      PARAMETER (NSUBDE=8)
      COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE),
     1                ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE),
     1                SKECUT(NSUBDE+2)
*KEND.
*
      DIMENSION PFPSW(3),ALEN(20)
      DIMENSION PFPSC(3),PFPSB(3)
*
      CALL UGTBNK( 'FGAO', INDB )
      IF(INDB.LE.0) THEN
        WRITE(6,*) ' ** SUBR. FOGEOM ** FGAO BANK NOT FOUND ==> STOP '
        STOP
      ELSE
*        Number of cells across a planar chamber in w
         NCELL = IW(INDB+4)
*        Number of wires in a planar chamber in z
         NZ   = IW(INDB+5)
*        Halfwidth of a planar cell in w, -0.04 to allow for G10 cathode
         PFPSW(1) = RW(INDB+8)/2.0 - 0.04
*        Halflength of a planar cell in y, defined later since they vary
         PFPSW(2) = 0.0
*        Halfdepth of a planar cell in z, wire spacing*no. wires in z
         PFPSW(3) = RW(INDB+6)*4.0/2.0
         CALL UCOPY(RW(INDB+9),ALEN(1),NCELL/2)
      ENDIF
*     Halfwidth of a planar cathode in w
      PFPSC(1) = 0.04
*     Halflength of a planar cathode in y, defined later since they vary
      PFPSC(2) = 0.0
*     Halfdepth of a planar cathode in z, PFPSW(3) + 0.4 (dead area)
      PFPSC(3) = PFPSW(3) + 0.4
*     Halfwidth of a planar pin block in w
      PFPSB(1) = PFPSW(1)
*     Halflength of a planar cathode in y
      PFPSB(2) = 0.5
*     Halfdepth of a planar cathode in z, PFPSW(3) + 0.4 (dead area)
      PFPSB(3) = PFPSW(3) + 0.4
*
*  DEFINE GEOMETRY FOR PLANAR CHAMBERS
*
        XPOS = RW(INDB+7) - RW(INDB+8)
*
        DO 10 I = 1 , NCELL/2
          JJ = I
*         x,y position of centre of a planar cell
          XPOS = XPOS + RW(INDB+8)
          YPOS = 0.0
*         central 'broken' cells are displaced about beam hole
          IF(I.GT.10)  YPOS = RW(INDB + 14+I)
*         Halflength of a planar cell in y
          PFPSW(2) = ALEN(I)/2.0
*         x,y position of centre of a planar cathode
          XPOSS = XPOS - RW(INDB+8)/2.
          YPOSS = 0.0
*         Halflength of a planar cathode in y
          PFPSC(2) = ALEN(I)/2.0 + 1.0
          IF(I.EQ.11) THEN
            PFPSC(2) = ALEN(I)/2.0 + RW(INDB +14+I) + 1.0

          ELSE IF(I.EQ.12.OR.I.EQ.13) THEN
            YLEN =  ( RW(INDB + 14+I  ) + ALEN(I)/2.0 ) -
     &              ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 )
            PFPSC(2) = YLEN/2.0 + 1.0
            YPOSS = ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) + YLEN/2.0

          ELSE IF(I.EQ.14.OR.I.EQ.15) THEN
            JJ = I + 1
            YLEN =  ( RW(INDB + 14+I  ) + ALEN(I)/2.0 ) -
     &              ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 )
            PFPSC(2) = YLEN/2.0 + 1.0
            XPOSS = XPOS + RW(INDB+8)/2.
            YPOSS = ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) + YLEN/2.0

          ELSE IF(I.EQ.16) THEN
            JJ = 14
            PFPSC(2) = ALEN(13)/2.0 + 1.0
            XPOSS = 0.0
            YPOSS = RW(INDB + 14+13)
          ENDIF

* position sensitive volumes
            CALL GSPOSP('FPSW',I,'FPS0',XPOS,YPOS,0.,0,'ONLY',PFPSW,3)
            CALL GSPOSP('FPSW',33-I,'FPS0',-XPOS,-YPOS,0.,0,'ONLY',
     &       PFPSW,3)
* position noryl pin support blocks
            YPOSU = YPOS + ALEN(I)/2.0 + 0.5
            YPOSB = -YPOSU
            IF(I.GT.10) YPOSB = YPOS - ALEN(I)/2.0 - 0.5
            CALL GSPOSP('FPSB',I,'FPS0',XPOS,YPOSU,0.,0,'ONLY',
     &       PFPSB,3)
            CALL GSPOSP('FPSB',I+32,'FPS0',XPOS,YPOSB,0.,0,'ONLY',
     &       PFPSB,3)
            CALL GSPOSP('FPSB',33-I,'FPS0',-XPOS,-YPOSU,0.,0,'ONLY',
     &       PFPSB,3)
            CALL GSPOSP('FPSB',33-I+32,'FPS0',-XPOS,-YPOSB,0.,0,'ONLY',
     &       PFPSB,3)
* position cathode planes
            CALL GSPOSP('FPSC',JJ,'FPS0',XPOSS,YPOSS,0.,0,'ONLY',
     &       PFPSC,3)
            CALL GSPOSP('FPSC',33-JJ,'FPS0',-XPOSS,-YPOSS,0.,0,'ONLY',
     &       PFPSC,3)

*         WRITE(6,*) ' ** FPGEOM **',I,XPOS,YPOS,PFPSW,PFPSC
   10   CONTINUE
*
      IF(ISGRAN(2) .EQ. 1) THEN
*  DIVIDE EACH PLANE CELL IN W (FPSW) INTO 4 IN Z (FPSZ)
         CALL GSDVN('FPSZ','FPSW',NZ,3)
*
*  DEFINE GEOMETRY FOR MEDIUM GRANULARITY OPTION
*
      ELSE IF(ISGRAN(2) .EQ. 3) THEN
*  NO DIVISION IN Z OF THE CELLS, EACH BOX IS THEREFORE NZ TIMES AS WIDE
*
      ELSE
        WRITE(6,*) ' ILLEGAL FORWARD TRACKER GRANULARITY, ISGRAN= ',
     & ISGRAN, ' PROGRAM STOPPED IN FPGEOM '
        STOP
      ENDIF
*
      RETURN
      END
*CMZ :          15/09/99  16.56.13  by  Girish D. Patel
*-- Author :
      SUBROUTINE FQGEOM
*#**********************************************************************
*#                                                                     *
*#    VERSION: 21/07/98   Girish D. Patel                              *
*#                                                                     *
*# PURPOSE: Define NEW Active PLANAR Chamber Geometry                  *
*#                                                                     *
*# CALLED BY : FGEOM                                                   *
*#                                                                     *
*# INPUT : BOS BANK FGAQ                                               *
*#                                                                     *
*# OUTPUT :                                                            *
*#                                                                     *
*# AUTHOR : Girish D. Patel                                            *
*#                                                                     *
*#**********************************************************************
*
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
*
*KEEP,FROTM.
      PARAMETER (LFROTM = 10 )
      COMMON /FROTM/ NFROT(0:LFROTM)
*KEND.
*
*KEEP,H1DETC.
      PARAMETER (NSUBDE=8)
      COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE),
     1                ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE),
     1                SKECUT(NSUBDE+2)
*KEND.
*
      DIMENSION PFQSW(3),ALEN(20)
      DIMENSION PFQSC(3),PFQSB(3)
*
      CALL UGTBNK( 'FGAQ', INDB )
      IF(INDB.LE.0) THEN
        WRITE(6,*) ' ** SUBR. FQGEOM ** FGAQ BANK NOT FOUND ==> STOP '
        STOP
      ELSE
*        Number of cells across a planar chamber in w
         NCELL = IW(INDB+4)
*        Number of wires in a planar chamber in z
         NZ   = IW(INDB+5)
*        Halfwidth of a planar cell in w, -0.04 to allow for G10 cathode
         PFQSW(1) = RW(INDB+8)/2.0 - 0.04
*        Halflength of a planar cell in y, defined later since they vary
         PFQSW(2) = 0.0
*        Halfdepth of a planar cell in z, wire spacing*no. wires in z
         PFQSW(3) = RW(INDB+6)*FLOAT(IW(INDB+5))/2.0
         CALL UCOPY(RW(INDB+9),ALEN(1),NCELL/2)
      ENDIF
*     Halfwidth of a planar cathode in w
      PFQSC(1) = 0.04
*     Halflength of a planar cathode in y, defined later since they vary
      PFQSC(2) = 0.0
*     Halfdepth of a planar cathode in z, PFQSW(3) + 0.3 (dead area)
      PFQSC(3) = PFQSW(3) + 0.3
*     Halfwidth of a planar pin block in w
      PFQSB(1) = PFQSW(1)
*     Halflength of a planar cathode in y
      PFQSB(2) = 0.5
*     Halfdepth of a planar cathode in z, PFQSW(3) + 0.3 (dead area)
      PFQSB(3) = PFQSW(3) + 0.3
*
*  DEFINE GEOMETRY FOR PLANAR CHAMBERS
*
        XPOS = RW(INDB+7) - RW(INDB+8)
*
        DO 10 I = 1 , NCELL/2
          JJ = I
*         x,y position of centre of a planar cell
          XPOS = XPOS + RW(INDB+8)
          YPOS = 0.0
*         central 'broken' cells are displaced about beam hole
          IF(I.GT.8)  YPOS = RW(INDB + 14+I)
*         Halflength of a planar cell in y
          PFQSW(2) = ALEN(I)/2.0
*         x,y position of centre of a planar cathode
          XPOSS = XPOS - RW(INDB+8)/2.
          YPOSS = 0.0
*         Halflength of a planar cathode in y
          PFQSC(2) = ALEN(I)/2.0 + 1.0
          IF(I.EQ.9) THEN
            PFQSC(2) = ALEN(I)/2.0 + RW(INDB +14+I) + 1.0

          ELSE IF(I.EQ.10.OR.I.EQ.11) THEN
            YLEN =  ( RW(INDB + 14+I  ) + ALEN(I)/2.0 ) -
     &              ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 )
            PFQSC(2) = YLEN/2.0 + 1.0
            YPOSS = ( RW(INDB + 14+I-1) - ALEN(I-1)/2.0 ) + YLEN/2.0

          ELSE IF(I.EQ.12.OR.I.EQ.13) THEN
            JJ = I + 1
            YLEN =  ( RW(INDB + 14+I  ) + ALEN(I)/2.0 ) -
     &              ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 )
            PFQSC(2) = YLEN/2.0 + 1.0
            XPOSS = XPOS + RW(INDB+8)/2.
            YPOSS = ( RW(INDB + 14+I+1) - ALEN(I+1)/2.0 ) + YLEN/2.0

          ELSE IF(I.EQ.14) THEN
            JJ = 12
            PFQSC(2) = ALEN(11)/2.0 + 1.0
            XPOSS = 0.0
            YPOSS = RW(INDB + 14+11)
          ENDIF

* position sensitive volumes
            CALL GSPOSP('FQSW',I,'FQS0',XPOS,YPOS,0.,0,'ONLY',PFQSW,3)
            CALL GSPOSP('FQSW',29-I,'FQS0',-XPOS,-YPOS,0.,0,'ONLY',
     &       PFQSW,3)
* position noryl pin support blocks
            YPOSU = YPOS + ALEN(I)/2.0 + 0.5
            YPOSB = -YPOSU
            IF(I.GT.8) YPOSB = YPOS - ALEN(I)/2.0 - 0.5
            CALL GSPOSP('FQSB',I,'FQS0',XPOS,YPOSU,0.,0,'ONLY',
     &       PFQSB,3)
            CALL GSPOSP('FQSB',I+28,'FQS0',XPOS,YPOSB,0.,0,'ONLY',
     &       PFQSB,3)
            CALL GSPOSP('FQSB',29-I,'FQS0',-XPOS,-YPOSU,0.,0,'ONLY',
     &       PFQSB,3)
            CALL GSPOSP('FQSB',29-I+28,'FQS0',-XPOS,-YPOSB,0.,0,'ONLY',
     &       PFQSB,3)
* position cathode planes
            CALL GSPOSP('FQSC',JJ,'FQS0',XPOSS,YPOSS,0.,0,'ONLY',
     &       PFQSC,3)
            CALL GSPOSP('FQSC',29-JJ,'FQS0',-XPOSS,-YPOSS,0.,0,'ONLY',
     &       PFQSC,3)

c         WRITE(6,'(A13,I3,5F8.2)') ' **FQGEOM W**',
c     &            I,XPOS,YPOS,PFQSW
c         WRITE(6,'(A13,I3,6F8.2)') ' **FQGEOM B**',
c     &            I,XPOS,YPOSU,YPOSB,PFQSB
c         WRITE(6,'(A13,I3,5F8.2)') ' **FQGEOM C**',
c     &            I,XPOSS,YPOSS,PFQSC
   10   CONTINUE
*
      IF(ISGRAN(2) .EQ. 1) THEN
*  DIVIDE EACH PLANE CELL IN W (FPSW) INTO 4 IN Z (FPSZ)
         CALL GSDVN('FQSZ','FQSW',NZ,3)
*
*  DEFINE GEOMETRY FOR MEDIUM GRANULARITY OPTION
*
      ELSE IF(ISGRAN(2) .EQ. 3) THEN
*  NO DIVISION IN Z OF THE CELLS, EACH BOX IS THEREFORE NZ TIMES AS WIDE
*
      ELSE
        WRITE(6,*) ' ILLEGAL FORWARD TRACKER GRANULARITY, ISGRAN= ',
     & ISGRAN, ' PROGRAM STOPPED IN FQGEOM '
        STOP
      ENDIF
*
      RETURN
      END
*CMZ :          15/09/99  17.09.26  by  Girish D. Patel
*CMZU:  2.13/00 09/12/92  16.54.33  by  Girish D. Patel
*CMZ :  2.00/00 10/02/91  09.09.28  by  Stephan Egli
*CMZ :  1.08/02 06/02/91  13.38.38  by  Stephan Egli
*-- Author :
      SUBROUTINE FDET
*#**********************************************************************
*#                                                                     *
*#    VERSION: 02/03/90   Steve Maxfield                               *
*#                                                                     *
*# PURPOSE:  Sensitive Volume and Hit structure definition             *
*#                                                                     *
*# CALLED BY : FGEOM                                                   *
*#                                                                     *
*# INPUT :                                                             *
*#                                                                     *
*# OUTPUT :  GEANT Hit and Volume structures                           *
*#                                                                     *
*# AUTHOR : Steve Maxfield, Girish D. Patel                            *
*#                                                                     *
*# CHANGED BY: GDP, PR        AT: 9/5/89                               *
*# REASON :  * MODIFIED FOR APOLLO                                     *
*# Changed by: S.Egli at 1.4.90: all GSDETH calls removed.             *
*# CHANGED BY: G. D. Patel    AT: 4/12/92                              *
*# REASON :  * Planar geometry structure modified, FPSW => FPSZ        *
*#**********************************************************************
*
*
*KEEP,GCFLAG.
      COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN
     +        ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2)
      COMMON/GCFLAX/BATCH, NOLOG
      LOGICAL BATCH, NOLOG
C
      INTEGER       IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN
     +        ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM
C
*KEND.
*
*KEEP,H1DETC.
      PARAMETER (NSUBDE=8)
      COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE),
     1                ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE),
     1                SKECUT(NSUBDE+2)
*KEEP,H1OSGO.
      COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12)
*KEND.
*
      INTEGER     NWHI
      INTEGER     NWDI
*
      DATA        NWHI          /100/
      DATA        NWDI          /0/
*
*  ALLOCATE SENSITIVE DETECTOR VOLUMES TO SETS AND DEFINE HIT VARIABLES
*
*-----------------------------------------------------------------------
      IF(LCONFG.LT.10) THEN
*                   RADIALS....
      I2 = 201
      IF     (ISGRAN(2) .EQ. 1) THEN
         CALL GSDETV('FRSD','FRSZ',I2,NWHI,NWDI,ISETR,IDETR)
      ELSE IF(ISGRAN(2) .EQ. 3) THEN
         CALL GSDETV('FRSD','FRS0',I2,NWHI,NWDI,ISETR,IDETR)
      ELSE
         WRITE(6,*)' ** FDET **  ERROR - GRANULARITY UNDEFINED, STOP'
         STOP
      ENDIF
      IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETR = ',ISETR
     &,' IDETR = ',IDETR
*
*                   PLANARS....
      I2 = 202
      IF     (ISGRAN(2) .EQ. 1 ) THEN
         CALL GSDETV('FPSD','FPSZ',I2,NWHI,NWDI,ISETP,IDETP)
      ELSE IF(ISGRAN(2) .EQ. 3) THEN
         CALL GSDETV('FPSD','FPSW',I2,NWHI,NWDI,ISETP,IDETP)
      ELSE
         WRITE(6,*)' ** FDET **  ERROR - GRANULARITY UNDEFINED, STOP'
         STOP
      ENDIF
      IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP
     &,' IDETP = ',IDETP
*                   MWPCS....
      I2=203
      CALL GSDETV('FMWP','FMAC',I2,NWHI,NWDI,ISETM,IDETM)
*     CALL GSDETH('FMWP','FMAC',NHITSN,NAMESH,NBITSH,ORIG,FACT)
      IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETM = ',ISETM
     &,' IDETP = ',IDETP
*
*                   TR...
      I2 = 204
      CALL GSDETV('FTSD','FTRD',I2,NWHI,NWDI,ISETT,IDETT)
*     CALL GSDETH('FTSD','FTRD',NHITSN,NAMESH,NBITSH,ORIG,FACT)
      IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETT = ',ISETT
     &,' IDETT = ',IDETT
*
*-----------------------------------------------------------------------
      ELSE
*                   OLD PLANARS....
      I2 = 202
      IF     (ISGRAN(2) .EQ. 1 ) THEN
         CALL GSDETV('FPSD','FPSZ',I2,NWHI,NWDI,ISETP,IDETP)
      ELSE IF(ISGRAN(2) .EQ. 3) THEN
         CALL GSDETV('FPSD','FPSW',I2,NWHI,NWDI,ISETP,IDETP)
      ELSE
         WRITE(6,*)' ** FDET **  ERROR - GRANULARITY UNDEFINED, STOP'
         STOP
      ENDIF
      IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP
     &,' IDETP = ',IDETP


*                   NEW PLANARS....
      I2 = 203
      IF     (ISGRAN(2) .EQ. 1 ) THEN
         CALL GSDETV('FQSD','FQSZ',I2,NWHI,NWDI,ISETP,IDETP)
      ELSE IF(ISGRAN(2) .EQ. 3) THEN
         CALL GSDETV('FQSD','FQSW',I2,NWHI,NWDI,ISETP,IDETP)
      ELSE
         WRITE(6,*)' ** FDET **  ERROR - GRANULARITY UNDEFINED, STOP'
         STOP
      ENDIF
      IF(ISWIT(2).EQ.1) WRITE(6,*) ' ** FDET ** ISETP = ',ISETP
     &,' IDETP = ',IDETP

*-----------------------------------------------------------------------
      ENDIF
      RETURN
      END
*CMZ :          16/09/99  15.28.50  by  Girish D. Patel
*CMZU:  2.13/00 09/12/92  16.54.33  by  Girish D. Patel
*CMZ :  2.00/00 10/02/91  09.09.28  by  Stephan Egli
*CMZ :  1.08/02 06/02/91  13.38.39  by  Stephan Egli
*-- Author :
      SUBROUTINE FPHIT
*#**********************************************************************
*#                                                                     *
*#    VERSION: 02/03/90   Steve Maxfield                               *
*#                                                                     *
*# PURPOSE:  fill PLANAR CHAMBERS response and GEANT HIT banks         *
*#                                                                     *
*# CALLED BY :     FSTEP                                               *
*#                                                                     *
*# INPUT :       GEANT track data                                      *
*#                                                                     *
*# OUTPUT :     FRPF bank OR FRPT bank                                 *
*#              ====         ====                                      *
*# AUTHOR :   Steve Maxfield                                           *
*#                                                                     *
*# CHANGED BY:  S. J MAXFIELD AT:   26/02/90                           *
*# REASON :  Bank formats completely changed + Coarse Granularity      *
*#           Convert to new reduced format(see below)                  *
*#           If Granularity flag = 1 (fine) FRPT bank is produced      *
*#           If granularity is 2 (coarse) reduced format FRPF bank is  *
*#           produced instead.                                         *
*#        +  NB. single FRPT (tabular) bank with fine granularity.     *
*#        +  Convert to new cell numbering scheme.                     *
*# CHANGED BY S. EGLI at 10.3.90                                       *
*# Reason:  exchanged position of partial cell number and ITRHIS in    *
*#          order to have the ITRHIS word in the "standard" location   *
*#          PDG particle code introduced                               *
*# CHANGED BY: G. D. Patel    AT:    4/12/92                           *
*# REASON :  Planar geometry change requires NUMBV change for chan.no. *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRPF BANK    2I,(14F,4I)   Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#    BANK FRPF    Forward Planar Response (Fast-form)                 *
*#                 CONTAINS ALL TRACKPOINTS OF ALL TRACKS              *
*#                                                                     *
*#    word#   type     Content                                         *
*#       1       I     NCOL = 18                                       *
*#       2       I     Number of track points                          *
*# ----------------------------------------------------------------    *
*#     Col                                                             *
*#       1       R     X      in                 Attrib                *
*#       2       R     Y      in                 Attrib                *
*#       3       R     Z      in                 Attrib                *
*#       4       R     PX/P   in                 Attrib                *
*#       5       R     PY/P   in                 Attrib                *
*#       6       R     PZ/P   in                 Attrib                *
*#       7       R     P      in                 Attrib                *
*#                                                                     *
*#       8       R     X      out                Attrib                *
*#       9       R     Y      out                Attrib                *
*#      10       R     Z      out                Attrib                *
*#      11       R     PX/P   out                Attrib                *
*#      12       R     PY/P   out                Attrib                *
*#      13       R     PZ/P   out                Attrib                *
*#      14       R     P      out                Attrib                *
*#                                                                     *
*#      15       I     PARTICLE TYPE             Attrib                *
*#      16       I     (Partial) Cell Number     Attrib                *
*#      17       I     TRACKING HISTORY WORD     Attrib                *
*#      18       I     TRACK NUMBER              Reln                  *
*# ----------------------------------------------------------------    *
*#         (GEANT units: cms. GeV)                                     *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRPT BANK    2I,(I,7F,2I)  Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#    BANK FRPT    Forward Planar Response Track-based                 *
*#                 Contains all hits in Planars for all tracks         *
*#                                                                     *
*#    word#   type     Content                                         *
*#       1       I     NCOLS  = 10                                     *
*#       2       I     NROWS  = Number of hits                         *
*# ----------------------------------------------------------------    *
*#     Col                                                             *
*#       1       I     Cell Number               Attrib                *
*#       2       R     Xin                       Attrib                *
*#       3       R     Yin                       Attrib                *
*#       4       R     Zin                       Attrib                *
*#       5       R     Xout                      Attrib                *
*#       6       R     Yout                      Attrib                *
*#       7       R     Zout                      Attrib                *
*#       8       R     Energy Loss (GeV)         Attrib                *
*#       9       I     Tracking History word     Attrib                *
*#      10       I     TRACK NUMBER              Reln                  *
*# ----------------------------------------------------------------    *
*#         (GEANT units: cms. GeV)                                     *
*#**********************************************************************
*
*KEEP,GCKINE.
      COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP
     +      ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD
C
      INTEGER       IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD
      REAL          PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT
C
*KEEP,GCTRAK.
      INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC
     + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY
      REAL  VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP
     + ,SNEXT,SFIELD,TOFG  ,GEKRAT,UPWGHT
      PARAMETER (MAXMEC=30)
      COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC)
     + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG
     + ,STEP  ,SNEXT ,SFIELD,TOFG  ,GEKRAT,UPWGHT,IGNEXT,INWVOL
     + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN
     + ,NLVSAV,ISTORY
C
*KEEP,GCSETS.
      COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20)
C
      INTEGER       IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV
C
*KEEP,H1DETC.
      PARAMETER (NSUBDE=8)
      COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE),
     1                ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE),
     1                SKECUT(NSUBDE+2)
*KEEP,H1OSGO.
      COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12)
*KEEP,OTRHIS.
      COMMON/OTRHIS/ITRHIS
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
      PARAMETER (NCL=18)
      PARAMETER (NCL2=10)
      PARAMETER (NBN=0)
      DIMENSION   IKADD(NCL),BKADD(NCL)
      EQUIVALENCE (IKADD(1),BKADD(1))
      LOGICAL FIRST
      DATA FIRST/.TRUE./
*     Branch according to granularity flag...
      IF(ISGRAN(2) .EQ. 3) THEN
*     Coarse detector geometry create FRPF banks
      IF(FIRST)THEN
        FIRST=.FALSE.
        CALL BKFMT ('FRPF','2I,(14F,4I)')
      ENDIF
*
      IF(INWVOL.EQ.1)               THEN
*        Entrance to volume. Store first 7-vector...
         DO 10 I=1,7
10       BKADD(I)  = VECT(I)
      ELSEIF(INWVOL.EQ.2.OR.ISTOP.GT.0) THEN
*        Exit volume at boundary or particle stops...
         DO 11 I=1,7
11       BKADD(I+7)  = VECT(I)
         IKADD(15)   = IGEAPD(IPART)

         IF(LCONFG.LT.10) THEN
*        use word 16 to keep the (partial) cell number...
*     Determine Cell number - drift cells are numbered
*     as follows:-
*
*      cell number determined by supermodule number  (1-3)      NUMBV(1)
*                                orientation number  (1-3)      NUMBV(2)
*                                w-coordinate        (1-32)     NUMBV(3)
*      ...the cell number will be completed when the z plane number (0 -
*         is added in the Digitisation step
*
         IKADD(16) = 384 * (NUMBV(1) -1)
     .           +   128 * (NUMBV(2)-1)
     .           +     4 * (NUMBV(3)-1)
         ELSE
*
*      cell number determined by orientation number  (1-3)      NUMBV(1)
*                                w-coordinate        (1-32)     NUMBV(2)
*      ...the cell number will be completed when the z plane number (0 -
*         is added in the Digitisation step
*
         IKADD(16) = 128 * (NUMBV(1)-1)
     .           +     4 * (NUMBV(2)-1)
         ENDIF

         IKADD(17)   = ITRHIS
         IKADD(18) = ITRA
*        Track segment now complete. Add row to table...
         KND=IADROW('FRPF',NBN,NCL,BKADD)
         IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRPF')
      ENDIF
      ELSEIF(ISGRAN(2) .EQ. 1) THEN
*     Fine detector geometry - create FRPT banks...
      IF(FIRST)THEN
        FIRST=.FALSE.
        CALL BKFMT ('FRPT','2I,(I,7F,2I)')
      ENDIF
*
       IF(INWVOL.EQ.1) THEN
         XIN    = VECT(1)
         YIN    = VECT(2)
         ZIN    = VECT(3)
         ENLOSS = 0.0
*
       ELSEIF (INWVOL.EQ.2) THEN
         XOUT    = VECT(1)
         YOUT    = VECT(2)
         ZOUT    = VECT(3)
*       Add last bit of Energy
         ENLOSS=ENLOSS+DESTEP
*        Add information to the bank
*     Determine Cell number - drift cells are numbered
*     as follows:-
*
*      cell number determined by supermodule number  (1-3)      NUMBV(1)
*                                orientation number  (1-3)      NUMBV(2)
*                                w-coordinate        (1-32)     NUMBV(3)
*                                z-plane             (1-4)      NUMBV(4)
         IKADD( 1) =  384 * (NUMBV(1)-1)
     .           +   128 * (NUMBV(2)-1)
     .           +     4 * (NUMBV(3)-1)
     .           +         (NUMBV(4)-1)
         BKADD( 2) = XIN
         BKADD( 3) = YIN
         BKADD( 4) = ZIN
         BKADD( 5) = XOUT
         BKADD( 6) = YOUT
         BKADD( 7) = ZOUT
         BKADD( 8) = ENLOSS
         IKADD( 9) = ITRHIS
         IKADD(10) = ITRA
*
         KND=IADROW('FRPT',NBN,NCL2,BKADD)
         IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRPT')
      ENDIF
*
* ADD UP ENERGY LOSS
*
      ENLOSS=ENLOSS+DESTEP
      ELSE
*     Undefined geometry - STOP
        WRITE(6,*) ' FPHIT - Undefined FTD geometry!!'
        STOP
      ENDIF
      RETURN
      END

*CMZ :          16/04/99  15.43.49  by  Girish D. Patel
*-- Author :    Girish D. Patel   10/11/98
      SUBROUTINE FQHIT
*#**********************************************************************
*#                                                                     *
*#    VERSION: 22/07/98   Steve Maxfield                               *
*#                                                                     *
*# PURPOSE:  fill NEW PLANAR CHAMBERS response and GEANT HIT banks     *
*#                                                                     *
*# CALLED BY :     GEDEPO                                              *
*#                                                                     *
*# INPUT :       GEANT track data                                      *
*#                                                                     *
*# OUTPUT :     FRQF bank OR FRQT bank                                 *
*#              ====         ====                                      *
*# AUTHOR :   Steve Maxfield                                           *
*#                                                                     *
*# CHANGED BY:                                                         *
*# REASON :                                                            *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRQF BANK    2I,(14F,4I)   Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#    BANK FRQF    Forward New Planar Response (Fast-form)             *
*#                 CONTAINS ALL TRACKPOINTS OF ALL TRACKS              *
*#                                                                     *
*#    word#   type     Content                                         *
*#       1       I     NCOL = 18                                       *
*#       2       I     Number of track points                          *
*# ----------------------------------------------------------------    *
*#     Col                                                             *
*#       1       R     X      in                 Attrib                *
*#       2       R     Y      in                 Attrib                *
*#       3       R     Z      in                 Attrib                *
*#       4       R     PX/P   in                 Attrib                *
*#       5       R     PY/P   in                 Attrib                *
*#       6       R     PZ/P   in                 Attrib                *
*#       7       R     P      in                 Attrib                *
*#                                                                     *
*#       8       R     X      out                Attrib                *
*#       9       R     Y      out                Attrib                *
*#      10       R     Z      out                Attrib                *
*#      11       R     PX/P   out                Attrib                *
*#      12       R     PY/P   out                Attrib                *
*#      13       R     PZ/P   out                Attrib                *
*#      14       R     P      out                Attrib                *
*#                                                                     *
*#      15       I     PARTICLE TYPE             Attrib                *
*#      16       I     (Partial) Cell Number     Attrib                *
*#      17       I     TRACKING HISTORY WORD     Attrib                *
*#      18       I     TRACK NUMBER              Reln                  *
*# ----------------------------------------------------------------    *
*#         (GEANT units: cms. GeV)                                     *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRQT BANK    2I,(I,7F,2I)  Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#    BANK FRQT    Forward New Planar Response Track-based             *
*#                 Contains all hits in Planars for all tracks         *
*#                                                                     *
*#    word#   type     Content                                         *
*#       1       I     NCOLS  = 10                                     *
*#       2       I     NROWS  = Number of hits                         *
*# ----------------------------------------------------------------    *
*#     Col                                                             *
*#       1       I     Cell Number               Attrib                *
*#       2       R     Xin                       Attrib                *
*#       3       R     Yin                       Attrib                *
*#       4       R     Zin                       Attrib                *
*#       5       R     Xout                      Attrib                *
*#       6       R     Yout                      Attrib                *
*#       7       R     Zout                      Attrib                *
*#       8       R     Energy Loss (GeV)         Attrib                *
*#       9       I     Tracking History word     Attrib                *
*#      10       I     TRACK NUMBER              Reln                  *
*# ----------------------------------------------------------------    *
*#         (GEANT units: cms. GeV)                                     *
*#**********************************************************************
*
*KEEP,GCKINE.
      COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP
     +      ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD
C
      INTEGER       IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD
      REAL          PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT
C
*KEEP,GCTRAK.
      INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC
     + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY
      REAL  VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP
     + ,SNEXT,SFIELD,TOFG  ,GEKRAT,UPWGHT
      PARAMETER (MAXMEC=30)
      COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC)
     + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG
     + ,STEP  ,SNEXT ,SFIELD,TOFG  ,GEKRAT,UPWGHT,IGNEXT,INWVOL
     + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN
     + ,NLVSAV,ISTORY
C
*KEEP,GCSETS.
      COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20)
C
      INTEGER       IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV
C
*KEEP,H1DETC.
      PARAMETER (NSUBDE=8)
      COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE),
     1                ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE),
     1                SKECUT(NSUBDE+2)
*KEEP,OTRHIS.
      COMMON/OTRHIS/ITRHIS
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

      PARAMETER (NCL=18)
      PARAMETER (NCL2=10)
      PARAMETER (NBN=0)
      DIMENSION   IKADD(NCL),BKADD(NCL)
      EQUIVALENCE (IKADD(1),BKADD(1))
      LOGICAL FIRST
      DATA FIRST/.TRUE./
*     Branch according to granularity flag...
      IF(ISGRAN(2) .EQ. 3) THEN
*     Coarse detector geometry create FRPF banks
      IF(FIRST)THEN
        FIRST=.FALSE.
        CALL BKFMT ('FRQF','2I,(14F,4I)')
      ENDIF
*
      IF(INWVOL.EQ.1)               THEN
*        Entrance to volume. Store first 7-vector...
         DO 10 I=1,7
10       BKADD(I)  = VECT(I)
      ELSEIF(INWVOL.EQ.2.OR.ISTOP.GT.0) THEN
*        Exit volume at boundary or particle stops...
         DO 11 I=1,7
11       BKADD(I+7)  = VECT(I)
         IKADD(15)   = IGEAPD(IPART)
*        use word 17 to keep the (partial) cell number...
*     Determine Cell number - drift cells are numbered
*     as follows:-
*
*      cell number determined by supermodule number  (1-3)      NUMBV(1)
*                                w-coordinate        (1-28)     NUMBV(2)
*      ...the cell number will be completed when the z plane number (0 -
*         is added in the Digitisation step
*
c         write(6,*) 'FQHIT',(numbv(I),I=1,3)


         IKADD(16) = 224 * (NUMBV(1)-1)
     .           +     8 * (NUMBV(2)-1)
         IKADD(17)   = ITRHIS
         IKADD(18) = ITRA
*        Track segment now complete. Add row to table...
         KND=IADROW('FRQF',NBN,NCL,BKADD)
         IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRQF')
      ENDIF

      ELSEIF(ISGRAN(2) .EQ. 1) THEN
*     Fine detector geometry - create FRPT banks...
      IF(FIRST)THEN
        FIRST=.FALSE.
        CALL BKFMT ('FRQT','2I,(I,7F,2I)')
      ENDIF
*
       IF(INWVOL.EQ.1) THEN
         XIN    = VECT(1)
         YIN    = VECT(2)
         ZIN    = VECT(3)
         ENLOSS = 0.0
*
       ELSEIF (INWVOL.EQ.2) THEN
         XOUT    = VECT(1)
         YOUT    = VECT(2)
         ZOUT    = VECT(3)
*       Add last bit of Energy
         ENLOSS=ENLOSS+DESTEP
*        Add information to the bank
*     Determine Cell number - drift cells are numbered
*     as follows:-
*
*      cell number determined by supermodule number  (1-3)      NUMBV(1)
*                                orientation number  (1-1)      NUMBV(2)
*                                w-coordinate        (1-28)     NUMBV(3)
*                                z-plane             (1-8)      NUMBV(4)
         IKADD( 1) =  224 * (NUMBV(1)-1)
     .           +      8 * (NUMBV(3)-1)
     .           +          (NUMBV(4)-1)
         BKADD( 2) = XIN
         BKADD( 3) = YIN
         BKADD( 4) = ZIN
         BKADD( 5) = XOUT
         BKADD( 6) = YOUT
         BKADD( 7) = ZOUT
         BKADD( 8) = ENLOSS
         IKADD( 9) = ITRHIS
         IKADD(10) = ITRA
*
         KND=IADROW('FRQT',NBN,NCL2,BKADD)
         IF(IW(KND+2).EQ.1)CALL BLIST(IW,'E+','FRQT')
      ENDIF
*
* ADD UP ENERGY LOSS
*
      ENLOSS=ENLOSS+DESTEP
      ELSE
*     Undefined geometry - STOP
        WRITE(6,*) ' FQHIT - Undefined FTD geometry!!'
        STOP
      ENDIF
      RETURN
      END
*CMZU:          03/08/98  13.56.29  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FDQSME(DRIFT,IFLAG0,IFLAG1,IFLAG2,DSMEA)
*#****************************************************************
*#                                                               *
*#    PURPOSE:  Compute Smeared drift length (in new planars)    *
*#                                                               *
*#    INPUT:  DRIFT  -  drift length to wire in cms              *
*#                      end of wire in units of total wire length*
*#                      IFLAG - FLAG containing hit "quality" inf*
*#                                                               *
*#       OUTPUT: DSMEA   Smeared drift time                      *
*#                       Depends on IFLAG                        *
*#                                                               *
*#****************************************************************
*#                                                               *
*# CHANGED BY:                AT:                                *
*#                                                               *
*# REASON :                                                      *
*#                                                               *
*#****************************************************************

*KEEP,FQDGPR.
      COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3
     &,               DELCHG,DQUANT,FADBIN
*KEEP,FQDGST.
      LOGICAL LSMEAR,LNOISE
      COMMON /FQDGST/ LSMEAR,LNOISE
*KEND.

*#****************************************************************

      IF (.NOT.LSMEAR) THEN
         DSMEA = DRIFT
         RETURN
      ENDIF

* Resolution vs. drift distance curve
      DELTA = SQRT(ERRD0 + DRIFT*ERRD1 + EXP(-ERRD3*DRIFT)*ERRD2)

* Scale up the resolution for close previous hits (arbitrary)
      ISEPL = IFLAG0/256
      IF (ISEPL.LT.10 .AND. ISEPL.GT.0) THEN
         IPEAK  = IFLAG0 - 256*ISEPL
         IPLAST = IFLAG1/256
* Just in case ...
         IF (IPEAK.EQ.0) IPEAK = 1
         FRAC = 10.*IPLAST/FLOAT(ISEPL*IPEAK)
         IF (FRAC.GT.1.) DELTA = DELTA*FRAC
      ENDIF

* Error can't be bigger than 2-track resolution
      IF (DELTA.GT.TTSEP1) DELTA = TTSEP1

* Allow -ve fluctuations (across T0 boundary)
      CALL H1NORR(GAUSS)
      DSMEA = DRIFT + DELTA*GAUSS

      RETURN
      END
*CMZU:          03/08/98  13.56.29  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FQDIGI
*#*****************************************************************
*#                                                                *
*#    PURPOSE: Digitisation of hits in New Forward Planars.       *
*#                                                                *
*#    CALLED BY: H1DIGI                                           *
*#                                                                *
*#*****************************************************************

*KEEP,FQDGDB.
      COMMON /FQDGDB/ IFQDEB(5)
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEEP,BOSMDL.
C     ------BOSMDL
      LOGICAL       BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT
      COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT,
     +              LCCRUN,NCCRUN,NEVENT,
     +              IHA,IBS,IDB,IDATEL,LUP,ISN,JSN
      SAVE  /BOSMDL/
C     ------
*KEND.

      LOGICAL IQDEB

*#****************************************************************

* Check debug range
      IQDEB =        IFQDEB(1) .EQ. 1
     +        .AND.  NEVENT .LE. IFQDEB(5)
     +        .AND.  NEVENT .GE. IFQDEB(4)

* Check for existence of FRQF banks. If they exist then
* create FRQH bank from them directly
      INFRQF = NLINK('FRQF',0)
      IF (IW(INFRQF).GT.0) THEN
* Generate noise bank ... (not used yet)
*        CALL FRQNCR
         CALL FRQHCC
         IF (IQDEB) THEN
            CALL  FPFRQF
            CALL  FPFRQH
         ENDIF
      ELSE
* Create FRPH bank from FRPT banks ...
* Generate noise bank ... (not used yet)
*        CALL FRQNCR
         CALL FRQHCR
         IF (IQDEB) THEN
            CALL FPFRQT
            CALL FPFRQH
         ENDIF
      ENDIF

* Now digitise the hits creating FRQE bank
      CALL FRQECR
      CALL FRQXCR
      IF (IQDEB) CALL FPFRQE
      IF (IQDEB) CALL FPFRQX

* Now drop the intermediate HIT bank
      CALL BDROP(IW,'FRQH')

      RETURN
      END
*CMZ :          20/01/99  14.09.57  by  Girish D. Patel
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FQDRF(XP,YP,ZP,ICELL,FDRIFT,IFSGN)
*#**********************************************************************
*#                                                                     *
*# PURPOSE: COMPUTE DRIFT DISTANCE OF HIT IN NEW PLANARS AT            *
*#          XP, YP, ZP (mean of track entry and exit points for now )  *
*#                                                                     *
*# CALLED BY : FRQHCC, FRQHCR                                          *
*#                                                                     *
*# INPUT : BOS BANK  FGAQ, XP,YP,ZP (cms)                              *
*#                                                                     *
*# OUTPUT : FDRIFT  (cms)     if in cell ELSE -2000.                   *
*#          IFSGN      drift sign 0/1                                  *
*#                                                                     *
*# IFSGN changed so that 0 / 1 = positive / negative drift to agree    *
*# with the convention used in reconstruction.                         *
*# IFSGN is -1 if the track is outside the sensitive volume            *
*#                                                                     *
*#**********************************************************************

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

      DIMENSION IPKMOD(0:671)
      DIMENSION IPKWCL(0:671)
      DIMENSION IPKZPL(0:671)

      DIMENSION PSTART(0:2), STAGGE(0:2)
      DIMENSION PAOFF(0:27), PALEN(0:27)
      PARAMETER(TWOPI=6.283185)

      LOGICAL FIRST
      DATA FIRST/.TRUE./

*#**********************************************************************

* Initialise drift distance to large negative number
      FDRIFT  =  -2000.
      IFSGN   = 0

* Unpack FGAQ bank if first call...
      IF (FIRST) THEN
         DO 1 JJ=0,671
            KMOD = JJ/224
            KWCL = (JJ-KMOD*224)/8
            KZPL = (JJ-KMOD*224-KWCL*8)
            IPKMOD(JJ) = KMOD
            IPKWCL(JJ) = KWCL
            IPKZPL(JJ) = KZPL
 1       CONTINUE
* Access FGAQ bank
         CALL UGTBNK('FGAQ',INFGAQ)
         IF (INFGAQ.LE.0) THEN
            WRITE(6,*)' ***FQDRF  >> FGAQ BANK NOT FOUND'
            RETURN
         ENDIF
* Get basic planar parameters ...
         NMOD   = IW(INFGAQ+3)
         NPLANE = IW(INFGAQ+5)
         ZSEP   = RW(INFGAQ+6)
         WZER   = RW(INFGAQ+7)
         WSEP   = RW(INFGAQ+8)

* Half-lengths of wires ...
         KIND = INFGAQ + 8
         DO 6 JL=1,14
            PALEN(JL-1) = RW(KIND+JL)/2.0
            PALEN(28-JL)= RW(KIND+JL)/2.0
 6       CONTINUE
* Offsets of wire centres ...
         KIND = INFGAQ + 22
         DO 7 JO=1,6
            PAOFF(7+JO)  =   RW(KIND+JO)
            PAOFF(13+JO) = - RW(KIND+JO)
 7       CONTINUE
         DO 8 JO=0,7
            PAOFF(JO)    =  0.0
 8       CONTINUE
         DO 9 JO=20,27
            PAOFF(JO)    =  0.0
 9       CONTINUE

         KIND = INFGAQ + IW(INFGAQ+1) + 1
         DO 2 KMOD=0,NMOD-1
            PSTART(KMOD)  = RW(KIND+4)
            STAGGE(KMOD)  = RW(KIND+5)
            KIND = KIND + IW(KIND+1) + 1
 2       CONTINUE

         CALL UGTRUN('FDQR',INFDQR)
         IF (INFDQR.LE.0) THEN
            WRITE(6,*)' ***FQDRF >> FDQR BANK NOT FOUND'
            RETURN
         ENDIF
* Get TAN of Lorenz angle
         TLOREN = TAN(RW(INFDQR+23)*TWOPI/360.)

         FIRST = .FALSE.
      ENDIF
* End unpacking

* Unpack the module number and the celnum in W
      KPMOD = IPKMOD(ICELL)
      KWCL  = IPKWCL(ICELL)
      KZPL  = IPKZPL(ICELL)

* Determine the W-coordinate of the wire in this cell
      IF (KWCL.LE.13) THEN
         WWIRE = WZER +  KWCL   *WSEP + STAGGE(KPMOD)*( (-1)**KZPL )
      ELSE
         WWIRE = WZER + (KWCL-6)*WSEP + STAGGE(KPMOD)*( (-1)**KZPL )
      ENDIF

* Rotate x,y coordinates of hit into W,V frame:
* W is the drift coordinate and V the coordinate along the wires.
      WHIT   =  XP*COS(PSTART(KPMOD)) + YP*SIN(PSTART(KPMOD))
      VTRUE  = -XP*SIN(PSTART(KPMOD)) + YP*COS(PSTART(KPMOD))

      FDRIFT = WHIT - WWIRE
      VCORR  = VTRUE - FDRIFT*TLOREN

      IF (FDRIFT.LT.0) IFSGN = 1

* V at 'top' and 'bottom' of cell
      PVMIN  = PAOFF(KWCL) - PALEN(KWCL)
      PVMAX  = PAOFF(KWCL) + PALEN(KWCL)

* Check original V (for interpolated hits in coarse granularity,
* the track can leave and re-enter the drift volume!!)
      IF (VTRUE.LT.PVMIN  .OR. VTRUE.GT.PVMAX) IFSGN = -1

* Check if electrons reach wire
      IF (VCORR.LT.PVMIN  .OR. VCORR.GT.PVMAX) IFSGN = -1

      FDRIFT = ABS(FDRIFT)

      RETURN
      END
*CMZ :          20/01/99  14.46.40  by  Girish D. Patel
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FQIDIG
*******************************************************************
*#                                                                *
*#    PURPOSE: Initialise COMMONS for Forward Planar digitisation *
*#                                                                *
*#*****************************************************************
*#                                                                *
*# CHANGED BY:                AT:                                 *
*#                                                                *
*# REASON :                                                       *
*#                                                                *
*#*****************************************************************

*KEEP,FQDGPR.
      COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3
     &,               DELCHG,DQUANT,FADBIN
*KEEP,FQDGST.
      LOGICAL LSMEAR,LNOISE
      COMMON /FQDGST/ LSMEAR,LNOISE
*KEEP,FQDGDB.
      COMMON /FQDGDB/ IFQDEB(5)
*KEEP,FQDGDG.
      COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT
*KEEP,FQDGEF.
      COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5)
     &,               PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5)
*KEEP,FQMAXN.
* Maximum number of noise hits for new planars
      PARAMETER (MXNHTQ=5)
*KEEP,FQTRNP.
* Forward new planar track-related noise + shifted data parameters
      PARAMETER (MAXSGQ=5)
      LOGICAL LFDQX
      COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ)
     &,               QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI
     &,               ANGNOI,PRBNOI,OFFNOI
*KEND.

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

      DIMENSION P1(MXNHTQ),P2(MXNHTQ),D(MAXSGQ-1),PD(MAXSGQ-2)

*------------------------------------------------------------------

*
* Initialisation - access parameter banks
*

      CALL UGTRUN('FDQR',INFDQR)
      IF (INFDQR.LE.0) THEN
         WRITE(6,*) ' ***FQIDIG >> FDQR BANK NOT FOUND'
         CALL H1STOP
      ENDIF
      IF (IW(INFDQR+3).LT.980801) THEN
         WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQR BANK'
         CALL H1STOP
      ENDIF

      LSMEAR    = (IW(INFDQR + 4).NE.0)
      LNOISE    = (IW(INFDQR + 5).NE.0)
      IFQDEB(1) = IW(INFDQR +  6)
      IFQDEB(2) = IW(INFDQR +  7)
      IFQDEB(3) = IW(INFDQR +  8)
      IFQDEB(4) = IW(INFDQR +  9)
      IFQDEB(5) = IW(INFDQR + 10)
      QFAC      = RW(INFDQR + 11)
      IQSAT     = IW(INFDQR + 12)
      DRFVEL    = RW(INFDQR + 13)
      TTSEP1    = RW(INFDQR + 14)
      TTSEP2    = RW(INFDQR + 15)
      MAXINT    = IW(INFDQR + 16)
      ERRD0     = RW(INFDQR + 17)
      ERRD1     = RW(INFDQR + 18)
      ERRD2     = RW(INFDQR + 19)
      ERRD3     = RW(INFDQR + 20)
      DELCHG    = RW(INFDQR + 21)
      DQUANT    = RW(INFDQR + 22)

      EFFQ(0,0) = RW(INFDQR + 24)
      EFFQ(1,0) = RW(INFDQR + 25)
      EFFQ(2,0) = RW(INFDQR + 26)
      EFFQ(3,0) = RW(INFDQR + 27)
      EFFQ(4,0) = RW(INFDQR + 28)
      EFFQ(5,0) = RW(INFDQR + 29)
      EFFQ(6,0) = RW(INFDQR + 30)
      EFFQ(7,0) = RW(INFDQR + 31)

      EFFQ8(0)  = RW(INFDQR + 32)
      EFFQ8(1)  = RW(INFDQR + 33)
      EFFQ8(2)  = RW(INFDQR + 34)

      P1(1)     = RW(INFDQR + 35)
      P1(2)     = RW(INFDQR + 36)
      P1(3)     = RW(INFDQR + 37)
      P1(4)     = RW(INFDQR + 38)
      P1(5)     = RW(INFDQR + 39)
      P2(1)     = RW(INFDQR + 40)
      P2(2)     = RW(INFDQR + 41)
      P2(3)     = RW(INFDQR + 42)
      P2(4)     = RW(INFDQR + 43)
      P2(5)     = RW(INFDQR + 44)
      D(1)      = RW(INFDQR + 45)
      D(2)      = RW(INFDQR + 46)
      D(3)      = RW(INFDQR + 47)
      D(4)      = RW(INFDQR + 48)
      PD(1)     = RW(INFDQR + 49)
      PD(2)     = RW(INFDQR + 50)
      PD(3)     = RW(INFDQR + 51)
      QPNEGD    = RW(INFDQR + 52)

* 1/(Size of an FADC bin in cm)
      FADBIN = 1.0/(0.00096*DRFVEL)

* Re-scale resolution parameters
      ERRD0 = ERRD0*ERRD0
      ERRD1 = ERRD1*ERRD1
      ERRD2 = ERRD2*ERRD2
      ERRD3 = 2./ERRD3

* Cumulate the track-related noise probabilities
      PCUM1 = 0.
      PCUM2 = 0.
      DO 100 J=1,MXNHTQ
         PCUM1 = PCUM1 + P1(J)
         PCUM2 = PCUM2 + P2(J)
         QTRNP1(J) = PCUM1
         QTRNP2(J) = PCUM2
 100  CONTINUE

* Cumulate the track-related noise drift distribution
      QTRNDD(1,1) = 0.
      QTRNDD(2,1) = 0.
      DO 200 JSEG=2,MAXSGQ-1
         QTRNDD(1,JSEG) = QTRNDD(1,JSEG-1) + PD(JSEG-1)
         QTRNDD(2,JSEG) = D(JSEG-1)
 200  CONTINUE
      QTRNDD(1,MAXSGQ) = 1.
      QTRNDD(2,MAXSGQ) = D(MAXSGQ-1)

      CALL UGTRUN('FDQH',INFDQH)
      IF (INFDQH.LE.0) THEN
         WRITE(6,*) ' ***FQIDIG >> FDQH BANK NOT FOUND'
         CALL H1STOP
      ENDIF
      IF (IW(INFDQH+3).LT.980801) THEN
         WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQH BANK'
         CALL H1STOP
      ENDIF

      PHMC(1)     = RW(INFDQH +  4)
      PHMC(2)     = RW(INFDQH +  5)
      PHMC(3)     = RW(INFDQH +  6)
      PHMC(4)     = RW(INFDQH +  7)
      PHMC(5)     = RW(INFDQH +  8)
      PHMC(6)     = RW(INFDQH +  9)
      PWMC1(1)    = RW(INFDQH + 10)
      PWMC1(2)    = RW(INFDQH + 11)
      PWMC1(3)    = RW(INFDQH + 12)
      PWMC1(4)    = RW(INFDQH + 13)
      PWMC1(5)    = RW(INFDQH + 14)
      PWMC2(1)    = RW(INFDQH + 15)
      PWMC2(2)    = RW(INFDQH + 16)
      PWMC2(3)    = RW(INFDQH + 17)
      PWMC2(4)    = RW(INFDQH + 18)
      PWMC2(5)    = RW(INFDQH + 19)
      PWMC3(1)    = RW(INFDQH + 20)
      PWMC3(2)    = RW(INFDQH + 21)
      PWMC3(3)    = RW(INFDQH + 22)
      PWMC3(4)    = RW(INFDQH + 23)
      PWMC3(5)    = RW(INFDQH + 24)
      PWMC4(1)    = RW(INFDQH + 25)
      PWMC4(2)    = RW(INFDQH + 26)
      PWMC4(3)    = RW(INFDQH + 27)
      PWMC4(4)    = RW(INFDQH + 28)
      PWMC4(5)    = RW(INFDQH + 29)
      PWMC5(1)    = RW(INFDQH + 30)
      PWMC5(2)    = RW(INFDQH + 31)
      PWMC5(3)    = RW(INFDQH + 32)
      PWMC5(4)    = RW(INFDQH + 33)
      PWMC5(5)    = RW(INFDQH + 34)

      CALL UGTRUN('FDEF',INFDEF)
      IF (INFDEF.LE.0) THEN
         WRITE(6,*) ' ***FQIDIG >> FDEF BANK NOT FOUND'
         CALL H1STOP
      ENDIF
      IF (IW(INFDEF+3).LT.980801) THEN
         WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDEF BANK'
         CALL H1STOP
      ENDIF

      RDFAC0 = RW(INFDEF + 10)
      RDFAC1 = RW(INFDEF + 11)
      RDFAC2 = RW(INFDEF + 12)

* Apply run-dependent efficiency factors
      DO 500 JWIRE=0,5
         EFFQ(JWIRE,2) = EFFQ(JWIRE,0)*RDFAC2
         EFFQ(JWIRE,1) = EFFQ(JWIRE,0)*RDFAC1
         EFFQ(JWIRE,0) = EFFQ(JWIRE,0)*RDFAC0
 500  CONTINUE

      LFDQX = .FALSE.
      SIGSHF = 0.
      SGNSHF = 0.
      SIGNOI = 0.
      SGNNOI = 0.
      ANGNOI = 0.
      PRBNOI = 0.
      OFFNOI = 0.

* Look for FDQX bank - shifted data parameters, may not be present
      CALL UGTRUN('FDQX',INFDQX)
      IF (INFDQX.LE.0) RETURN
      IF (IW(INFDQX+3).LT.980801) THEN
         WRITE(6,*) ' ***FQIDIG >> WRONG VERSION OF FDQX BANK'
         CALL H1STOP
      ENDIF

      LFDQX = .TRUE.
      SIGSHF = RW(INFDQX+4)
      SGNSHF = RW(INFDQX+5)
      SIGNOI = RW(INFDQX+6)
      SGNNOI = RW(INFDQX+7)
      ANGNOI = RW(INFDQX+8)
      PRBNOI = RW(INFDQX+9)
      OFFNOI = RW(INFDQX+10)

      RETURN
      END
*CMZU:          03/08/98  13.56.29  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FQQSME(QPLUS,IFLAG0,IFLAG1,IFLAG2,QPSME)
*#****************************************************************
*#                                                               *
*#    PURPOSE:  Compute Smeared Charge (Energy)                  *
*#                                                               *
*#    INPUT:  QPLUS  -  deposited charge (actually Energy in eV) *
*#                      IFLAG - FLAG containing hit "quality" inf*
*#                                                               *
*#       OUTPUT: QPSME   Smeared charge                          *
*#                       Depends on IFLAG                        *
*#                                                               *
*#****************************************************************
*#                                                               *
*# CHANGED BY:                AT:                                *
*#                                                               *
*# REASON :                                                      *
*#                                                               *
*#                                                               *
*#****************************************************************

*KEEP,FQDGPR.
      COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3
     &,               DELCHG,DQUANT,FADBIN
*KEEP,FQDGDG.
      COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT
*KEEP,FQDGST.
      LOGICAL LSMEAR,LNOISE
      COMMON /FQDGST/ LSMEAR,LNOISE
*KEND.

*#****************************************************************

      QPSME = QPLUS*QFAC

* NB There is no adjustment for a preceding pulse

      IF (LSMEAR) THEN
         CALL H1NORR(GAUSS1)
         CALL H1NORR(GAUSS2)
         QPSME = QPLUS*(1.0 + DELCHG*GAUSS1)*QFAC + DQUANT*GAUSS2
      ENDIF

      IF (QPSME.LT.0.) QPSME = 0.

      RETURN
      END
*CMZU:          03/08/98  13.56.29  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FRQECR
*#**********************************************************************
*#                                                                     *
*#    VERSION: 29/07/98   Steve Burke                                  *
*#                                                                     *
*# PURPOSE: Create EVENT response bank FRQE                            *
*#                                                                     *
*#          1) Sort hits from FRQH bank by cell number(wire)           *
*#          2) Sort hits on one wire by drift distance                 *
*#          3) Simulate QT                                             *
*#                                                                     *
*# CALLED BY : FQDIGI                                                  *
*#                                                                     *
*# CALLS :     FQQTSM                                                  *
*#                                                                     *
*# INPUT :     BOS BANK  FRQH                                          *
*#                                                                     *
*# OUTPUT :    FRQE bank                                               *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*# AUTHOR : S. BURKE                                                   *
*#                                                                     *
*# CHANGED BY:                AT:                                      *
*# REASON :                                                            *
*#                                                                     *
*#**********************************************************************

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

* Common for work bank index
      COMMON /CFSORT/ ISORT

* Temp common for pointer arrays (extended for FRQX 29/7/98)
      PARAMETER (MAXHIT=3000)
      COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX
     &,               IFRQX(3,MAXHIT),NFRQX

*#**********************************************************************

* Zero pointer table
      CALL VZERO(IFRQX,MAXHIT*3)
      NFRQX = 0

* Locate FRQH Bank
      INFRQH = NLINK('FRQH',0)
      IF (INFRQH.LE.0) THEN
C         WRITE(6,*) 'FRQH BANK NOT FOUND'
         RETURN
      ENDIF

* Number of Hits
      INUM = IW(INFRQH+2)
      IF (INUM.LE.0) GOTO 100
* Truncate and warn if INUM exceeds MAXHIT
      IF (INUM.GT.MAXHIT) THEN
         CALL ERRLOG(205,'W:FRQECR: More than 3000 hits - rest ignored')
         INUM = MAXHIT
      ENDIF
      NFRQX = INUM

* Format event response bank
      CALL BKFMT('FRQE','B16')

* Create work bank for indices of channel numbers
      ISORT = 0
      CALL WBANK(IW,ISORT,INUM,*100)

* Length of data block ...
      IB = IW(INFRQH+1)
* Position one data block length before first block ...
      IA = INFRQH + 3 - IB
* Loop to insert indices of cell numbers
      DO 30 I=1,INUM
         IW(ISORT+I) = IA + I*IB
 30   CONTINUE

* Sort by cell number ...
*   RW(IW(ISORT+J)) is now the cell number and, in general,
*   RW(IW(ISORT+J) + IATTRIB - 1) is now IATTRIB'th attribute of
*   row  JROW = (IW(ISORT+J) - INSTR)/IW(INFRQH+3) + 1
*   in the FRQH bank.
      CALL SORTIL(IW,IW(ISORT+1),INUM)

*==============================================================

* Initialise digi counter
      KDIGI = 0

* Loop on all wires
      I = 0
   40 IF (I.EQ.INUM) GOTO 90
* Next wire number
         I  = I + 1
         IJ = I
 50      CONTINUE
            IF (IJ.LT.INUM) THEN
               IF (IW(IW(ISORT+IJ+1)).EQ.IW(IW(ISORT+I))) THEN
                  IJ = IJ + 1
                  GOTO 50
               ENDIF
            ENDIF
* I ... IJ are for same wire
         IBASE = I - 1
         N = IJ - IBASE
* Inline sort within one wire
* Sort is based on drift distance
* Drift distance is 2 words on from celnum in FRQH data blocks
         ISRT = ISORT + IBASE
         M = N
   51    CONTINUE
         M = M/2
         IF (M.GT.0) THEN
            DO 53 J=1,N-M
               L = J
* Compare elements with indices 'L' and 'L+M'
   52          CONTINUE
                  IF (RW(IW(ISRT+L+M)+2).LT.RW(IW(ISRT+L)+2)) THEN
* exchange the two index values
                     LL           = IW(ISRT+L+M)
                     IW(ISRT+L+M) = IW(ISRT+L)
                     IW(ISRT+L  ) = LL
                     L = L - M
                     IF (L.GT.0) GOTO 52
                  ENDIF
   53       CONTINUE
            GOTO 51
         ENDIF
*
* Hits on this wire are J=I,IJ, now sorted in order of increasing
* drift distance. Now simulate the QT and extend the FRQE bank
*
         CALL FQQTSM(INFRQH,KDIGI,I,IJ)
* Make transition to next  wire
         I = IJ
      GOTO 40

*==============================================================

* Finished
   90 CONTINUE

* Close bank
      IFRQE = IADFIN('FRQE',0)
      CALL BLIST(IW,'E+','FRQE')

  100 CONTINUE

* Drop work bank
      CALL WDROP(IW,ISORT)

      RETURN
      END
*CMZ :          20/01/99  14.59.43  by  Girish D. Patel
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FRQHCC
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*# PURPOSE:  Create FRQH hit bank from FRQF bank                       *
*#                                                                     *
*# CALLED BY :  FQDIGI                                                 *
*#                                                                     *
*# CALLS :      FRQHEX                                                 *
*#                                                                     *
*# INPUT :      FRQF banks                                             *
*#                                                                     *
*# OUTPUT :     FRQH bank                                              *
*#              ====                                                   *
*# AUTHOR :     Steve Burke                                            *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRQH BANK    2I,(I,2F,4I)  Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#    BANK FRQH    Forward Response new planar (Q) Hit bank            *
*#                 Contains all hits in chambers                       *
*#            IND+1 = NCOLS = 7                                        *
*#            IND+2 = NROWS                                            *
*# ----------------------------------------------------------------    *
*#    Col                                                              *
*#      1     I     = CELNUM                     Attrib                *
*#      2     R     = EDEP                       Attrib                *
*#      3     R     = DRIFT DISTANCE             Attrib                *
*#      4     I     = HITTYP                     Attrib                *
*#      5     I     = Drift 'sign' 0/1           Attrib                *
*#      6     I     = Trk History word           Attrib                *
*#      7     I     = Trk Number                 Reln                  *
*# ----------------------------------------------------------------    *
*#            HITTYP = 1 for track; 2 for noise                        *
*#            (GEANT units: cms GeV)                                   *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*# CHANGED BY:                AT:                                      *
*#                                                                     *
*# REASON :                                                            *
*#                                                                     *
*#**********************************************************************

*KEEP,FQDGEF.
      COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5)
     &,               PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5)
*KEEP,FQDGST.
      LOGICAL LSMEAR,LNOISE
      COMMON /FQDGST/ LSMEAR,LNOISE
*KEEP,FQMAXN.
* Maximum number of noise hits for new planars
      PARAMETER (MXNHTQ=5)
*KEEP,FQTRNP.
* Forward new planar track-related noise + shifted data parameters
      PARAMETER (MAXSGQ=5)
      LOGICAL LFDQX
      COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ)
     &,               QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI
     &,               ANGNOI,PRBNOI,OFFNOI
*KEND.

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

      PARAMETER (IHTTRK=1)
      PARAMETER (IHTNOI=2)
      PARAMETER (NCL   =7)
      PARAMETER (NBN   =0)
      DIMENSION    IKADD(NCL),BKADD(NCL)
      EQUIVALENCE (IKADD(1),BKADD(1))

* Cut in Deltap/p between entrance and exit. Ignore hits produced
* by stopping and spiralling tracks...
      PARAMETER (DPRCUT=0.5)

* Precision with which cell boundary (in z) is required. This
* should be >= the parameter EPSIL for the tracking medium as
* in the FGME bank...
      PARAMETER (SMALL=0.0101)

* Minimum energy deposit (50MeV) for a hit (avoids hits with zero
* energy loss and hence un-reconstructible radii)
      PARAMETER(FELMIN= 5.0E-8)

      DIMENSION ZPLA(24)
      DIMENSION KQMOD(24)
      PARAMETER (NWMAX=8)
      DIMENSION DRIFT(NWMAX),IDSIGN(NWMAX)

      LOGICAL LMASK
      LOGICAL LMHIT
      LOGICAL FIRST
      LOGICAL DONE
      DATA FIRST/.TRUE./

*#**********************************************************************

* Initialise geometry on first call...
      IF (FIRST) THEN
         CALL BKFMT('FRQH','2I,(I,2F,4I)')
* Access FGAQ bank
         CALL UGTBNK('FGAQ',INFGAQ)
         IF (INFGAQ.LE.0) THEN
            WRITE(6,*) ' FRQHCC Error -  FGAQ Bank not found'
            RETURN
         ENDIF
* Get basic planar parameters
         NMODQ = IW(INFGAQ+3)
         WSEPQ = RW(INFGAQ+6)
         KIND  = INFGAQ + IW(INFGAQ+1) + 1
* N.B. ZPLA(K) gives location of the cell boundary in z
* FURTHEST from the interaction point !!!
         DO 1 KMOD=0,NMODQ-1
            ZST = RW(KIND+3)
            DO 2 KZP=1,8
               KK = KZP + KMOD*8
               ZPLA (KK) = ZST + KZP*WSEPQ
               KQMOD(KK) = KMOD
 2          CONTINUE
            KIND = KIND + IW(KIND+1) + 1
 1       CONTINUE
         FIRST = .FALSE.
      ENDIF

*-----------------------------------------------------------------------

* Access FRQF bank
      INFRQF = NLINK('FRQF',0)
      IF (INFRQF.EQ.0) RETURN

* If bank exists access relevant information ...
      IBLEN = IW(INFRQF+1)
      IBLKS = IW(INFRQF+2)
      DO 11 J=1,IBLKS
* Pointers to entrance and exit data blocks ...
         IPT0 = INFRQF + 2 + (J-1)*IBLEN
         IPT1 = IPT0 + 7
* and to subsidiary data ...
         IPTD = IPT0 + 14
* Check momentum loss. Stopping tracks, spiraling tracks etc.
* cause problems. We can't be bothered with this so skip if
* Deltap/p > 50%.
         RDRP = ABS(RW(IPT0+7) - RW(IPT1+7))/RW(IPT0+7)
         IF (RDRP.GT.DPRCUT) GOTO 11
* Allow for coherent loss of 8-wire groups
         ICLNUM = IW(IPTD+2)
         IF (H1RN(J-1).GT.EFFQ8(ICLNUM/224)) THEN
            CALL FQHMC(MASK)
            IF (MASK.EQ.0) GOTO 11
            LMASK = .TRUE.
         ELSE
            LMASK = .FALSE.
         ENDIF
         IF (LFDQX) THEN
* Allow for correlated shifts
            SHIFT = -SIGSHF*LOG(1. - MIN(H1RN(J-17),0.999999))
            IF (H1RN(J-18).GT.SGNSHF) SHIFT = -SHIFT
         ELSE
            SHIFT = 0.
         ENDIF
* Trouble if track is going backwards? Reverse pointers
* if Z1 less than Z0
         IF (RW(IPT1+3).LT.RW(IPT0+3)) THEN
            IPDM = IPT0
            IPT0 = IPT1
            IPT1 = IPDM
         ENDIF
         X0  = RW(IPT0+1)
         Y0  = RW(IPT0+2)
         Z0  = RW(IPT0+3)
         VX0 = RW(IPT0+4)
         VY0 = RW(IPT0+5)
         VZ0 = RW(IPT0+6)
         X1  = RW(IPT1+1)
         Y1  = RW(IPT1+2)
         Z1  = RW(IPT1+3)
         VX1 = RW(IPT1+4)
         VY1 = RW(IPT1+5)
         VZ1 = RW(IPT1+6)
         P0  = RW(IPT0+7)
* Ignore vertical tracks
         IF (VZ0.EQ.0.) GOTO 11
* Particle type, History word, Cell number and track number ...
* S.E. PDG code translated to Geant code
         IR0    = IPDGEA(IW(IPTD+1))
         ITRHIS = IW(IPTD+3)
         ITRK   = IW(IPTD+4)
         VT0    = SQRT(1.0 - VZ0*VZ0)
         IF (VT0.EQ.0. .OR. (X1.EQ.X0 .AND. Y1.EQ.Y0)) THEN
            VXT0 = 0.
            VYT0 = 0.
            CU   = 0.
         ELSE
            VXT0 = VX0/VT0
            VYT0 = VY0/VT0
* Compute curvature of track ...
            CU   = -2.0*(VYT0*(X1 - X0) - VXT0*(Y1 - Y0))/
     +                  ((X1 - X0)**2 + (Y1 - Y0)**2)
         ENDIF
* P0 needs to be signed by the charge, which (I think) is opposite to
* the sign of the curvature *for forward-going tracks*
         P0   = SIGN(P0,-CU)
         AFAC = CU*VT0/(2.0*VZ0)
* Propagate the track from X0,Y0,Z0 in Steps of z.
* The z-step is one cell depth in z, allowing however for
* the possibility that the 1st and last point are interior
* to a z-cell.
* Locate the first z-cell boundary to propagate to ...
         KZBEG = 24
         DO 20 KZ=1,24
            DIST = ZPLA(KZ) - Z0
            IF (DIST.GT.SMALL) THEN
               KZBEG = KZ
               GO TO 21
            ENDIF
 20      CONTINUE
 21      CONTINUE
* First plane to go to is at ZPLA(KZBEG)
         KZP   = KZBEG - 1
         ZIN   = Z0
         XIN   = X0
         YIN   = Y0
         NWIRE = 0
* Loop over intermediate drift cells ...
 100     CONTINUE
            KZP  = MIN(KZP+1,24)
            ZOUT = ZPLA(KZP)
* Last point?
            IF (ZOUT.GT.Z1 .OR. ABS(ZOUT-Z1).LT.SMALL
     +                     .OR. KZP.EQ.24) THEN
               ZOUT = Z1
               DONE = .TRUE.
            ELSE
               DONE = .FALSE.
            ENDIF
* Propagate track along helix to exit point of drift cell
            DIST = ZOUT - Z0
            SPSI = SIN(AFAC*DIST)
            CPSI = COS(AFAC*DIST)
* modified by S.E. at 30.3.90 to avoid division by zero
            IF (CU.EQ.0.)THEN
               BFAC = VT0*DIST/VZ0
            ELSE
               BFAC = 2.0*SPSI/CU
            ENDIF
            XOUT = X0 + BFAC*(VXT0*CPSI - VYT0*SPSI)
            YOUT = Y0 + BFAC*(VYT0*CPSI + VXT0*SPSI)
* Complete CELL number ...
            ICELNM  = ICLNUM + MOD(KZP-1,8)
* Compute drift distance
            ZP = ZPLA(KZP) - 0.5*WSEPQ
            XP = XIN + (XOUT - XIN)*(ZP - ZIN)/(ZOUT - ZIN)
            YP = YIN + (YOUT - YIN)*(ZP - ZIN)/(ZOUT - ZIN)
            CALL FQDRF(XP,YP,ZP,ICELNM,DRIF,IFSGN)
            DRIF = DRIF + SHIFT
            IF (IFSGN.GE.0) THEN
* Collect drift and sign for each wire
               IF (NWIRE.LT.NWMAX) THEN
                  NWIRE = NWIRE + 1
                  IF (NWIRE.EQ.1) ICELL = ICELNM
                  DRIFT(NWIRE)  = DRIF
                  IDSIGN(NWIRE) = IFSGN
               ENDIF
* Compute energy loss ...
               CALL FDEDXL(XIN,YIN,ZIN,XOUT,YOUT,ZOUT,P0,IR0,FELOSS)
* Only make hit if sufficient energy loss in drift cell,
* and allow for inefficiency
               IF (FELOSS.GT.FELMIN) THEN
                  IWR = MOD(ICELNM,8)
                  IF (LMASK) THEN
                     LMHIT = JBIT(MASK,IWR+1).EQ.1
                  ELSE
                     LMHIT = H1RN(J).LE.EFFQ(IWR,ICELNM/224)
                  ENDIF
                  IF (LMHIT) THEN
* Add hit to bank ...
                     IKADD(1) = ICELNM
                     BKADD(2) = FELOSS
                     BKADD(3) = DRIF
                     IKADD(4) = IHTTRK
                     IKADD(5) = IFSGN
                     IKADD(6) = ITRHIS
                     IKADD(7) = ITRK
                     KND = IADROW('FRQH',NBN,NCL,BKADD)
                  ENDIF
               ENDIF
            ELSEIF (NWIRE.GT.0) THEN
* Track went outside cell, so add noise for the wires so far
               IF (LNOISE) CALL FRQHEX(ICELL,NWIRE,DRIFT,IDSIGN,ITRK)
               NWIRE = 0
            ENDIF
* Done with this step - go on to next
            IF (DONE) THEN
* Add track-related noise
               IF (NWIRE.GT.0 .AND. LNOISE)
     &            CALL FRQHEX(ICELL,NWIRE,DRIFT,IDSIGN,ITRK)
               GOTO 200
            ENDIF
            XIN  = XOUT
            YIN  = YOUT
            ZIN  = ZOUT
         GOTO 100
 200     CONTINUE
 11   CONTINUE

* Now access NOISE hit banks and fill hits ...
* No noise is generated at the moment. We may well generate
* different categories of noise kept in FRQN's with different
* bank numbers.
      IFRQN  = NAMIND('FRQN')
      INFRQN = IFRQN + 1
   40 CONTINUE
         INFRQN = IW(INFRQN-1)
* If bank exists access relevant information ...
         IF (INFRQN.NE.0 .AND. LNOISE) THEN
* Number of hits in bank
            INUM = IW(INFRQN+2)
* Track number zero for noise?
            ITRK =  0
* History word zero for noise?
            ITRHIS = 0
* Loop through hits in this bank
            INDST = INFRQN + 2
            DO 41 JJHIT=1,INUM
* Information from noise response bank ...
* N.B. Noise bank must contain full CELNUM
               ICLNUM =  IW(INDST + 1)
               XD     =  RW(INDST + 2)
               YD     =  RW(INDST + 3)
               ZD     =  RW(INDST + 4)
               EDEP   =  RW(INDST + 5)
* Only make hit if sufficient energy loss in drift cell ...
               IF (EDEP.GT.FELMIN) THEN
* Compute drift distance
                  CALL FQDRF(XD,YD,ZD,ICLNUM,DRIF,IFSGN)
                  IF (IFSGN.GE.0) THEN
* Extend FRQH bank ...
                     IKADD(1) = ICLNUM
                     BKADD(2) = EDEP
                     BKADD(3) = DRIF
                     IKADD(4) = IHTNOI
                     IKADD(5) = IFSGN
                     IKADD(6) = ITRHIS
                     IKADD(7) = ITRK
                     KND = IADROW('FRQH',NBN,NCL,BKADD)
                  ENDIF
               ENDIF
               INDST = INDST + IW(INFRQN+1)
 41         CONTINUE
* End loop through hits this bank - go to next bank
         GOTO 40
      ENDIF

* Close bank
      KND = IADFIN('FRQH',NBN)

      RETURN
      END
*CMZ :          20/01/99  15.03.05  by  Girish D. Patel
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FRQHCR
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*#    Create hit bank FRQH,0 from fine granularity input               *
*#                                                                     *
*#    CALLED BY:  FQDIGI                                               *
*#                                                                     *
*#    INPUTS:                                                          *
*#            FRQT banks                                               *
*#            FRQN banks  (noise)                                      *
*#    OUTPUT:                                                          *
*#            One bank FRQH,0 containing Hits from above banks         *
*#                                                                     *
*#    CALLS TO: FQDRF                                                  *
*#                                                                     *
*#    NB: There is also an FRQT bank in the database (with radial QT   *
*#        parameters), so beware of clashes! Fine granularity          *
*#        simulation should not be used for standard MC production.    *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRQH BANK    2I,(I,2F,4I)  Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#    BANK FRQH    Forward Response new planar (Q) Hit bank            *
*#                 Contains all hits in chambers                       *
*#            IND+1 = NCOLS = 7                                        *
*#            IND+2 = NROWS                                            *
*# ----------------------------------------------------------------    *
*#    Col                                                              *
*#      1     I     = CELNUM                     Attrib                *
*#      2     R     = EDEP                       Attrib                *
*#      3     R     = DRIFT DISTANCE             Attrib                *
*#      4     I     = HITTYP                     Attrib                *
*#      5     I     = Drift 'sign' 0/1           Attrib                *
*#      6     I     = Trk History word           Attrib                *
*#      7     I     = Trk Number                 Reln                  *
*# ----------------------------------------------------------------    *
*#            HITTYP = 1 for track; 2 for noise                        *
*#            (GEANT units: cms GeV)                                   *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*# CHANGED BY:                AT:                                      *
*#                                                                     *
*# REASON :                                                            *
*#                                                                     *
*#**********************************************************************

*KEEP,FQDGEF.
      COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5)
     &,               PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5)
*KEEP,FQDGST.
      LOGICAL LSMEAR,LNOISE
      COMMON /FQDGST/ LSMEAR,LNOISE
*KEND.

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

      PARAMETER (IHTTRK=1)
      PARAMETER (IHTNOI=2)
      PARAMETER (NCL   =7)
      PARAMETER (NBN   =0)

* Minimum energy deposit (50eV) for a hit (avoids hits with zero
* energy loss and hence un-reconstructible radii)
      PARAMETER (FELMIN=5.0E-8)
      DIMENSION IKADD(NCL),BKADD(NCL)
      EQUIVALENCE (IKADD(1),BKADD(1))

*#**********************************************************************

* Locate FRQT bank ...
      INFRQT = NLINK('FRQT',NBN)
* Locate FRQN bank ... (noise in new planars)
      INFRQN = IW(NAMIND('FRQN'))
* Check to see if any information ...
      IF (INFRQT.LE.0 .AND. INFRQN.LE.0) RETURN

* Hits Exist ...
      CALL BKFMT ('FRQH','2I,(I,2F,4I)')

* Now create banks
* First search through FRQT bank ...
      IF (INFRQT.GT.0) THEN
* Number of hits in bank
         INUM = IW(INFRQT+2)
* Loop through hits in this bank
         INDST = INFRQT + 2
         DO 11 JJHIT=1,INUM
* Information from track response bank ...
            ICLNUM = IW(INDST + 1)
            EDEP   = RW(INDST + 8)
* Only make hit if above minimum energy deposition, and allow
* for inefficiency
            IF (EDEP.GT.FELMIN .AND.
     &          H1RN(JJHIT).LE.EFFQ(MOD(ICLNUM,8),ICLNUM/224)) THEN
               XIN    = RW(INDST +  2)
               YIN    = RW(INDST +  3)
               ZIN    = RW(INDST +  4)
               XOUT   = RW(INDST +  5)
               YOUT   = RW(INDST +  6)
               ZOUT   = RW(INDST +  7)
               ITRHIS = IW(INDST +  9)
               ITRK   = IW(INDST + 10)
* Compute drift distance
               XP = 0.5*(XIN + XOUT)
               YP = 0.5*(YIN + YOUT)
               ZP = 0.5*(ZIN + ZOUT)
               CALL FQDRF(XP,YP,ZP,ICLNUM,DRIF,IFSGN)
               IF (IFSGN.GE.0) THEN
* Add hit to bank ...
                  IKADD(1) = ICLNUM
                  BKADD(2) = EDEP
                  BKADD(3) = DRIF
                  IKADD(4) = IHTTRK
                  IKADD(5) = IFSGN
                  IKADD(6) = ITRHIS
                  IKADD(7) = ITRK
                  KND = IADROW('FRQH',NBN,NCL,BKADD)
               ENDIF
            ENDIF
            INDST = INDST + IW(INFRQT+1)
 11      CONTINUE
      ENDIF

      IFRQN  = NAMIND('FRQN')
      INFRQN = IFRQN + 1
   40 CONTINUE
         INFRQN = IW(INFRQN-1)
* If bank exists access relevant information ...
         IF (INFRQN.GT.0 .AND. LNOISE) THEN
* Number of hits in bank
            INUM = IW(INFRQN+2)
* Track number zero for noise?
            ITRK =  0
* History word zero for noise?
            ITRHIS =  0
* Loop through hits in this bank
            INDST = INFRQT + 2
            DO 41 JJHIT=1,INUM
* Information from noise response bank ...
* N.B. Noise bank must contain full CELNUM
               ICLNUM = IW(INDST + 1)
               XD     = RW(INDST + 2)
               YD     = RW(INDST + 3)
               ZD     = RW(INDST + 4)
               EDEP   = RW(INDST + 5)
               IF (EDEP.GT.FELMIN) THEN
* Compute drift distance
                  CALL FQDRF(XD,YD,ZD,ICLNUM,DRIF,IFSGN)
                  IF (IFSGN.GE.0) THEN
* Extend FRQH bank ...
                     IKADD(1) = ICLNUM
                     BKADD(2) = EDEP
                     BKADD(3) = DRIF
                     IKADD(4) = IHTNOI
                     IKADD(5) = IFSGN
                     IKADD(6) = ITRHIS
                     IKADD(7) = ITRK
                     KND = IADROW('FRQH',NBN,NCL,BKADD)
                  ENDIF
               ENDIF
               INDST = INDST + IW(INFRQN+1)
 41         CONTINUE
* End loop through hits this bank - go to next bank
         GOTO 40
      ENDIF

* Finished
      IFRQH = IADFIN('FRQH',NBN)

      RETURN
      END
*CMZU:          03/08/98  13.56.29  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FRQXCR
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*#    Create table of pointers, parallel to FRQH hit bank              *
*#    pointing into FRQE                                               *
*#                                                                     *
*#    CALLED BY: FQDIGI                                                *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRQX BANK    B16           Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#    Bank FRQX    Forward Response new planar (Q) X-ref bank          *
*#                 Contains relations to FRQE and STR banks            *
*#                 PARALLEL to FRQH bank                               *
*#                                                                     *
*#  word#  type      Content                                           *
*#      1     I     = NCOLS  = 3                                       *
*#      2     I     = NROWS  = Number of hits                          *
*# ----------------------------------------------------------------    *
*#    Col                                                              *
*#      1     I     = IFLAG                      Attrib                *
*#      2     I     = Trk Number (STR)           Reln                  *
*#      3     I     = IFRQE                      Reln                  *
*# -----------------------------------------------------------------   *
*#    IFLAG   = Bit 0 set if drift sign posive                         *
*#              Bit 8 set if hit from track                            *
*#              Bit 9 set if hit from noise                            *
*#              Bit10 set if hit from TR                               *
*#    Trk Num   Pointer into STR  bank                                 *
*#    IFRQE     Pointer into FRQE bank                                 *
*#                                                                     *
*#**********************************************************************

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

* Temp common for pointer arrays (extended for FRQX 29/7/98)
      PARAMETER (MAXHIT=3000)
      COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX
     &,               IFRQX(3,MAXHIT),NFRQX

      PARAMETER (NBN=0)
      PARAMETER (NCOL=3)

*#**********************************************************************

      IF (NFRQX.NE.0) THEN
         CALL BKFMT('FRQX','B16')
         IND = IADNRW('FRQX',NBN,NCOL,NFRQX,IFRQX)
         IND = IADFIN('FRQX',NBN)
         CALL BLIST(IW,'E+','FRQX')
      ENDIF

      RETURN
      END
*CMZ :          20/01/99  15.04.09  by  Girish D. Patel
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FRQHEX(ICLNUM,NWIRE,DRIFT,IDSIGN,ITRK)
*#**********************************************************************
*#                                                                     *
*# PURPOSE:  Extend FRQH hit bank by adding track-related noise hits   *
*#                                                                     *
*# CALLED BY :  FRQHCC, once per track per module                      *
*#                                                                     *
*# INPUT :      ICLNUM - cell number (for wire 0)                      *
*#              NWIRE  - number of wires                               *
*#              DRIFT  - absolute drift to each wire                   *
*#              IDSIGN - drift sign for each wire                      *
*#              ITRK   - track number                                  *
*#                                                                     *
*# OUTPUT :     FRQH bank rows                                         *
*#              ====                                                   *
*#                                                                     *
*# AUTHOR :     Stephen Burke                                          *
*#                                                                     *
*# MODIFICATIONS:                                                      *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRQH BANK    2I,(I,2F,4I)  Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#                                                                     *
*#    BANK FRQH    Forward Response new planar (Q) Hit bank            *
*#                 Contains all hits in new Planars                    *
*#                                                                     *
*#            IND+1 = NCOLS = 7                                        *
*#            IND+2 = NROWS                                            *
*# ----------------------------------------------------------------    *
*#    Col                                                              *
*#      1     I     = CELNUM                     Attrib                *
*#      2     R     = EDEP                       Attrib                *
*#      3     R     = DRIFT DISTANCE             Attrib                *
*#      4     I     = HITTYP                     Attrib                *
*#      5     I     = Drift 'sign' 0/1           Attrib                *
*#      6     I     = Trk History word           Attrib                *
*#      7     I     = Trk Number                 Reln                  *
*# ----------------------------------------------------------------    *
*#            HITTYP = 2 for noise                                     *
*#            (GEANT units: cms GeV)                                   *
*#                                                                     *
*# Word 6 is set to zero, and word 7 to the 'parent' track number      *
*#                                                                     *
*#**********************************************************************

*KEEP,FQMAXN.
* Maximum number of noise hits for new planars
      PARAMETER (MXNHTQ=5)
*KEND.

      PARAMETER (NWMAX=8)
      DIMENSION DRIFT(NWMAX),IDSIGN(NWMAX),DRIFTN(MXNHTQ,NWMAX)

      PARAMETER (IHTNOI=2,ITRHIS=0,NCL=7,NBN=0)
      DIMENSION IKADD(NCL),BKADD(NCL)
      EQUIVALENCE (IKADD(1),BKADD(1))

* Minimum energy deposit (50MeV) for a hit (avoids hits with zero
* energy loss and hence un-reconstructible radii)
      PARAMETER (FELMIN=5.0E-8)

* Parameters for noise pseudo-track (6 mm, 100 MeV electron)
      PARAMETER (DIST=0.6,PMOM=-0.1,IPDG=11)

*#**********************************************************************

* Just in case ...
      IF (NWIRE.GT.NWMAX) NWIRE = NWMAX

* Generate noise hits
      CALL FQGTRN(NWIRE,DRIFT,DRIFTN)

      DO 200 JWIRE=1,NWIRE
         DO 100 JHIT=1,MXNHTQ
* Negative drift means no hit
            IF (DRIFTN(JHIT,JWIRE).LT.0.) GOTO 100
* Compute energy loss (totally arbitrary)
            CALL FDEDXL(DIST,0.,0.,0.,0.,0.,PMOM,IPDGEA(IPDG),FELOSS)
            IF (FELOSS.LE.FELMIN) GOTO 100
* Add row to FRQH bank
            IKADD(1) = ICLNUM + JWIRE - 1
            BKADD(2) = FELOSS
            BKADD(3) = DRIFTN(JHIT,JWIRE)
            IKADD(4) = IHTNOI
            IKADD(5) = IDSIGN(JWIRE)
            IKADD(6) = ITRHIS
            IKADD(7) = ITRK
            KND = IADROW('FRQH',NBN,NCL,BKADD)
 100     CONTINUE
 200  CONTINUE

      RETURN
      END
*CMZ :          20/01/99  15.05.03  by  Girish D. Patel
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FQGTRN(NWIRE,DD,DDN)
*#**********************************************************************
*#                                                                     *
*# PURPOSE:  Generate track-related noise for the new planars          *
*#                                                                     *
*# CALLED BY :  FRQHEX                                                 *
*#                                                                     *
*# INPUT :      NWIRE - number of wires                                *
*#              DD    - absolute drifts to each of the wires           *
*#                                                                     *
*# OUTPUT :     DDN - drifts for noise hits                            *
*#                                                                     *
*# AUTHOR :     Steve Burke                                            *
*#                                                                     *
*# CHANGED BY:                AT:                                      *
*#                                                                     *
*# REASON :                                                            *
*#                                                                     *
*#**********************************************************************

*KEEP,FQMAXN.
* Maximum number of noise hits for new planars
      PARAMETER (MXNHTQ=5)
*KEEP,FQTRNP.
* Forward new planar track-related noise + shifted data parameters
      PARAMETER (MAXSGQ=5)
      LOGICAL LFDQX
      COMMON /FQTRNP/ QTRNP1(MXNHTQ),QTRNP2(MXNHTQ),QTRNDD(2,MAXSGQ)
     &,               QPNEGD,LFDQX,SIGSHF,SGNSHF,SIGNOI,SGNNOI
     &,               ANGNOI,PRBNOI,OFFNOI
*KEND.

* Maximum drift for noise hits - slightly unphysical
      PARAMETER (DMAX=3.2,NWMAX=8)
      DIMENSION DD(NWMAX),DDN(MXNHTQ,NWMAX)

      INTEGER FCBDD
      LOGICAL LFIRST

*#**********************************************************************

* Just in case ...
      IF (NWIRE.GT.NWMAX) NWIRE = NWMAX

      SHIFT = 0.
      NSHFT = 0
      IF (LFDQX .AND. H1RN(NWIRE+2).LE.PRBNOI) THEN
         SHIFT = -SIGNOI*LOG(1. - MIN(H1RN(NWIRE),0.999999))
* Choose a drift sign
         IF (H1RN(NWIRE+1).LE.SGNNOI) SHIFT = -SHIFT
         CALL H1NORR(GAUSS)
         ANGLE = ANGNOI*GAUSS
         NSHFT = 1
      ENDIF

      LFIRST = .TRUE.
      DO 200 JWIRE=1,NWIRE
         IF (LFIRST) THEN
* QTRNP1 is the probability distribution for the first wire with hits ...
            NHIT = FCBDD(QTRNP1,MXNHTQ)
            IF (NHIT.GT.0) LFIRST = .FALSE.
         ELSE
* ... and QTRNP2 for subsequent wires
            NHIT = FCBDD(QTRNP2,MXNHTQ)
         ENDIF
         DO 100 JHIT=1,MXNHTQ
* Negative drift means no hit
            DDN(JHIT,JWIRE) = -1.0
            IF (JHIT.GT.NHIT+NSHFT) THEN
               GOTO 100
            ELSEIF (JHIT.GT.NSHFT) THEN
* Choose a drift from the distribution in QTRNDD
               DN = FCVPWL(QTRNDD,MAXSGQ)
               IF (LFDQX) DN = DN + OFFNOI
* Choose a drift sign
               IF (H1RN(JHIT).LE.QPNEGD) DN = -DN
            ELSE
               DN = SHIFT + ANGLE*FLOAT(JWIRE-1)
            ENDIF
* Disallow unphysical drifts
            TEST = DD(JWIRE) + DN
            IF (TEST.LT.0. .OR. TEST.GT.DMAX) TEST = DD(JWIRE) - DN
            IF (TEST.GE.0. .AND. TEST.LE.DMAX) DDN(JHIT,JWIRE) = TEST
 100     CONTINUE
 200  CONTINUE

      RETURN
      END
*CMZU:          03/08/98  13.56.29  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FQQTSM(INFRQH,KDIGI,JFIRST,JLAST)
*#**********************************************************************
*#                                                                     *
*# PURPOSE: Simulate the new planar QT code, and fill the EVENT        *
*#          response bank FRQE                                         *
*#                                                                     *
*# CALLED BY :  FRQECR                                                 *
*#                                                                     *
*# INPUT:       INFRQH - index of FRQH bank                            *
*#              KDIGI  - last digi number                              *
*#              JFIRST - pointer to first hit on wire                  *
*#              JLAST  - pointer to last hit on wire                   *
*#              ISORT  - pointer to work bank with sorted FRQH indices *
*#                       (in /CFSORT/)                                 *
*#                                                                     *
*# OUTPUT :     FRQE bank rows for this wire                           *
*#              IFRQX  - array holding FRQX bank rows (in /H1WORK/)    *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*#    FORMAT OF FRQE BANK    B16           Bank Number = 0             *
*#    ====== == ==== ====                                              *
*#                                                                     *
*#    Bank FRQE    Forward Response new planar (Q) Event bank          *
*#                 Contains digitisations for new planar drift chambers*
*#                                                                     *
*#    word#   type     Content                                         *
*#       1       I     NCOLS = 6 (= Number of attrributes)             *
*#       2       I     NROWS     (= Num of digis)                      *
*# ----------------------------------------------------------------    *
*#     Col                                                             *
*#       1       I     Cell Number               Attrib                *
*#       2       I     Drift                     Attrib                *
*#       3       I     Q                         Attrib                *
*#       4       I     FLAG0                     Attrib                *
*#       5       I     FLAG1                     Attrib                *
*#       6       I     FLAG2                     Attrib                *
*# ----------------------------------------------------------------    *
*#                                                                     *
*#  NOTES: *  Digitisations consist of more than one hit in general    *
*#         *  Drift times refer to the first hit to arrive at the wire *
*#            and are given in 10 micron units                         *
*#         *  Q is evaluated from energy deposition in the cell.       *
*#              The default unit is eV. In FRQH the energy is          *
*#              given in GeV. The conversion to eV is done in two      *
*#              steps. GeV -> keV is 'hard-wired' in this routine and  *
*#              an additional scale factor, QFAC, is then applied.     *
*#              QFAC is taken from the FDQR bank and so can be         *
*#              steered. Its default value is 1000.                    *
*#                                                                     *
*#         *  IFLAG0    Bits 0-7   Peak height (non-linear)            *
*#                      Bits 8-15  Separation in FADC bins from        *
*#                                 previous digi in cluster (measured  *
*#                                 between the centres of the hits)    *
*#         *  IFLAG1    Bits 0-7   Re-linearised pedestal (set to 100) *
*#                      Bits 8-15  Peak height of previous hit         *
*#         *  IFLAG2    Bits 0-6   Number of FADC bins from start of   *
*#                                 cluster to end of this hit          *
*#                      Bits 7-10  Length of the leading edge in FADC  *
*#                                 bins                                *
*#                      Bits 11-14 Number of previous hits in this     *
*#                                 cluster                             *
*#                      Bit  15    Raw data kept flag (always zero)    *
*#                                                                     *
*#**********************************************************************

*KEEP,FQDGPR.
      COMMON /FQDGPR/ TTSEP1,TTSEP2,MAXINT,ERRD0,ERRD1,ERRD2,ERRD3
     &,               DELCHG,DQUANT,FADBIN
*KEEP,FQDGDG.
      COMMON /FQDGDG/ IDRFAC,QFAC,IQSAT
*KEND.

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.

* Temp common for pointer arrays (extended for FRQX 29/7/98)
      PARAMETER (MAXHIT=3000)
      COMMON /H1WORK/ IFRRX(3,MAXHIT),IFRPX(3,MAXHIT),NFRRX,NFRPX
     &,               IFRQX(3,MAXHIT),NFRQX
      COMMON /CFSORT/ ISORT

      PARAMETER (NBN=0,NCL=6)
      INTEGER IKADD(NCL)

* Max of 64 hits per cluster (previous hit stops at 15)
      PARAMETER (MAXQT=64)
      DIMENSION JDIGI(0:MAXQT)
* Minimum allowed Q (arbitrary)
      PARAMETER (QMIN=10.)
* Nominal length of the leading edge is 3 bins
      PARAMETER (LLEDGE=3)
* Q for a maximum count of 1024: 1024*12/2 = 6144 (highly arbitrary!)
      PARAMETER (QMAX=6144.)
      PARAMETER (GVTOKV=1000000.)

*#**********************************************************************

* Main loop over clusters - set cell number, first drift and previous drift
      ICELL = IW(IW(ISORT+JFIRST))
      DCLUS = RW(IW(ISORT+JFIRST)+2)
      DLAST = -1.
      JCLUS = JFIRST
 100  CONTINUE

* Find hit cluster (from JDIGI(0) to JCLUS-1) and collect into digis
      NHIT     = 0
      JDIGI(0) = JCLUS
 200  CONTINUE
         JCLUS = JCLUS + 1
* Have we fallen off the end of the wire?
         IF (JCLUS.LE.JLAST) THEN
            DPREV = DCLUS
            DCLUS = RW(IW(ISORT+JCLUS)+2)
* The minimum cluster separation is taken as being the same as
* the integration interval
            IF ((DCLUS-DPREV)*FADBIN.LE.MAXINT) THEN
* The two-track separation should probably depend on Q; this is a bodge
* Model is a linear rise from TTSEP1 to TTSEP2
               PROB = (DCLUS - DPREV - TTSEP1)/(TTSEP2 - TTSEP1)
               IF (H1RN(JCLUS).LT.PROB) THEN
* Start a new digi (else merged with the previous one)
                  NHIT = NHIT + 1
* The QT has a maximum number of hits per cluster
                  IF (NHIT.LE.MAXQT) JDIGI(NHIT) = JCLUS
               ENDIF
               GOTO 200
            ENDIF
         ENDIF
      IF (NHIT.LT.MAXQT) THEN
* We need a pointer to the next hit after this cluster
         JDIGI(NHIT+1) = JCLUS
      ELSE
* We got more than the allowed number of hits
         NHIT = MAXQT - 1
      ENDIF

* Loop over digis in cluster - initialise last DOS sum and first drift
      IPLAST = 0
      DSTART = RW(IW(ISORT+JDIGI(0))+2)
      DO 500 IHIT=0,NHIT
* Increment digi counter
         KDIGI = KDIGI + 1
* Add up the charges in this digi, and fill the FRQX rows
         DRIFT = 0.
         QPLUS = 0.
         DO 300 JHIT=JDIGI(IHIT),JDIGI(IHIT+1)-1
            CHARGE = GVTOKV*RW(IW(ISORT+JHIT)+1)
            DRIFT  = DRIFT + CHARGE*RW(IW(ISORT+JHIT)+2)
            QPLUS  = QPLUS + CHARGE
* Type of hit + drift sign
            IHTTYP = IW(IW(ISORT+JHIT)+3)
            ISGN   = IW(IW(ISORT+JHIT)+4)
* Row number in FRQH
            JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1
            IFRQX(1,JROW) = IBSET(IFRQX(1,JROW),IHTTYP+7) + ISGN
            IFRQX(2,JROW) = IW(IW(ISORT+JHIT)+6)
            IFRQX(3,JROW) = KDIGI
 300     CONTINUE
* Drift is charge-weighted average (rough guess)
         DRIFT  = DRIFT/QPLUS
* Now for the QT flags: DOS sum (peak height) (rather arbitrary)
         IPEAK = 255.*QPLUS*QFAC/QMAX
         IF (IPEAK.GT.255) IPEAK = 255
* Distance to previous hit - set to zero for first hit (?)
         IF (DLAST.LT.0.) THEN
            ISEPL = 0
         ELSE
            ISEPL = (DRIFT - DLAST)*FADBIN + 0.499
            IF (ISEPL.GT.255) ISEPL = 255
         ENDIF
         DLAST = DRIFT
* Relinearised pedestal - arbitrary
         IPED = 100
* Number of bins from start of cluster to end of leading edge of this hit
         DSTOP = RW(IW(ISORT+JDIGI(IHIT+1)-1)+2)
         LHIT  = LLEDGE + ((DSTOP - DSTART)*FADBIN + 0.499)
         IF (LHIT.GT.127) LHIT = 127
* Number of adjacent bins above threshold
* Set to 2 + number of hits in digi (a bit silly, but what else?)
* Should just be length of leading edge?
         NADJ = LLEDGE + JDIGI(IHIT+1) - JDIGI(IHIT) - 1
         IF (NADJ.GT.15) LHIT = 15
* Hit counter sticks at 15
         IIHIT = MIN(IHIT,15)
* Pack pulse shape info
         IFLAG0 = 0
         IFLAG1 = 0
         IFLAG2 = 0
         CALL MVBITS(IPEAK,0,7,IFLAG0,0)
         CALL MVBITS(ISEPL,0,7,IFLAG0,8)
         CALL MVBITS(IPED,0,7,IFLAG1,0)
         CALL MVBITS(IPLAST,0,7,IFLAG1,8)
         CALL MVBITS(LHIT,0,6,IFLAG2,0)
         CALL MVBITS(NADJ,0,3,IFLAG2,7)
         CALL MVBITS(IIHIT,0,3,IFLAG2,11)
* No raw data kept!
*        CALL SBIT0(IFLAG2,16)
* Remember last peak height
         IPLAST = IPEAK
* Compute smeared drift (first hit)
         CALL FDQSME(DRIFT,IFLAG0,IFLAG1,IFLAG2,DSMEA)
* Compute smeared charge
         CALL FQQSME(QPLUS,IFLAG0,IFLAG1,IFLAG2,QPSME)
         IF (QPSME.LT.QMIN) THEN
* Abandon digi
            KDIGI = KDIGI - 1
            DO 400 JHIT=JDIGI(IHIT),JDIGI(IHIT+1)-1
               JROW = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1
               IFRQX(3,JROW) = 0
 400        CONTINUE
         ELSE
* Prepare input array of FRQE bank (NB T0 = 1000)
            IKADD(1) = ICELL
            IKADD(2) = ABS(1000. + DSMEA*FADBIN*50.0)
            IKADD(3) = MIN(IFIX(QPSME),IQSAT)
            IKADD(4) = IFLAG0
            IKADD(5) = IFLAG1
            IKADD(6) = IFLAG2
* Extend FRQE bank
            INFRQE = IADROW('FRQE',NBN,NCL,IKADD)
         ENDIF
 500  CONTINUE

* Allow for hits with no digi!
      DO 600 JHIT=JDIGI(NHIT+1),JCLUS-1
         IHTTYP = IW(IW(ISORT+JHIT)+3)
         ISGN   = IW(IW(ISORT+JHIT)+4)
         JROW   = (IW(ISORT+JHIT) - INFRQH - 2)/IW(INFRQH+1) + 1
         IFRQX(1,JROW) = IBSET(IFRQX(1,JROW),IHTTYP+7) + ISGN
         IFRQX(2,JROW) = IW(IW(ISORT+JHIT)+6)
         IFRQX(3,JROW) = 0
 600  CONTINUE

* Go on to next cluster, if any
      IF (JCLUS.LE.JLAST) GOTO 100

      RETURN
      END
*CMZU:          03/08/98  13.56.29  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FQHMC(MASK)
*#**********************************************************************
*#                                                                     *
*# PURPOSE:  Choose which hits are present in a "missing" new planar   *
*#           cluster.                                                  *
*#                                                                     *
*# CALLED BY :  FRQHCC                                                 *
*#                                                                     *
*# CALLS :      FCBDD                                                  *
*#                                                                     *
*# INPUT :      Hit probabilities from FQDGEF                          *
*#                                                                     *
*# OUTPUT :     Hit mask (one bit per wire)                            *
*#                                                                     *
*# AUTHOR :     Steve Burke                                            *
*#                                                                     *
*#**********************************************************************
*#                                                                     *
*# CHANGED BY:                                                         *
*#                                                                     *
*# REASON :                                                            *
*#                                                                     *
*#**********************************************************************

      INTEGER FCBDD

*KEEP,FQDGEF.
      COMMON /FQDGEF/ EFFQ(0:7,0:2),EFFQ8(0:2),PHMC(6),PWMC1(5)
     &,               PWMC2(5),PWMC3(5),PWMC4(5),PWMC5(5)
*KEND.

*#**********************************************************************


* How many hits are there?
      NHIT = FCBDD(PHMC,6)

      IF (NHIT.LE.0) THEN
* Zero hits
         MASK = 0
      ELSEIF (NHIT.EQ.1) THEN
* One hit
         MASK = 0
         CALL SBIT1(MASK,FCBDD(PWMC1,5)+1)
      ELSEIF (NHIT.EQ.2) THEN
* Two hits
         MASK = 0
         IWR1 = FCBDD(PWMC1,5)
 10      CONTINUE
         IWR2 = FCBDD(PWMC2,5)
         IF (IWR2.EQ.IWR1) GOTO 10
         CALL SBIT1(MASK,IWR1+1)
         CALL SBIT1(MASK,IWR2+1)
      ELSEIF (NHIT.EQ.3) THEN
* Three hits
         MASK = 0
         IWR1 = FCBDD(PWMC1,5)
 20      CONTINUE
         IWR2 = FCBDD(PWMC2,5)
         IF (IWR2.EQ.IWR1) GOTO 20
 30      CONTINUE
         IWR3 = FCBDD(PWMC3,5)
         IF (IWR3.EQ.IWR1 .OR. IWR3.EQ.IWR2) GOTO 30
         CALL SBIT1(MASK,IWR1+1)
         CALL SBIT1(MASK,IWR2+1)
         CALL SBIT1(MASK,IWR3+1)
      ELSEIF (NHIT.EQ.4) THEN
* Four hits
         MASK = 63
         IWR5 = FCBDD(PWMC5,5)
 40      CONTINUE
         IWR4 = FCBDD(PWMC4,5)
         IF (IWR4.EQ.IWR5) GOTO 40
         CALL SBIT0(MASK,IWR5+1)
         CALL SBIT0(MASK,IWR4+1)
      ELSEIF (NHIT.EQ.5) THEN
* Five hits
         MASK = 63
         CALL SBIT0(MASK,FCBDD(PWMC5,5)+1)
      ELSE
* Six hits
         MASK = 63
      ENDIF

      RETURN
      END
*CMZ :          15/09/99  17.28.21  by  Girish D. Patel
*CMZ :  3.06/24 12/09/95  21.46.24  by  Vladimir Shekelyan
*CMZU:  3.01/00 09/03/94  15.02.36  by  Stephan Egli
*CMZU:  3.00/05 08/02/94  15.48.15  by  Stephan Egli
*CMZU:  2.13/00 20/05/93  18.23.11  by  Stephan Egli
*CMZU:  2.10/00 07/12/92  19.26.58  by  Stephan Egli
*CMZU:  2.00/01 19/02/91  15.00.52  by  Stephan Egli
*-- Author :    Stephan Egli   19/02/91
      SUBROUTINE FDIGI
************************************************************************
* Digitize hit data for forward tracker.                               *
************************************************************************
*KEEP,BOSMDL.
C     ------BOSMDL
      LOGICAL       BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT
      COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT,
     +              LCCRUN,NCCRUN,NEVENT,
     +              IHA,IBS,IDB,IDATEL,LUP,ISN,JSN
      SAVE  /BOSMDL/
C     ------
*KEEP,H1OSGO.
      COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12)
*KEND.

      CHARACTER*8 VERSQQ

*KEEP,VERSQQ.
      VERSQQ = ' 3.09/10'
      IVERSQ =  30910
*KEND.

      IF(LCONFG.LT.10) THEN

        CALL MODULS('FDIGI',IVERSQ,'FRPTFRPFFRRTFRRFFRMTFRTT')
        CALL MODDEF(30433)

        IF(BEGRUN)THEN
          CALL FRIDIG
          CALL FPIDIG
        ENDIF

        IF(REVENT)THEN
          CALL FRDIGI
          CALL FPDIGI
          CALL FMDIGI
          CALL FMPME
        ENDIF
      ELSE
        CALL MODULS('FDIGI',IVERSQ,'FRPTFRPFFRQTFRQF')
        CALL MODDEF(30433)

        IF(BEGRUN)THEN
          CALL FQIDIG
          CALL FPIDIG
        ENDIF

        IF(REVENT)THEN
          CALL FQDIGI
          CALL FPDIGI
        ENDIF
      ENDIF

      CALL MODULF
      CALL MODDEF(0)

      RETURN
      END

*------------- end upgrade.f ---------------------
*------------- start newftsim.f ------------------

*CMZU:  3.06/00 28/12/94  17.39.21  by  Matthias Korn
*CMZ :  3.05/02 08/11/94  15.07.49  by  Vladimir Shekelyan
*CMZ :  3.04/01 01/10/94  21.10.29  by  Stephan Egli
*CMZU:  3.01/02 23/03/94  17.59.14  by  Stephan Egli
*CMZ :  3.01/01 22/03/94  17.24.46  by  Stephan Egli
*CMZU:  3.01/00 05/03/94  20.57.42  by  Stephan Egli
*CMZU:  3.00/01 12/11/93  16.44.27  by  Stephan Egli
*-- Author : Stephan Egli
      PROGRAM SIMH1
************************************************************************
* Main program for purely simulation jobs. Use the following flags     *
* to extract the proper version:                                       *
*                                                                      *
* Flag H1GEAONLY: only the H1GEA module is run (e.g. for external      *
*                 productions.                                         *
* no flags:       H1GEA + digi + trigger modules                       *
************************************************************************
*
*KEEP,CJOBNR.
      COMMON/CJOBNR/JOBNR,LAB
      SAVE  /CJOBNR/
*KEND.

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
      CHARACTER*8 INBOS
*
*     initialize BOS
*
      CALL BNAMES(2000)
      CALL BOS(IW,NBOSIW)
*
*
*     read i/o commands and steering banks

      CALL FPARMR(5)
      CALL BREADC
*
*     check for input file:
*
 35   IF(IFRST('BOSINPUT',0).NE.0)THEN
        INBOS='BOSINPUT'
      ELSE
        INBOS=' '
      ENDIF

*     initialize random number generator

*     get next job number

      JOBNR=MDB('/JOB')
      CALL H1RNIN(JOBNR+1)

* ---- event processing loop ------------------------------------------
*
   10 CALL FSEQR(INBOS,IRET)
        IF(IRET.LT.0) GOTO 100
        IF(INBOS.EQ.' ')CALL INLGEN
*  -----------    tracking module ----------------

        CALL H1GEA


*  select run number (call has no effect, if no RUNR bank available)

        CALL NEWRUN(IEND)
        IF(IEND.EQ.1)CALL FSEQE

*  -----------     digi modules -------------------

c        CALL CDIGI
        CALL FDIGI
c        CALL ADIGI
c        CALL PDIGI
c        CALL BDIGI
c        CALL SDIGI
c        CALL IDIGI
c        CALL MDIGI
c        CALL JHITS
c        CALL JDIGI
c        CALL LDIGI

* --------------   trigger modules -----------------

c        CALL MWTRES
c        CALL ARTRES
c        CALL DCTRES
c        CALL BCTRES
c        CALL SPTRES
c        CALL MUTRES
c        CALL LUTRES
*       trigger elements
c        CALL CTCELE
*       central trigger logic
c        CALL CTCLOG


        CALL FSEQW('BOSOUTPUT')

      GOTO 10
*
*     perform final book keeping

 100  IND=MDB('/END')
      CALL FPARM('CLOSE ALL')
      STOP
      END

*CMZ :          10/11/98  14.49.49  by  Girish D. Patel
*CMZU:  3.07/18 31/01/98  18.13.53  by  V.Solochenko
*CMZ :  3.07/00 20/02/97  15.16.06  by  Hanna Mahlke-Krueger
*CMZU:  3.06/37 27/02/96  16.26.57  by  Olaf Duenger
*CMZU:  3.06/35 28/12/95  08.47.04  by  Vladimir Andreev
*CMZ :  3.06/25 28/09/95  20.48.57  by  Vladimir Shekelyan
*CMZU:  3.05/02 01/11/94  13.15.55  by  Benno List
*CMZU:  3.00/03 06/12/93  15.35.51  by  Vladimir Shekelyan
*CMZU:  2.14/02 10/08/93  20.45.44  by  Vladimir Shekelyan
*CMZU:  2.10/13 15/12/92  17.27.25  by  Alexander Fedotov
*CMZU:  2.08/04 11/06/92  11.58.39  by  Christian Pichler
*CMZU:  2.06/04 10/01/92  10.37.08  by  Jozef Ferencei
*CMZU:  2.04/00 11/07/91  19.26.42  by  Joerg Gayler
*CMZ :  2.01/00 08/07/91  19.01.14  by  Pavel Staroba
*CMZU:  2.00/06 15/05/91  17.39.03  by  Stephan Egli
*CMZU:  2.00/03 25/04/91  12.34.03  by  Stephan Egli
*CMZ :  2.00/02 05/04/91  11.39.35  by  Stephan Egli
*CMZ :  2.00/00 10/02/91  09.08.52  by  Stephan Egli
*CMZ :  1.08/02 06/02/91  14.35.14  by  Stephan Egli
*-- Author :
      SUBROUTINE GEDEPO
************************************************************************
*  Main steering routine for hit production. Depending on the current  *
*  subdetector,IDTYPE and granularity the necessary hit routine is     *
*  selected.                                                           *
*  Input:   IDTYPE:       COMMON/GCSETS/                               *
*           ISGRAN(1..8): COMMON/H1DETC/                               *
*           CHARGE:       COMMON/GCKINE/                               *
*           DESTEP:       COMMON/GCTRAK/                               *
*           ICURSU:       COMMON/CCURSU/                               *
*                                                                      *
* The array EN has the following meaning:                              *
*   EN(1) visible had energy + fluctation                              *
*   EN(2) visible em energy + fluctation                               *
*   EN(3) invisible energy no fluctuation (break-up)                   *
*   EN(4) total em energy no fluctuation                               *
*   EN(5) total had energy no fluctuation                              *
*   EN(6) visible had energy no fluctuation                            *
*                                                                      *
*  Author:  Stephan Egli    10.3.90                                    *
*  Changed by: P.Staroba    28.1.91  Reason : Adaption for ARCET       *
*  Changed by: W. Hildesheim 7.4.91  Reason : no calib. ene's in IRHT  *
*              H1DEDX stuff obsoleted, use IFLASH(1,I)=0 instead       *
*  Changed by: W.H./S.E. passive E not in visible E, only in Eemtot    *
*  CHANGED BY: H.KAUFMANN          AT: 30/1/91                         *
*  REASON : VERTEX- AND BACKWARD SILICON DETECTORS IMPLEMENTED         *
*  Changed by: J.Gayler 11.7.91  Reason : allow for M>7 in ARCET       *
*  Changed by: J.Ferencei          at: 10/01/92                        *
*  Reason : ACSOFT part (as determined by P.Reimer) of the energy      *
*           inside the BEMC WLS stored for detailed granularity        *
*  Changed by: C.Pichler           at: 27/05/92                        *
*  Reason : ACSOFT correction removed and put to subroutine BDEPO      *
*  Changed by: A.Fedotov 13.12.92  Reason: call JHIT for proton tagger *
*  Changed by: V.Shekelyan         at: 29.07.93                        *
*  Reason : upgrade 1995                                               *
*  Changed by: P.Biddulph 27.10.94 Reason: call JHIT for FToF          *
*  Changed by: O.Duenger 27.02.96 Reason: call JHIT for Neutron Counter*
*  Changed by: H. Mahlke-Krueger    01.08.96                           *
*  Reason: call JHIT for interior of Roman Pots                        *
*  Changed by: V.Solochenko 31.01.98  Reason: call JHIT for FTS        *
************************************************************************
*KEEP,GCKINE.
      COMMON/GCKINE/IKINE,PKINE(10),ITRA,ISTAK,IVERT,IPART,ITRTYP
     +      ,NAPART(5),AMASS,CHARGE,TLIFE,VERT(3),PVERT(4),IPAOLD
C
      INTEGER       IKINE,ITRA,ISTAK,IVERT,IPART,ITRTYP,NAPART,IPAOLD
      REAL          PKINE,AMASS,CHARGE,TLIFE,VERT,PVERT
C
*KEEP,GCTRAK.
      INTEGER NMEC,LMEC,NAMEC,NSTEP ,MAXNST,IGNEXT,INWVOL,ISTOP,MAXMEC
     + ,IGAUTO,IEKBIN,ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN,NLVSAV,ISTORY
      REAL  VECT,GETOT,GEKIN,VOUT,DESTEP,DESTEL,SAFETY,SLENG ,STEP
     + ,SNEXT,SFIELD,TOFG  ,GEKRAT,UPWGHT
      PARAMETER (MAXMEC=30)
      COMMON/GCTRAK/VECT(7),GETOT,GEKIN,VOUT(7),NMEC,LMEC(MAXMEC)
     + ,NAMEC(MAXMEC),NSTEP ,MAXNST,DESTEP,DESTEL,SAFETY,SLENG
     + ,STEP  ,SNEXT ,SFIELD,TOFG  ,GEKRAT,UPWGHT,IGNEXT,INWVOL
     + ,ISTOP ,IGAUTO,IEKBIN, ILOSL, IMULL,INGOTO,NLDOWN,NLEVIN
     + ,NLVSAV,ISTORY
C
*KEEP,GCSETS.
      COMMON/GCSETS/IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV(20)
C
      INTEGER       IHSET,IHDET,ISET,IDET,IDTYPE,NVNAME,NUMBV
C
*KEEP,H1DETC.
      PARAMETER (NSUBDE=8)
      COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE),
     1                ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE),
     1                SKECUT(NSUBDE+2)
*KEEP,CCURSU.
      COMMON/CCURSU/ICURSU,IPRESU,ISGRAC,ISRBNC,ISDSBC,ISTRBC,ISTRKC,
     1              SKECUC
*KEEP,GCFLAG.
      COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN
     +        ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2)
      COMMON/GCFLAX/BATCH, NOLOG
      LOGICAL BATCH, NOLOG
C
      INTEGER       IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN
     +        ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM
C
*KEEP,GCTMED.
      COMMON/GCTMED/NUMED,NATMED(5),ISVOL,IFIELD,FIELDM,TMAXFD,STEMAX
     +      ,DEEMAX,EPSIL,STMIN,CFIELD,PREC,IUPD,ISTPAR,NUMOLD
C
      INTEGER       NUMED,NATMED,ISVOL,IFIELD,IUPD,ISTPAR,NUMOLD
      REAL          FIELDM,TMAXFD,STEMAX,DEEMAX,EPSIL,STMIN,CFIELD,PREC
C
*KEEP,GCMATE.
      COMMON/GCMATE/NMAT,NAMATE(5),A,Z,DENS,RADL,ABSL
C
      INTEGER NMAT,NAMATE
      REAL A,Z,DENS,RADL,ABSL
C
*KEEP,GCBANK.
      INTEGER IQ,LQ,NZEBRA,IXSTOR,IXDIV,IXCONS,LMAIN,LR1,JCG
      INTEGER KWBANK,KWWORK,IWS
      REAL GVERSN,ZVERSN,FENDQ,WS,Q
C
      PARAMETER (KWBANK=1300000,KWWORK=5200)
      COMMON/GCBANK/NZEBRA,GVERSN,ZVERSN,IXSTOR,IXDIV,IXCONS,FENDQ(16)
     +             ,LMAIN,LR1,WS(KWBANK-24)
      DIMENSION IQ(KWBANK-30),Q(KWBANK-30),LQ(KWBANK-22),IWS(KWBANK-24)
      EQUIVALENCE (Q(1),IQ(1),LQ(9)),(LQ(1),LMAIN),(IWS(1),WS(1))
      EQUIVALENCE (JCG,JGSTAT)
      INTEGER       JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
     +      ,JROTM ,JRUNG ,JSET  ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
     +      ,JVOLUM,JXYZ  ,JGPAR ,JGPAR2,JSKLT
C
      COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
     +      ,JROTM ,JRUNG ,JSET  ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
     +      ,JVOLUM,JXYZ  ,JGPAR ,JGPAR2,JSKLT
C
*KEEP,GCJLOC.
      COMMON/GCJLOC/NJLOC(2),JTM,JMA,JLOSS,JPROB,JMIXT,JPHOT,JANNI
     +                  ,JCOMP,JBREM,JPAIR,JDRAY,JPFIS,JMUNU,JRAYL
     +                  ,JMULOF,JCOEF,JRANG
C
      INTEGER       NJLOC   ,JTM,JMA,JLOSS,JPROB,JMIXT,JPHOT,JANNI
     +                  ,JCOMP,JBREM,JPAIR,JDRAY,JPFIS,JMUNU,JRAYL
     +                  ,JMULOF,JCOEF,JRANG
C
*KEEP,H1OSGO.
      COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12)
*KEND.

      LOGICAL BTEST
      DIMENSION MNLIJK(6),EN(6),VSPOT(6)

*  ==============================================
*  sum of DESTEP (calorimeters and dead material)
*  ==============================================

      IF(DESTEP.EQ.0.) GO TO 5
* for particles leaving iron (ICURSU=9) dE/dx is not defined
      IF(ICURSU.EQ.9) GO TO 5

*  map to channel number

      CALL GENMAP(1,VECT,MNLIJK,ISGRAC)

* apply Birk's law for BEMC SCSN-38 scintillator and for LAr
* if requested by steering

      DESVIS=DESTEP
      IF(BTEST(ISWIT(9),8))THEN
        IF (ABS(CHARGE) .GT. 0.1)THEN
          IF(NUMED.EQ.503.OR.(NUMED.GE.511.AND.NUMED.LE.516))THEN
            RKB=Q(LQ(JTM)+28)/DENS
            IF (ABS(CHARGE).GE.2.) RKB=RKB*7.2/12.6
            DEDXCM=1000.*Q(JLOSS+IEKBIN)
            DESVIS=DESTEP/(1.+RKB*DEDXCM)
          ELSE IF(NMAT.EQ.310)THEN
            RKB=Q(LQ(LQ(JTMED-310))+28)/DENS
            IF (ABS(CHARGE).GE.2.) RKB=RKB*7.2/12.6
            DEDXCM=1000.*Q(JLOSS+IEKBIN)
            DESVIS=DESTEP/(1.+RKB*DEDXCM)
          ENDIF
        ENDIF
      ENDIF

* distinguish between absorber material and sensitive material in detailled
* tracking (no Evis for passive) and distinction of em and had energies

      N=MNLIJK(2)
      IF(ITRTYP.LT.3)THEN
*       electromagnetic energy
        EN(1)=0.
        IF(N.GE.4) THEN
          EN(2)=0.
        ELSE
          EN(2)=DESVIS
        ENDIF
        EN(3)=0.
        EN(4)=DESTEP
        EN(5)=0.
        EN(6)=0.
      ELSE
*       hadronic energy
        IF(N.GE.4) THEN
          EN(1)=0.
          EN(6)=0.
        ELSE
          EN(1)=DESVIS
          EN(6)=DESVIS
        ENDIF
        EN(2)=0.
        EN(3)=0.
        EN(4)=0.
        EN(5)=DESTEP
      ENDIF
*     reset to "active" number except for IRON
      IF(N.GE.4.AND.MNLIJK(1).NE.10)MNLIJK(2)=N-4

*     deposit dE/dx in bank
      CALL SPODEP(1,VECT,EN,MNLIJK)

*  ========================
*  other cases (tracks,...)
*  ========================
5     CONTINUE
*
      IF(IDTYPE.EQ.0) RETURN

*  tracker hits after 100 ns are ignored
      IF(ICURSU.LE.2)THEN
        IF(TOFG.GT.1.E-7)RETURN
      ENDIF

      GOTO(10,20,30,40,50,60,70,80),ICURSU
      WRITE(6,*)' ***GEDEPO***: invalid subdetector:',ICURSU
      STOP
*     ********************   CENT  ******************
10    IF(CHARGE.EQ.0.)RETURN
        GOTO(11,12,13,14,14,14,14,15,16),IDTYPE-100
        WRITE(6,900)IDTYPE
        STOP
11      IF(ISGRAN(1).EQ.3)THEN
          CALL CJHITF
        ELSE
          CALL CJHITS
        ENDIF
        RETURN
12      CALL USRHIT('CRYT')
        RETURN
13      CALL USRHIT('CRZT')
        RETURN
14      CALL USRHIC('CRMT',IDTYPE-104)
        RETURN
15      CALL USRHIT('CRVT')
        RETURN
16      CALL USRHIT('BRST')
        RETURN
*     ********************   FWDT  ******************
20    IF(CHARGE.EQ.0.)RETURN
        GOTO(21,22,23),IDTYPE-200
        WRITE(6,900)IDTYPE
        STOP
21      CALL FRHIT
        RETURN
22      CALL FPHIT
        RETURN
23      CALL FQHIT
        RETURN
*     ********************   CALO  ******************
30    CONTINUE
      RETURN
*     ********************   PLUG  ******************
40    CONTINUE
      RETURN
*     ********************   BEMC  ******************
50    CONTINUE
      IF(LCONFG.LE.1) THEN
*......................................... configuration of 1992
       GOTO (51,52,53,51)IDTYPE-500
       WRITE(6,900)IDTYPE
51     CONTINUE
       RETURN
52     IF(CHARGE.NE.0..AND.INWVOL.EQ.1)CALL BTHIT
       RETURN
53     IF(CHARGE.NE.0.)CALL USRHIC('BRMT',NUMBV(NVNAME)-1)
       RETURN
      ELSE
*......................................... upgrade 1995
*>>       GOTO (151,151,151,151,154)IDTYPE-500
*>> add BToF for 1995
       GOTO (151,70,151,151,154)IDTYPE-500
       WRITE(6,900)IDTYPE
151    CONTINUE
       RETURN
154    IF(CHARGE.NE.0.)CALL HDHIT
       RETURN
      ENDIF
*     ********************   IRON  ******************
60    IF(CHARGE.EQ.0.)RETURN
      IF(INWVOL.EQ.1)THEN
        VSPOT(1)=VECT(1)
        VSPOT(2)=VECT(2)
        VSPOT(3)=VECT(3)
      ELSE IF(INWVOL.EQ.2.OR.ISTOP.NE.0)THEN
        VSPOT(4)=VECT(1)
        VSPOT(5)=VECT(2)
        VSPOT(6)=VECT(3)
        IF(ISRBNK(6).EQ.1) THEN
          CALL IDEPO(VSPOT,VECT(7))
        ENDIF
      ENDIF
      RETURN
*     ********************   FWFE  ******************
70    IF(IDTYPE.EQ.1001
     +  .OR.IDTYPE.EQ.1101.OR.IDTYPE.EQ.1102
     +  .OR.IDTYPE.EQ.1005.OR.IDTYPE.EQ.1009
     +  .OR.IDTYPE.EQ.502.OR.IDTYPE.EQ.1221) THEN
*       proton tagger or FToF (P.Biddulph)
*       or Roman pots (H. Mahlke-Krueger)
*       or BToF for 1995 (V.Shekelyan)
*       or neutron counter (O.Duenger)
*       or FTS (V.Solochenko)
          CALL JHIT
          RETURN
      ELSE
*       forward muon spectrometer
          IF(CHARGE.EQ.0.) RETURN
          GOTO(71,72),IDTYPE-700
          WRITE(6,900)IDTYPE
          STOP
71        CALL MTPHIT('MRTT')
          RETURN
72        CALL MTPHIT('MRPT')
          RETURN
      ENDIF
*     ********************   LUMI  ******************
80    GOTO(81,82,83,84),IDTYPE-800
      WRITE(6,900)IDTYPE
      STOP
81    IFOK=-200
      CALL LEHIT(VECT(7),-VECT(1),VECT(2),IFOK)
      RETURN
82    CALL LPHIT(VECT(7),-VECT(1),VECT(2))
      RETURN
83    CALL LVHIT
      RETURN
84    IFOK=0
c************************************************************
c please note I commented this to get rid of an unresolved to
c test the new code. This is NOT for export back into CMZ!!
c Girish.   
c************************************************************
c      CALL LE1HIT(VECT(7),-VECT(1),VECT(2),IFOK)
      RETURN
900   FORMAT(' ***GEDEPO*** illegal IDTYPE:',I5)
      END
*CMZ :          17/11/98  13.07.59  by  Girish D. Patel
*CMZU:  2.14/02 10/08/93  20.45.43  by  Vladimir Shekelyan
*CMZU:  2.10/13 13/12/92  20.40.54  by  Alexander Fedotov
*CMZU:  2.08/04 16/09/92  15.23.26  by  Stephan Egli
*CMZ :  2.07/00 26/03/92  08.10.40  by  Stephan Egli
*CMZU:  2.05/02 11/12/91  18.18.49  by  Stephan Egli
*CMZU:  2.05/00 01/11/91  16.31.18  by  Stephan Egli
*CMZU:  2.03/00 26/06/91  18.56.01  by  Stephan Egli
*CMZ :  2.00/00 10/02/91  09.08.52  by  Stephan Egli
*CMZ :  1.08/02 06/02/91  17.24.01  by  Stephan Egli
*-- Author :
      SUBROUTINE GUGEOM
*#**********************************************************************
*#                                                                     *
*#     SUBROUTINE GUGEOM                                               *
*#                                                                     *
*# PURPOSE: Define H1 detector geometry and constants                  *
*#                                                                     *
*# CALLED BY : GUINIT                                                  *
*#                                                                     *
*# AUTHOR : Girish D. Patel                                            *
*#                                                                     *
*# CHANGED BY: GIRISH D. PATEL    AT: 5/8/89                           *
*# REASON : CALL TO UDFPAR INSERTED                                    *
*#                                                                     *
*# CHANGED BY: S.EGLI             AT: 14/12/89                         *
*# REASON : ORDER THE BEAM PIPE VOLUMES WITH A GSORD CALL              *
*#                                                                     *
*# CHANGED BY: S.EGLI             AT: 09/03/90                         *
*# REASON : draw stuff removed                                         *
*# CHANGED BY: A.Fedotov          AT: 01/12/92 (14/07/92)              *
*# REASON : Geometry definition from OGDJ added                        *
*# CHANGED BY: A.Fedotov          AT: 13/12/92 (07/09/92)              *
*# REASON : Call of JGEOM in muon branch added                         *
* changed by  V.Shekelyan                                  at 28.07.93 *
* reason: For upgrade 1995 (LCONFG=2) use OGVM,OGVB instead of OGDM,OGDB
*#**********************************************************************
*
*KEEP,H1DETC.
      PARAMETER (NSUBDE=8)
      COMMON /H1DETC/ NAMSUB(NSUBDE),ISGRAN(NSUBDE),ISRBNK(NSUBDE),
     1                ISDSBK(NSUBDE),ISTRKB(NSUBDE),ISTRKM(NSUBDE),
     1                SKECUT(NSUBDE+2)
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEEP,GCFLAG.
      COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN
     +        ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20),NEVENT,NRNDM(2)
      COMMON/GCFLAX/BATCH, NOLOG
      LOGICAL BATCH, NOLOG
C
      INTEGER       IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN
     +        ,IEOTRI,IEVENT,ISWIT,IFINIT,NEVENT,NRNDM
C
*KEEP,H1OSGO.
      COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12)
*KEND.
*
*KEEP,HROTM.
      PARAMETER ( LHROTM = 17 )
      COMMON /HROTM/ NHROT(0:LHROTM)
*KEND.
*
*   DEFINE H1 GENERAL MATERIAL CONSTANTS FROM OGMA BOS BANK
*
      CALL UGTBNK( 'OGMA', INDB )
      IF( INDB.LE.0 )          THEN
        WRITE(6,*) ' ** SUBR. GUGEOM ** OGMA BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFMAT( INDB )
      ENDIF
*
*   DEFINE H1 GENERAL TRACKING MEDIA PARAMETERS FROM OGME BOS BANK
*
      CALL UGTBNK( 'OGME', INDB )
      IF( INDB.LE.0 )          THEN
        WRITE(6,*) ' ** SUBR. GUGEOM ** OGME BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFMED( INDB )
      ENDIF
*
*   DEFINE H1 SPECIAL TRACKING MEDIA PARAMETERS FROM OGTP BOS BANK
*
*     CALL UGTBNK( 'OGTP', INDB )
*     IF( INDB.LE.0 )          THEN
*        WRITE(6,*) ' ** SUBR. GUGEOM ** OGTP BANK NOT FOUND ==> ',
*     +                              'Default values will be used'
*     ELSE
*       CALL UDFPAR( INDB )
*     ENDIF
*
*
*  DEFINE GEANT ROTATION MATRICES FROM OGRO BOS BANK
*
      CALL UGTBNK( 'OGRO', INDB )
      IF( INDB.LE.0 ) THEN
        WRITE(6,*) ' ** SUBR. GUGEOM **  OGRO BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        CALL UDFROT( INDB, NHROT, LHROTM )
      ENDIF
*
*   DEFINE GEOMETRY OF THE SET UP FROM OGDM BOS BANK
*   for upgrade 1995 OGVM bank is used
*
      IF(LCONFG.LE.1)THEN
        CALL UGTBNK( 'OGDM' , INDB )
      ELSE
        CALL UGTBNK( 'OGVM' , INDB )
      ENDIF
      IF( INDB.LE.0 ) THEN
        STOP
      ELSE
        CALL UDFVOL( INDB, NHROT, LHROTM )
      ENDIF
*
*   DEFINE GEOMETRY OF BEAM PIPE SET UP FROM OGDB BOS BANK
*   for upgrade 1995 OGVB bank is used
*
      IF(LCONFG.LE.1)THEN
        CALL UGTBNK( 'OGDB' , INDB )
      ELSE
        CALL UGTBNK( 'OGVB' , INDB )
      ENDIF
      IF( INDB.LE.0 ) THEN
        WRITE(6,*)' ** SUBR.GUGEOM ** OGDB(OGVB) BANK NOT FOUND => STOP'
        STOP
      ELSE
        CALL UDFVOL( INDB, NHROT, LHROTM )
      ENDIF
*
*     ORDER THE VOLUMES OF THE BEAM
*
      CALL GSORD('BEAM',3)
*
*   DEFINE GEOMETRY OF FORW. BEAMLINE (IN PLUG,FWFE) FROM OGDJ BOS BANK
*
c      CALL UGTBNK( 'OGDJ' , INDB )
c      IF( INDB.LE.0 ) THEN
c        WRITE(6,*) ' ** SUBR. GUGEOM **  OGDJ BANK NOT FOUND ==> STOP '
c        STOP
c      ELSE
c        CALL UDFVOL( INDB, NHROT, LHROTM )
c      ENDIF
*
*   DEFINE GEOMETRY OF COIL SET UP FROM OGDC BOS BANK
*
      CALL UGTBNK( 'OGDC' , INDB )
      IF( INDB.LE.0 ) THEN
        WRITE(6,*) ' ** SUBR. GUGEOM **  OGDC BANK NOT FOUND ==> STOP '
        STOP
      ELSE
        IF(ISGRAN(3).NE.0) CALL UDFVOL( INDB, NHROT, LHROTM )
      ENDIF
*
* Central Tracking
*
        IF (ISGRAN(1).NE.0)THEN
          WRITE(6,900)'CENT',ISGRAN(1)
          CALL CGEOM
        ENDIF
*
* Forward Tracking
*
        IF (ISGRAN(2).NE.0)THEN
          WRITE(6,900)'FWDT',ISGRAN(2)
          CALL FGEOM
        ENDIF
*
* Liquid Argon Calorimeter
*
        IF (ISGRAN(3).NE.0)THEN
          WRITE(6,900)'CALO',ISGRAN(3)
          CALL AGEOM
        ENDIF
*
* Plug Calorimeter
*
        IF (ISGRAN(4).NE.0)THEN
          WRITE(6,900)'PLUG',ISGRAN(4)
          CALL PGEOM
        ENDIF
*
* Backward Electromagnetic Calorimeter
*
        IF (ISGRAN(5).NE.0)THEN
         IF(LCONFG.LE.1) THEN
          WRITE(6,900)'BEMC',ISGRAN(5)
          CALL BGEOM
         ELSE
*.........upgrade 1995 (SPACal,BDC)
          WRITE(6,900)'SPAC',ISGRAN(5)
          CALL SGEOM
         ENDIF
        ENDIF
*
* Instrumented Iron
*
        IF (ISGRAN(6).NE.0)THEN
          WRITE(6,900)'IRON',ISGRAN(6)
          CALL IGEOM
        ENDIF
*
* Forward Muons
*    and the rest of Forward beam line with p tagger (z = 1177-2442)
*
        IF (ISGRAN(7).NE.0)THEN
          WRITE(6,900)'MUON',ISGRAN(7)
          CALL MGEOM
          CALL JGEOM
        ENDIF
*
* Luminosity  (proton beam line to -50 meters)
*
        IF (ISGRAN(8).NE.0)THEN
          WRITE(6,900)'LUMI',ISGRAN(8)
          CALL LGEOM
        ENDIF
*
*             Optimisation of geometry definition
*
*
*             Close geometry banks. Mandatory system routine.
*
      CALL GGCLOS

*      CALL BDROP(IW,'OGMAOGMEOGTPOGROOGDMOGDBOGDJOGDC')
*
900       FORMAT(' Creating geometry for subdetector ',A4,
     +           ' with granularity flag ',I1)

      RETURN
      END
*CMZU:          03/08/98  14.03.51  by  Stephen Burke
*CMZ :  4.06/28 06/12/96  13.44.27  by  Vladimir Shekelyan
*CMZU:  4.05/02 26/01/95  15.18.17  by  Martine Charlet
*CMZ :  4.04/05 10/11/94  20.59.30  by  Vladimir Shekelyan
*CMZU:  4.04/04 01/11/94  13.40.07  by  Benno List
*CMZU:  4.02/02 23/03/94  12.58.49  by  Stephan Egli
*CMZU:  4.00/08 08/12/93  16.31.48  by  Stephan Egli
*CMZU:  4.00/05 22/11/93  14.12.19  by  Stephan Egli
*CMZU:  3.04/06 13/08/93  09.34.07  by  Vladimir Shekelyan
*CMZ :  3.01/06 16/09/92  15.57.31  by  Stephan Egli
*CMZ :  2.09/01 30/03/92  15.11.43  by   Michael Colombo
*CMZ :  2.08/01 26/03/92  12.05.10  by  Stephan Egli
*CMZ :  2.07/00 17/12/91  11.29.18  by  Stephan Egli
*CMZ :  2.03/05 09/09/91  19.19.48  by  Stephan Egli
*CMZU:  2.03/00 13/06/91  14.04.01  by  Michael Kuhlen
*CMZU:  2.02/00 07/06/91  14.17.54  by  M. Erdmann
*CMZ :  2.00/00 10/02/91  09.25.00  by  Stephan Egli
*CMZ :  1.08/02 05/02/91  11.03.13  by  Stephan Egli
*-- Author :
      SUBROUTINE H1PRNT(NAME,NR)
*********************************************************************
*
*     PRINTOUT OF H1 SIMULATION BANK
*     ==============================
*
*     BANKS INCLUDED UP TO NOW ARE:
*
*     ARHT, AEHT, ARDT, AEDT, ARWT, AEWT, AS  , ARCE, AECE, ARCX
*
*     BRMT, BRCT, BRTT, BS  , BRME, BRCE, BRTE, BRCX
*
*     CRJT, CRJF, CRYT, CRZT, CRMT, CS  , CRJE, CRME, CRYE, CRZE,
*     CRYX, CRZX
*
*     FRPT, FRPF, FRRT, FRRF, FRMT, FRTT, FS  , FRME, FRPE, FRRE,
*     FRPN, FRRN, FRPH, FRRH, FRPX, FRRX,
*     FRQT, FRQF, FRQE, FRQN, FRQH, FRQX
*
*     GTR , GVX , GEVC
*
*     IRHT, IS  , IL  , IRSE, IRTE, IRWE
*
*     JSPT, JSRP, JSFT, JRHT, JRDT, JRDE
*
*     LRET, LRPT, LRVT, LS  , LREE, LRPE
*
*     MS  , ML
*
*     PRDT, PS  , PRDE, PRDX
*
*     SHD , STR , SVX
*
*     MODS, MODI, MODO
*
*     ExEG, ExSG, ExNG, ExFR, ExFX      (x=A,B,P,I,W)
*
*     RCLX, ECLX, ECLC
*
*     SRCT, SRCE, SRCX
*
*     04.04.1990            RALF GERHARDS
*
*     CHANGED  05.04.1990   RG      ADD BANKS GHD  AND GKI
*     CHANGED  12.04.1990   RG      ADD BANK  LRTE
*     CHANGED  26.04.1990   RG      ADD BANKS TRIP, TRAK, CACE, CCEG,
*                                   MUON, LTL1, TTSE
*     CHANGED  02.05.1990   RG      ADD BANK  HEAD
*                                   CALL P.SCHLEPER'S MYPRNT IF BANK
*                                   IS NOT KNOWN TO CURRENT BANK LIST
*     CHANGED  01.07.1990   SE      FORWARD MUON BANKS ADDED
*                                   MRPE, MRTE, MRPX, MRTX
*                                   MRPN, MRPT, MRTN, MRTT
*     CHANGED  05.07.1990   RG      BUG FIXED IN FUNCTION PDGNAM, GOT
*                                   SOMETIMES WRONG PARTICLE NAMES
*                                   FOR L.AR. BANKS SCALE AND GAIN
*                                   FACTORS TAKEN INTO ACCOUNT
*     CHANGED  05.09.1990   SE      MODUL STEERING BANKS MODS/I/O ADDED
*     CHANGED  16.05.1991   MK      perf. energ. (ARHT,PRDT,BRCT,ARWT)
*     CHANGED  07.06.1991   ME      ADD PRINT GEVC BANK
*     CHANGED  11.06.1991   MK      protection against old bank formats
*     CHANGED  13.06.1991   MK      print more bits in ITRHIS
*     CHANGED  20.08.1991   MK      add calibr. energy and cluster banks
*     CHANGED  12.12.1991   PL      new format GTR, GKI, GHD
*     CHANGED  28.02.1992   PL      new printout GTR and GHD
*     CHANGED  30.03.1992   MCo     both parents in GTR
*     CHANGED  12.08.1993   VSh     upgrade 1995: SRCT (Spacal)
*     CHANGED  24.10.1994   VSh     add SRCE,SRCX banks
*                           BL      print GHD bank with >1 row,
*                                   add JSPT,JSRP,JRHT,JRDT,JRDE banks
*     CHANGED   1.11.1994   BL      add JSFT bank
*     CHANGED  29.12.1995   GG      new printout GKI
*     CHANGED  29.07.1998   SB      add FxQx banks for new planar chambers
*********************************************************************
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
      PARAMETER (ISCALA=50,ISCALD=500,NBMAX=124)
      CHARACTER*4  NAME, BKNAME(NBMAX), CHAINT
      CHARACTER*10 PTYP(8), PDGNAM*13, VTYP(5)
      INTEGER BKFORM(NBMAX), ID1(10)
      COMMON /COTEMP/ID, ID2, ID1
      INTEGER IBIT(14)
C
C.... OUTPUT UNIT
C
      DATA LUN/6/
C
      DATA BKNAME/'SHD ','STR ','SVX ','GTR ','GVX ','GKI ','GHD ',
     *     'HEAD','GEVC',
     *     'CRJT','CRJF','CRYT','CRZT','CRMT','CS  ',
     *     'CRJE','CRME','CRYE','CRZE','CRYX','CRZX','CRJX','CRMX',
     *     'FRPT','FRPF','FRRT','FRRF','FRMT','FRTT','FS  ',
     *     'FRME','FRPE','FRRE','FRPN','FRRN','FRPH','FRRH',
     *     'FRPX','FRRX','FRMX',
     *     'FRQT','FRQF','FRQE','FRQN','FRQH','FRQX',
     *     'ARHT','AEHT','ARDT','AEDT','ARWT','AEWT','AS  ',
     *     'AECE','AEDE','ARCE','ARDE','ARCX','ATES','ATBE',
     *     'BRMT','BRCT','BRTT','BS  ',
     *     'BRME','BRCE','BRTE','BRMX','BRCX','BRTX',
     *     'IRHT','IS  ','IL  ',
     *     'IRSE','IRTE','IRWE','IRSX','IRTX','IRWX',
     *     'JSPT','JSRP','JSFT','JRHT','JRDT','JRDE',
     *     'LRET','LRPT','LRVT','LS  ',
     *     'LREE','LRPE','LRTE','LREX','LRPX','LRVX',
     *     'MS  ','ML  ','MRPE','MRTE','MRPX','MRTX',
     *     'MRPN','MRPT','MRTN','MRTT',
     *     'PRDT','PS  ','PRDE','PRDX',
     *     'TRIP','TRAK','CACE','CCEG','MUON',
     *     'TTSE','LTL1','TEL1',
     *     'MODS','MODI','MODO','MODC',
     *     'SRCT','SRCE','SRCX'/
      DATA BKFORM/  1   ,  2   ,  3   ,  4   ,  5   ,100   ,100   ,
     *     100   ,100   ,
     *       6   ,  7   ,  8   ,  8   ,  9   , 19   ,
     *     -23   ,-24   ,-25   ,-23   ,-32   ,-32   ,-32   ,-32   ,
     *      10   , 11   ,  6   ,  7   ,  9   , 10   , 19   ,
     *     -24   ,-25   ,-25   , 26   , 26   , 27   , 28   ,
     *     -29   ,-29   ,-99   ,
     *      10   , 11   ,-25   , 26   , 27   ,-29   ,
     *     -12   ,-12   ,-12   ,-12   ,-12   ,-12   , 19   ,
     *     -20   ,-99   ,-20   ,-99   ,-32   ,-43   , -45  ,
     *       9   ,-14   , 15   , 19   ,
     *     -24   ,-21   ,-22   ,-99   ,-32   ,-99   ,
     *     -16   , 19   , 19   ,
     *     -30   ,-31   ,-30   ,-99   ,-99   ,-99   ,
     *      19   , 46   , 46   ,-47   ,-47   ,-48   ,
     *     -17   ,-17   ,-18   , 19   ,
     *     -21   ,-21   ,-34   ,-99   ,-99   ,-99   ,
     *      19   , 19   ,-25   ,-25   ,-29   ,-29   ,
     *      26   , 10   , 26   , 10   ,
     *     -13   , 19   ,-21   ,-32   ,
     *      35   , 35   , 36   , 36   , 37   ,
     *      38   ,-34   , 44   ,
     *      39   , 40   , 40   ,41    ,
     *     -42   ,-20   ,-32/
C
      DATA PTYP /' undecayed','  reserved','decay/frag',' document.',
     *           '  reserved',' undefined','beam part.','rad. gamma'/
C
      DATA VTYP /'   primary','     decay',' bremsstr.',
     *           'conversion','      else'/
C
C.... STATEMENT FUNCTIONS
C
C.... INDEX OF ELEMENT BEFORE ROW NUMBER IROW
      INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1)
C.... INDEX OF L-TH ELEMENT OF ROW NUMBER IROW
      INDCR(IND,L,IROW)=INDR(IND,IROW)+L
C.... L-TH INTEGER ELEMENT OF THE IROW-TH ROW IN BANK WITH INDEX IND
      IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW))
C.... L-TH REAL ELEMENT OF THE IROW-TH ROW IN BANK WITH INDEX IND
      RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW))
C
C.... STATEMENT FUNCTIONS FOR IRON HIT BANK DECODING
C
      FX(I)=FLOAT(I)/20.-600.
      FY(I)=FLOAT(I)/20.-600.
      FZ(I)=FLOAT(I)/20.-500.
C
C.... STATEMENT FUNCTIONS FOR LUMI HIT BANK DECODING
C
      FL(I)=FLOAT(I)*0.001-10.
C
C.... INITIALIZE LUND COMMONS WITH PARTICLE NAMES
C
C.... END OF INITIALISATION
C
C  first deal with calibrated energy banks etc.

      IF( NAME.EQ.'EAEG' .OR. NAME.EQ.'EASG' .OR. NAME.EQ.'EANG' .OR.
     &    NAME.EQ.'EAFR' .OR. NAME.EQ.'EAFX'                     .OR.
     &    NAME.EQ.'EBEG' .OR. NAME.EQ.'EBSG' .OR. NAME.EQ.'EBNG' .OR.
     &    NAME.EQ.'EBFR' .OR. NAME.EQ.'EBFX'                     .OR.
     &    NAME.EQ.'EPEG' .OR. NAME.EQ.'EPSG' .OR. NAME.EQ.'EPNG' .OR.
     &    NAME.EQ.'EPFR' .OR. NAME.EQ.'EPFX'                     .OR.
     &    NAME.EQ.'EIEG' .OR. NAME.EQ.'EISG' .OR. NAME.EQ.'EING' .OR.
     &    NAME.EQ.'EIFR' .OR. NAME.EQ.'EIFX'                     .OR.
     &    NAME.EQ.'EWEG' .OR. NAME.EQ.'EWSG' .OR. NAME.EQ.'EWNG' .OR.
     &    NAME.EQ.'EWFR' .OR. NAME.EQ.'EWFX') THEN
        CALL PREXEG(NAME,NR)
        RETURN
      ELSEIF( NAME.EQ.'RCLX' .OR. NAME.EQ.'ECLX' ) THEN
        CALL PRRCLX(NAME,NR)
        RETURN
      ELSEIF( NAME.EQ.'ECLC' ) THEN
        CALL PRECLC(NAME,NR)
        RETURN
      ENDIF

C.... SEARCH FOR REQUIRED BANK
C
      IBKFMT = 0
      DO 10 I = 1, NBMAX
         IF(NAME.NE.BKNAME(I)) GOTO 10
         IBKFMT = BKFORM(I)
         GOTO 20
10    CONTINUE
      GOTO 9010
C
20    CONTINUE
C
C.... FETCH REQUIRED BANK
C.... COPY TO WORK BANK IF FORMAT 'B16'
C
      IND = NLINK(NAME,NR)
      IF(IND.EQ.0) GOTO 9000
C
      IF(IBKFMT.LT.0) THEN
         ID=0
         CALL BKTOW(IW,NAME,NR,IW,ID,*9000)
         NROW = IW(ID+2)
         NCOL = IW(ID+1)
         NLEN = IW(ID)
         WRITE(LUN,1300) NAME, NR, NLEN, NCOL, NROW
      ELSE
C
C....... SPECIAL FORMATS (WITHOUT MINIHEADER)
C
         IF(IBKFMT.GE.100) THEN
            WRITE(LUN,1900) NAME, NR
            GOTO 500
         ELSE
            NCOL = IW(IND+1)
            NROW = IW(IND+2)
            NLEN = IW(IND)
            WRITE(LUN,1300) NAME, NR, NLEN, NCOL, NROW
         END IF
      END IF
C
C.... CHECK ON BANK LENGTH
C
      NTEST=NCOL*NROW+2
      IF(NTEST.NE.NLEN .AND. NTEST.NE.NLEN-1) THEN
         WRITE(LUN,1500)
         WRITE(LUN,1400)
      END IF
C
C.... PRINTOUT
C
      GOTO (101,102,103,104,105,106,107,108,109,110,111,112,113,
     *      114,115,116,117,118,119,120,121,122,123,124,125,126,
     *      127,128,129,130,131,132,133,134,135,136,137,138,139,
     *      140,141,142,143,144,145,146,147,148)
     *      IABS(IBKFMT)
C
      WRITE(LUN,1200) NAME
      WRITE(LUN,1400)
      RETURN
C
C.... 'SHD '
C
101   WRITE(LUN,1400)
      WRITE(LUN,10101) (CHAINT(IBTAB(IND,1,I)),
     *      RBTAB(IND,2,I), I=1,NROW)
10101 FORMAT(/,((7X,'MODULE NAME  ',A4,'      VERSION NUMBER ',
     *       F6.4,/)),1H+)
      GOTO 200
C
C.... 'STR '
C
102   WRITE(LUN,1400)
      WRITE(LUN,10201)
      WRITE(LUN,10202) (I,RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I), RBTAB(IND,4,I),
     *      PDGNAM(IBTAB(IND,5,I)), IDUAL(IBTAB(IND,6,I),7),
     *      IBTAB(IND,7,I), IBTAB(IND,8,I), IBTAB(IND,9,I),
     *      I=1, NROW)
10201 FORMAT(9X,'           MOMENTUM (GEV)            ENERGY ',
     *       ' PARTICLE TYPE   ITRHIS    LINK  TO    LINK  TO  ',
     *       '  LINK  TO  ',/,
     *       9X,'      PX         PY         PZ        (GEV) ',
     *       '                LMIBPAFC  PARENT,STR  PARENT,GTR ',
     *       ' VERTEX,SVX',/,1X,130('-'),/)
10202 FORMAT((3X,I3,2X,4(1X,F10.3),2X,A13,2X,I8,3(I10,2X)))
      GOTO 200
C
C.... 'SVX '
C
103   WRITE(LUN,1400)
      WRITE(LUN,10301)
      WRITE(LUN,10302) (I,RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      VTYP(IBTAB(IND,4,I)), (1.0E+09*RBTAB(IND,5,I)),
     *      IDUAL(IBTAB(IND,6,I),7), IBTAB(IND,7,I), I=1 ,NROW)
10301 FORMAT(9X,'       VERTEX COORDINATES (CM)       VERTEX',
     *       '     TIME OF     ITRHIS     LINK  TO ',/,
     *       9X,'       X          Y          Z        TYPE ',
     *       '   FLIGHT (NS)  LMIBPAFC   PARENT,STR',/,
     *           1X,130('-'),/)
10302 FORMAT((3X,I3,2X,3(1X,F10.3),1X,A,1X,F10.3,5X,I8,5X,I6))
      GOTO 200
C
C.... 'GTR '
C
104   WRITE(LUN,1400)
      WRITE(LUN,10401)
      DO 10410 I = 1, NROW
        IPATYP  = ABS( 1+IBTAB(IND,8,I) )
        IF( IPATYP-1 .GT. 3 .AND. IPATYP .LE. 10 ) IPATYP  = 5
        IF( IPATYP-1 .GT. 10 .AND. IPATYP .LE. 200 ) IPATYP  = 6
        IF( IPATYP-1 .EQ. 201 ) IPATYP  = 7
        IF( IPATYP-1 .EQ. 202 ) IPATYP  = 8
        IMOTH1 = IBTAB(IND,9,I)-(IBTAB(IND,9,I)/10000)*10000
        IMOTH2 = IBTAB(IND,9,I)/10000
        WRITE(LUN,10402) I, PDGNAM(IBTAB(IND,7,I)), PTYP(IPATYP),
     *        IMOTH1, IMOTH2, RBTAB(IND,1,I), RBTAB(IND,2,I),
     *        RBTAB(IND,3,I), RBTAB(IND,4,I), RBTAB(IND,5,I),
     *        RBTAB(IND,6,I), IBTAB(IND,10,I)
10410 CONTINUE
10401 FORMAT(2X,'    PARTICLE    PARTICLE     PARENT  ',
     *       '        MOMENTUM (GEV)         ENERGY  ',
     *       '     MASS     CHARGE  LINK  TO  ',/,
     *       2X,'    TYPE        FLAG        PARTICLE  ',
     *       '   PX        PY        PZ      (GEV)  ',
     *       '    (GEV)             VERTEX,GVX ',/,1X,130('-'),/)
10402 FORMAT((1X, I3, 2X, A12, A10, 2(1X,I3), 4(1X,F9.3),
     *        2(1X,F10.4), 2X, I5))
      GOTO 200
C
C.... 'GVX '
C
105   WRITE(LUN,1400)
      WRITE(LUN,10501)
      WRITE(LUN,10502) (I,RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I), VTYP(IBTAB(IND,4,I)),
     *      (1.0E+09*RBTAB(IND, 5,I)), I=1, NROW)
10501 FORMAT(9X,'      VERTEX  COORDINATES  (CM)      VERTEX',
     *       '     TIME OF  ',/,
     *       9X,'       X          Y          Z         TYPE',
     *       '   FLIGHT (NS)',/,1X,130('-'),/)
10502 FORMAT((3X,I3,2X,3(1X,F10.3),1X,A10,1X,F10.3))
      GOTO 200
C
C.... 'CRJT', 'FRRT'
C
106   WRITE(LUN,1400)
      WRITE(LUN,10601)
      WRITE(LUN,10602) (I,IBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I),
     *      RBTAB(IND,7,I), RBTAB(IND,8,I), IDUAL(IBTAB(IND,9,I),7),
     *      IBTAB(IND,10,I), I=1, NROW)
10601 FORMAT(1H0,8X,'  CHANNEL           ENTRY POINT  (CM)        ',
     *       '        EXIT POINT (CM)             DRIFT   ',
     *       '   ITRHIS      TRACK  ',/,
     *           9X,'   NUMBER        X          Y          Z     ',
     *       '     X          Y          Z     LENGTH (CM)',
     *       '  LMIBPAFC  NUMBER,STR',/,1X,130('-'),/)
10602 FORMAT((2X,I4,3X,I7,3X,7(1X,F10.3),4X,I8,2X,I8))
      GOTO 200
C
C.... 'CRJF', 'FRRF'
C
107   WRITE(LUN,1400)
      WRITE(LUN,10701)
      WRITE(LUN,10702) (I,RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I),
     *      RBTAB(IND,7,I), RBTAB(IND,8,I), RBTAB(IND,9,I),
     *      RBTAB(IND,10,I), RBTAB(IND,11,I), RBTAB(IND,12,I),
     *      RBTAB(IND,13,I), RBTAB(IND,14,I),
     *      PDGNAM(IBTAB(IND,15,I)),
     *      IDUAL(IBTAB(IND,16,I),7), IBTAB(IND,17,I), I=1, NROW)
10701 FORMAT(7X,' ENTRY POINT  (CM)  ',
     *       '    ENTRY MOMENTUM  (GEV)   ',
     *       '   EXIT POINT (CM)  ',
     *       '    EXIT MOMENTUM   (GEV)   ',
     *       '   PARTICLE   ITRHIS   TRACK',/,
     *       7X,'  X      Y      Z   ',
     *       '   PX/P   PY/P   PZ/P    P  ',
     *       '   X      Y      Z  ',
     *       '    PX/P   PY/P   PZ/P    P ',
     *       '    type       LMIBPAFC   NO.',/,1X,130('-'),/)
10702  FORMAT((2X,I4,14(F7.2),1X,A13,I8,I5))
      GOTO 200
C
C.... 'CRYT', 'CRZT'
C
108   WRITE(LUN,1400)
      WRITE(LUN,10801)
      WRITE(LUN,10802) (I,RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I),
     *      IDUAL(IBTAB(IND,7,I),7), IBTAB(IND,8,I), I=1, NROW)
10801 FORMAT(9X,'         ENTRY POINT  (CM)        ',
     *       '         EXIT POINT (CM)       ',
     *       '   ITRHIS      TRACK   ',/,
     *       9X,'      X          Y          Z     ',
     *       '     X          Y          Z   ',
     *       '  LMIBPAFC   NUMBER,STR',/,1X,130('-'),/)
10802 FORMAT((2X,I4,2X,6(1X,F10.3),2X,I8,6X,I5))
      GOTO 200
C
C.... 'CRMT', 'FRMT', 'BRMT'
C
109   WRITE(LUN,1400)
      WRITE(LUN,10901)
      WRITE(LUN,10902) (I,IBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I),
     *      RBTAB(IND,7,I), IDUAL(IBTAB(IND,8,I),7), IBTAB(IND,9,I),
     *      I=1, NROW)
10901 FORMAT(9X,'   CHAMBER          ENTRY POINT  (CM)        ',
     *       '         EXIT POINT (CM)      ',
     *       '   ITRHIS     TRACK   ',/,
     *       9X,'    NUMBER       X          Y          Z     ',
     *       '     X          Y          Z  ',
     *       '  LMIBPAFC  NUMBER,STR',/,1X,130('-'),/)
10902 FORMAT((2X,I4,3X,I7,3X,6(1X,F10.3),1X,I8,5X,I5))
      GOTO 200
C
C.... 'FRPT', 'FRTT', 'MRPT', 'MRTT'
C
110   WRITE(LUN,1400)
      WRITE(LUN,11001)
      WRITE(LUN,11002) (I, IBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      RBTAB(IND,4,I), RBTAB(IND,5,I),RBTAB(IND,6,I),
     *      RBTAB(IND,7,I), (RBTAB(IND,8,I)*1000.),
     *      IDUAL(IBTAB(IND,9,I),7),
     *      IBTAB(IND,10,I), I=1, NROW)
11001 FORMAT(9X,'    CELL            ENTRY POINT  (CM)        ',
     *       '         EXIT POINT (CM)            ENERGY   ',
     *       '   ITRHIS      TRACK  ',/,
     *       9X,'   NUMBER        X          Y          Z     ',
     *       '     X          Y          Z      LOSS (MEV) ',
     *       '  LMIBPAFC  NUMBER,STR',/,1X,130('-'),/)
11002 FORMAT((2X,I4,3X,I8,2X,6(1X,F10.3),1X,F10.5,5X,I8,2X,I8))
      GOTO 200
C
C.... 'FRPF'
C
111   WRITE(LUN,1400)
      WRITE(LUN,11101)
      WRITE(LUN,11102) (I, RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I),
     *      RBTAB(IND,7,I), RBTAB(IND,8,I), RBTAB(IND,9,I),
     *      RBTAB(IND,10,I), RBTAB(IND,11,I), RBTAB(IND,12,I),
     *      RBTAB(IND,13,I), RBTAB(IND,14,I),
     *      PDGNAM(IBTAB(IND,15,I)),
     *      IBTAB(IND,16,I), IDUAL(IBTAB(IND,17,I),7), IBTAB(IND,18,I),
     *      I=1, NROW)
11101 FORMAT(7X,'  ENTRY POINT  (CM)  ',
     *       ' ENTRY MOMENTUM  (GEV)   ',
     *       '   EXIT POINT (CM)   ',
     *       '  EXIT MOMENTUM (GEV)    ',
     *       '  PARTICLE  CELL  ITRHIS   TRACK',/,
     *       7X,'   X      Y      Z   ',
     *       ' PX/P  PY/P  PZ/P    P   ',
     *       '   X      Y      Z   ',
     *       ' PX/P  PY/P  PZ/P    P   ',
     *       '    TYPE    NUMB   LMIBPAFC  NO.',/,
     *           1X,130('-'),/)
11102 FORMAT((2X,I4,3F7.2,3F6.2,4F7.2,3F6.2,F7.2,1X,A13,I5,1X,I8,I5))
      GOTO 200
C
C.... 'ARHT' ('AEHT'), 'ARDT' ('AEDT'), 'ARWT' ('AEWT')
C     FETCH PARALLEL BANKS
C
112   CONTINUE
      ID2=0
      IF(NAME.EQ.'ARHT')THEN
         CALL BKTOW(IW,'AEHT',0,IW,ID2,*9020)
         WRITE(LUN,1800) 'AEHT'
      ELSE IF(NAME.EQ.'ARDT') THEN
         CALL BKTOW(IW,'AEDT',0,IW,ID2,*9020)
         WRITE(LUN,1800) 'AEDT'
      ELSE IF(NAME.EQ.'ARWT') THEN
         CALL BKTOW(IW,'AEWT',0,IW,ID2,*9020)
         WRITE(LUN,1800) 'AEWT'
      ENDIF
C
      IF(NAME.EQ.'AEHT') THEN
         WRITE(LUN,1800) 'AEHT'
         GOTO 200
      ELSE IF(NAME.EQ.'AEDT') THEN
         WRITE(LUN,1800) 'AEDT'
         GOTO 200
      ELSE IF(NAME.EQ.'AEWT') THEN
         WRITE(LUN,1800) 'AEWT'
         GOTO 200
      ENDIF
C
      WRITE(LUN,1400)
      WRITE(LUN,11201)
      DO 11200 I = 1, NROW
         ITRHIS = IBTAB(ID,3,I)
         CALL IDUAL1( ITRHIS, 14, 1, IBIT )
         IENER  = IFRB16(IBTAB(ID,2,I))
         IENERE = IFRB16(IBTAB(ID2,1,I))
         IF( NCOL.GE.6 ) THEN
             IEINV  = IFRB16(IBTAB(ID,5,I))*ISCALD
             IEEM   = IFRB16(IBTAB(ID,6,I))*ISCALD
         ELSE
             IEINV = 0
             IEEM  = 0
         ENDIF
         IF(NAME.EQ.'ARWT') THEN
            IENER  = IENER*ISCALD
            IENERE = IENERE*ISCALD
            CALL NWSOFT(IBTAB(ID,1,I),MM,NN,LL,II,JJ,KK,IFL)
            WRITE(LUN,11202) I, IBTAB(ID,1,I), MM, NN, LL, II,
     *         JJ, KK, FLOAT(IENER)/1.E3,
     *         IBIT,IBTAB(ID,4,I),FLOAT(IENERE)/1.E3,
     *         FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3
         ELSE
            IENER  = IENER*ISCALA
            IENERE = IENERE*ISCALA
            IF( NCOL.GE.8 ) THEN
                IEHAD  = IFRB16(IBTAB(ID,7,I))*ISCALD
                IEHVIS = IFRB16(IBTAB(ID,8,I))*ISCALD
            ELSE
                IEHAD = 0
                IEHVIS= 0
            ENDIF
            CALL NBSOFT(IBTAB(ID,1,I),MM,NN,LL,II,JJ,KK,IFL)
            WRITE(LUN,11202) I, IBTAB(ID,1,I), MM, NN, LL, II,
     *         JJ, KK, FLOAT(IENER)/1.E3,
     *         IBIT,IBTAB(ID,4,I),FLOAT(IENERE)/1.E3,
     *         FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3,
     *         FLOAT(IEHAD)/1.E3, FLOAT(IEHVIS)/1.E3
         END IF
11200 CONTINUE
11201 FORMAT(6X,'          CHANNEL  NUMBER           ENERGY',
     *          '           ITRHIS    TRACK  ',
     *       'ELECTROMAGNETIC          PERFECT ENERGIES (MeV)',/,
     *       6X,'   CONT   MM  NN  LL  II  JJ  KK    (MEV) ',
     *          '          LMIBPAFC  NUMBER  ',
     *       'ENERGY   (MEV)  ',
     *       '     Einv','      Eem','     Ehad','   Ehavis'
     *       /,1X,130('-'),/)
11202 FORMAT((2X,I4,I7,1X,6I4,3X,F7.2,1X,3X,14I1,I7,3X,F10.2,6x,4F9.1))
C
C.... DROP WORK BANK
C
      CALL WDROP(IW,ID2)
      GOTO 200
C
C.... 'PRDT'
C
113   WRITE(LUN,1400)
      WRITE(LUN,11301)
      DO 1023 I = 1, NROW
         ITRHIS = IBTAB(ID,3,I)
         CALL IDUAL1( ITRHIS, 14, 1, IBIT )
         IF( NCOL.GE.8 ) THEN
            IEINV =  IFRB16(IBTAB(ID,5,I))*ISCALD
            IEEM  =  IFRB16(IBTAB(ID,6,I))*ISCALD
            IEHAD =  IFRB16(IBTAB(ID,7,I))*ISCALD
            IEHVIS=  IFRB16(IBTAB(ID,8,I))*ISCALD
         ELSE
            IEINV = 0
            IEEM  = 0
            IEHAD = 0
            IEHVIS= 0
         ENDIF
         WRITE(LUN,11302) I,IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I)),
     *   IBIT, IBTAB(ID,4,I),
     *   FLOAT( IEINV )/1000.,
     *   FLOAT( IEEM  )/1000.,
     *   FLOAT( IEHAD )/1000.,
     *   FLOAT( IEHVIS)/1000.
 1023 CONTINUE
11301 FORMAT(1H0,8X,'  CHAMBER    ENERGY',
     *       '            ITRHIS       TRACK  ',
     *       '         perfect energies (MeV)       ',/,
     *    9X,'   NUMBER                     LMIBPAFC     NUMBER  ',
     *       '     Einv','      Eem','     Ehad','   Ehavis',/,
     *       1X,130('-'),/)
11302 FORMAT((2X,I4,3X,I7,4X,I7,3X,3X,14I1,3X,I7,3X,4F9.1))
      GOTO 200
C
C.... 'BRCT'
C
114   WRITE(LUN,1400)
      WRITE(LUN,11401)
      DO 1024 I = 1, NROW
         ITRHIS = IBTAB(ID,16,I)
         CALL IDUAL1( ITRHIS, 14, 1, IBIT )
         WRITE(LUN,11402) I, IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I)),
     *   IFRB16(IBTAB(ID,3,I)),IFRB16(IBTAB(ID,4,I)),
     *   IFRB16(IBTAB(ID,5,I)),IFRB16(IBTAB(ID,6,I)),
     *   IFRB16(IBTAB(ID,7,I)),IFRB16(IBTAB(ID,8,I)),
     *   IFRB16(IBTAB(ID,9,I)),
     *   IBTAB(ID,10,I)-1000, IBTAB(ID,11,I)-1000,
     *   IBTAB(ID,12,I)-3000, IBTAB(ID,13,I)-1000,
     *   IBTAB(ID,14,I)-1000, IBTAB(ID,15,I)-3000,
     *   IBIT, IBTAB(ID,17,I)
 1024 CONTINUE
11401 FORMAT(6X,' STACK ',
     *       ' ENERG. FR. 6 WAVEL SHIFT (MEV)',
     *       '   ENERGIES     CENT. OF GRAV.  (MM)',
     *       '   C.O.G.   HADRONS  ',
     *       '          ITRHIS TRACK',/,
     *       6X,'NUMBER ',
     *       '  1    2    3    4    5    6   ',
     *       ' TOTAL  HADR.   X+XOFF Y+YOFF Z+ZOFF',
     *       ' X+XOFF Y+YOFF Z+ZOFF',
     *       '         LMIBPAFC  NO.',/,
     *           1X,130('-'),/)
11402 FORMAT((1X,I4,I5,1X,6I5,3X,I5,I6,3X,6I7,3X,14I1,I4))
      IF( NCOL.GE.21 ) THEN
          WRITE(LUN,11403)
          WRITE(LUN,11404)(I,
     *      FLOAT( IFRB16(IBTAB(ID,18,I))*ISCALD )/1000.,
     *      FLOAT( IFRB16(IBTAB(ID,19,I))*ISCALD )/1000.,
     *      FLOAT( IFRB16(IBTAB(ID,20,I))*ISCALD )/1000.,
     *      FLOAT( IFRB16(IBTAB(ID,21,I))*ISCALD )/1000.,
     *      I=1,NROW )
      ENDIF
11403 FORMAT(1H0,4X,
     *       '         perfect energies (MeV)       ',/,
     *        5X,'     Einv','      Eem','     Ehad','   Ehavis',/,
     *       1X,130('-'),/)
11404 FORMAT((1X,I4,4F9.1))
      GOTO 200
C
C.... 'BRTT'
C
115   WRITE(LUN,1400)
      WRITE(LUN,11501)
      WRITE(LUN,11502) (I, RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I),
     *      RBTAB(IND,4,I), RBTAB(IND,5,I), RBTAB(IND,6,I),
     *      RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)),
     *      IDUAL(IBTAB(IND,9,I),7),
     *      IBTAB(IND,10,I), I=1, NROW)
11501 FORMAT(9X,'         COORDINATES  (CM)       ',
     *       '                MOMENTUM  (GEV)             ',
     *       '    TIME OF     ITRHIS     TRACK  ',/,
     *       9X,'      X          Y          Z    ',
     *       '     PX/P       PY/P       PZ/P        P    ',
     *       '  FLIGHT (NS)  LMIBPAFC   NUMBER  ',/,1X,130('-'),/)
11502 FORMAT((2X,I4,3X,8(F10.3,1X),4X,2I8))
      GOTO 200
C
C.... 'IRHT'
C
116   WRITE(LUN,1400)
      WRITE(LUN,11601)
11601 FORMAT(9X,'        ENTRY POINT   ( CM )    ',
     *       '         EXIT  POINT   ( CM )        MOMENTUM ',
     *       'PARTICLE TYPE   ITRHIS     TRACK  ',/,
     *       9X,'      X          Y          Z   ',
     *       '       X          Y          Z         (MEV)  ',
     *       '               LMIBPAFC   NUMBER  ',/,1X,130('-'),/)
      WRITE(LUN,11602) (I, FX(IBTAB(ID,1,I)), FY(IBTAB(ID,2,I)),
     *      FZ(IBTAB(ID,3,I)), FX(IBTAB(ID,4,I)), FY(IBTAB(ID,5,I)),
     *      FZ(IBTAB(ID,6,I)), IBTAB(ID,7,I),
     *      PDGNAM(IBTAB(ID,8,I)-10000), IDUAL(IBTAB(ID,9,I),7),
     *      IBTAB(ID,10,I), I=1, NROW)
11602 FORMAT((2X,I4,3X,6(F10.2,1X),I10,2X,A13,2X,2I8))
      GOTO 200
C
C.... 'LRET', 'LRPT'
C
117   WRITE(LUN,1400)
      WRITE(LUN,11701)
      WRITE(LUN,11702) (I, FL(IBTAB(ID,1,I)), FL(IBTAB(ID,2,I)),
     *      IBTAB(ID,3,I), PDGNAM(IBTAB(ID,4,I)-10000),
     *      IDUAL(IBTAB(ID, 5,I),7), IBTAB(ID, 6,I), I=1, NROW)
11701 FORMAT(9X,'   ENTRY POINT  ( CM )   MOMENTUM  ',
     *       ' PARTICLE TYPE   ITRHIS     TRACK  ',/,
     *       9X,'      X          Y         (MEV)   ',
     *       '                LMIBPAFC   NUMBER  ',/,1X,130('-'),/)
11702 FORMAT((2X,I4,3X,2(F10.3,1X),I10,4X,A13,2X,2I8))
      GOTO 200
C
C.... 'LRVT'
C
118   WRITE(LUN,1400)
      WRITE(LUN,11801)
      WRITE(LUN,11802) (I, IBTAB(ID,1,I), IBTAB(ID,2,I),
     *      IDUAL(IBTAB(ID,3,I),7), IBTAB(ID,4,I), I=1, NROW)
11801 FORMAT(9X,' NUMBER OF    RANGE   ',
     *          '   ITRHIS     TRACK  ',/,
     *       9X,'  MINIHITS     (MM)   ',
     *          '  LMIBPAFC   NUMBER  ',/,1X,130('-'),/)
11802 FORMAT((2X,I4,3X,I6,5X,I8,5X,2I8))
      GOTO 200
C
C.... STARTING AND LEAVING BANKS AT SUBDETECTOR BOUNDARIES
C
119   WRITE(LUN,1400)
      WRITE(LUN,11901)
      WRITE(LUN,11902) (I, RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I), PDGNAM(IBTAB(IND,4,I)), RBTAB(IND,5,I),
     *      RBTAB(IND,6,I), RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)),
     *      IDUAL(IBTAB(IND,9,I),7), IBTAB(IND,10,I), I=1, NROW)
11901 FORMAT(9X,'           MOMENTUM (GEV)        PARTICLE ',
     *       'TYPE   COORD. AT ENTRY/EXIT POINT (CM)      TIME OF  ',
     *       '   ITRHIS     TRACK    ',/,
     *       9X,'      PX         PY         PZ            ',
     *       '           X          Y          Z        FLIGHT (NS)',
     *       '  LMIBPAFC   NUMBER    ',/,1X,130('-'),/)
11902 FORMAT((2X,I4,2X,3(1X,F10.3),1X,A13,3(1X,F10.3),
     *        3X,F10.3,5X,2I8))
      GOTO 200
C
C.... 'ARCE' ('AECE', 'ARDE', 'AEDE'), 'SRCE'
C     FETCH PARALLEL BANKS
C
120   CONTINUE
      CALL VZERO(ID1,10)
      IF(NAME.EQ.'ARCE') THEN
         CALL BKTOW(IW,'AECE',0,IW,ID1(1),*12006)
         WRITE(LUN,1800) 'AECE'
C         DO 12000  I = 1, 4
C            CALL BKTOW(IW,'ARDE',I,IW,ID1(I+1),*9020)
C            CALL BKTOW(IW,'AEDE',I,IW,ID1(I+5),*9020)
12000    CONTINUE
C         WRITE(LUN,1800) 'ARDE'
C         WRITE(LUN,1800) 'AEDE'
      ELSE IF(NAME.NE.'SRCE') THEN
         WRITE(LUN,1800) NAME
         GOTO 200
      ENDIF
C
      WRITE(LUN,1400)
      WRITE(LUN,12002)
      ISUM1 = 0
      ISUM2 = 0
      DO 12001 I = 1, NROW
         IENER  = IFRB16(IBTAB(ID,2,I))
         IENERE = IFRB16(IBTAB(ID1(1),1,I))
         IENER  = IENER*ISCALA
         IENERE = IENERE*ISCALA

         IF(NAME.EQ.'SRCE') THEN
            IENER  = IFRB16(IBTAB(ID,2,I))
            IENERE = 0.
            IENER  = IENER*ISCALA
            IENERE = 0.
            CALL NSSOFT(IBTAB(ID,1,I),NN,LL,II,JJ,IFL)
            MM = 9
            KK = 0
         ENDIF

         ISUM1 = ISUM1 + IENER
         ISUM2 = ISUM2 + IENERE

         WRITE(LUN,12003) I, IBTAB(ID,1,I), MM, NN, LL, II,
     *       JJ, KK, FLOAT(IENER)*1.E-3, FLOAT(IENERE)*1.E-3
12001 CONTINUE
      WRITE(LUN,12004) FLOAT(ISUM1)*1.E-3, FLOAT(ISUM2)*1.E-3
12002 FORMAT(9X,'          CHANNEL  NUMBER              ENERGY  ',
     *       10X,'ELECTROMAGNETIC ',/,
     *       9X,'   CONT   MM  NN  LL  II  JJ  KK       (MEV)   ',
     *       10X,'ENERGY   (MEV)  ',/,1X,130('-'),/)
12003 FORMAT((2X,I4,3X,I7,1X,6I4,2X,F10.2,12X,F10.2))
12004 FORMAT(1H0,'TOTAL ENERGY',30X,F10.2,12X,F10.2)
C
C.... DROP WORK BANK
C
      DO 12005 I = 1, 1
         CALL WDROP(IW,ID1(I))
12005 CONTINUE
      GOTO 200
C
12006 CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12007)
      WRITE(LUN,12008) (I,IBTAB(ID,1,I), IBTAB(ID,2,I),
     *      I=1, NROW)
12007 FORMAT(9X,'  CHANNEL    ENERGY ',18X,'  CHANNEL    ENERGY ',
     *       18X,'  CHANNEL    ENERGY ',/,
     *       9X,'   NUMBER   DEPOSIT ',18X,'   NUMBER   DEPOSIT ',
     *       18X,'   NUMBER   DEPOSIT ',/,
     *       1X,130('-'),/)
12008 FORMAT((1X,3(I6,2X,2(I8,2X),10X)))
      GOTO 200
C
C.... 'BRCE' 'PRDE', 'LREE', 'LRPE'
C
121   CONTINUE
      IF(NAME.EQ.'PRDE')THEN
        ISFAC=10
      ELSE
        ISFAC=1000
      ENDIF
      WRITE(LUN,1400)
      WRITE(LUN,12101)
      WRITE(LUN,12102) (I, IBTAB(ID,1,I), IFRB16(IBTAB(ID,2,I))*ISFAC,
     *       I=1, NROW)
12101 FORMAT(9X,'  CHANNEL    ENERGY ',18X,'  CHANNEL    ENERGY ',
     *       18X,'  CHANNEL    ENERGY ',/,
     *       9X,'   NUMBER     (KEV) ',18X,'   NUMBER     (KEV) ',
     *       18X,'   NUMBER     (KEV) ',/,
     *       1X,130('-'),/)
12102 FORMAT((1X,3(I6,2X,2(I8,2X),10X)))
      GOTO 200
C
C.... 'BRTE'
C
122   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12201)
      WRITE(LUN,12202) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW)
12201 FORMAT(9X,'  CHANNEL   TOF HIT ',18X,'  CHANNEL   TOF HIT ',
     *      18X,'  CHANNEL   TOF HIT ',/,
     *       9X,'   NUMBER           ',18X,'   NUMBER           ',
     *      18X,'   NUMBER           ',/,
     *       1X,130('-'),/)
12202 FORMAT((1X,3(I6,2X,2(I8,2X),10X)))
      GOTO 200
C
C.... 'CRJE', 'CRZE'
C
123   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12301)
      WRITE(LUN,12302) (I, IBTAB(ID,1,I), FLOAT(IBTAB(ID,2,I))/100.,
     *        IBTAB(ID,3,I), IBTAB(ID,4,I), IBTAB(ID,5,I),
     *        IBTAB(ID,6,I), I=1, NROW)
12301 FORMAT(9X,'    WIRE     DRIFT          CHARGE        ',
     *          '  FLAG 1    FLAG 2 ',/,
     *       9X,'   NUMBER LENGTH (MM)  + SIDE    - SIDE   ',
     *          '                   ',/,1X,130('-'),/)
12302 FORMAT((2X,I4,3X,I8,3X,F8.2,2X,4(I8,2X)))
      GOTO 200
C
C.... 'CRME', 'FRME', 'BRME'
C
124   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12401)
      WRITE(LUN,12402) (I, IBTAB(ID,1,I), I=1, NROW)
12401 FORMAT(9X,'  CHANNEL ',18X,'  CHANNEL ',18X,'  CHANNEL ',
     *      18X,'  CHANNEL ',/,
     *       9X,'   NUMBER ',18X,'   NUMBER ',18X,'   NUMBER ',
     *      18X,'   NUMBER ',/,1X,130('-'),/)
12402 FORMAT((1X,4(I6,2X,I8,12X)))
      GOTO 200
C
C.... 'CRYE', 'FRPE', 'FRRE', 'MRPE', 'MRTE'
C
125   CONTINUE
      ICONV = 40
      IF(NAME.EQ.'CRYE') ICONV = 200
      WRITE(LUN,1400)
      WRITE(LUN,12501)
      WRITE(LUN,12502) (I, IBTAB(ID,1,I), IBTAB(ID,2,I)*ICONV,
     *        IBTAB(ID,3,I), IBTAB(ID,4,I), IBTAB(ID,5,I),
     *        IBTAB(ID,6,I), I=1, NROW)
12501 FORMAT(9X,'    WIRE  DRIFT TIME       CHARGE        ',
     *          '  FLAG 1    FLAG 2 ',/,
     *       9X,'   NUMBER    (PS)     + SIDE    - SIDE ',
     *          '                   ',/,1X,130('-'),/)
12502 FORMAT((2X,I4,3X,6(I8,2X)))
      GOTO 200
C
C.... 'FRPN', 'FRRN', 'MRPN', 'MRTN'
C
126   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12601)
      WRITE(LUN,12602) (I, IBTAB(IND,1,I), RBTAB(ID,2,I),
     *        IBTAB(IND,3,I), IBTAB(IND,4,I),
     *        RBTAB(IND,5,I), I=1, NROW)
12601 FORMAT(1H0,8X,'    CELL  ',
     *           '   COORDINATES OF NOISE HITS     ENERGY ',/,
     *           9X,'   NUMBER ',
     *           '    X          Y          Z     DEPOSIT ',/,
     *           1X,130('-'),/)
12602 FORMAT((2X,I4,3X,I8,4F10.3))
      GOTO 200
C
C.... 'FRPH'
C
127   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12701)
      WRITE(LUN,12702) (I, IBTAB(IND,1,I), RBTAB(IND,2,I),
     *        RBTAB(IND,3,I), IBTAB(IND,4,I), IBTAB(IND,5,I),
     *        IDUAL(IBTAB(IND,6,I),7), IBTAB(IND,7,I), I=1, NROW)
12701 FORMAT(1H0,8X,'    CELL    ENERGY      DRIFT   TYPE OF ',
     *           '    DRIFT   ITRHIS     LINK TO ',/,
     *           9X,'   NUMBER  DEPOSIT    DISTANCE    HIT   ',
     *           '     SIGN  LMIBPAFC  PARENT,STR',/,
     *           1X,130('-'),/)
12702 FORMAT((2X,I4,3X,I8,2F10.3,2X,4(I8,2X)))
      GOTO 200
C
C.... 'FRRH'
C
128   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12801)
      WRITE(LUN,12802) (I, IBTAB(IND,1,I), RBTAB(IND,2,I),
     *        RBTAB(IND,3,I), RBTAB(IND,4,I), IBTAB(IND,5,I),
     *        IBTAB(IND,6,I), IDUAL(IBTAB(IND,7,I),7),
     *        IBTAB(IND,8,1), I=1, NROW)
12801 FORMAT(1H0,8X,'    CELL    ENERGY      DRIFT   TYPE OF ',
     *           '    DRIFT   ITRHIS     LINK TO ',/,
     *           9X,'   NUMBER  DEPOSIT    DISTANCE    HIT   ',
     *           '     SIGN  LMIBPAFC  PARENT,STR',/,
     *           1X,130('-'),/)
12802 FORMAT((2X,I4,3X,I8,3F10.3,2X,4(I8,2X)))
      GOTO 200
C
C.... 'FRPX', 'FRRX', 'MRPX', 'MRTX'
C
129   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,12901)
      WRITE(LUN,12902) (I, IDUAL(IBTAB(ID,1,I),9), IBTAB(ID,2,I),
     *       IBTAB(ID,3,I), I=1, NROW)
12901 FORMAT(9X,'    FLAG     LINK  TO   LINK TO  ',
     *      18X,'    FLAG     LINK  TO   LINK TO  ',/,
     *       9X,'             STR BANK  FR_E BANK ',
     *      18X,'             STR BANK  FR_E BANK ',/,
     *       1X,130('-'),/)
12902 FORMAT((1X,2(I6,3X,I10,I8,3X,I8,13X)))
      GOTO 200
C
C.... 'IRSE', 'IRWE'
C
130   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13001)
      WRITE(LUN,13002) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW)
13001 FORMAT(9X,'   MODULE    CHANNEL ',18X,'   MODULE    CHANNEL ',
     *      18X,'   MODULE    CHANNEL ',/,
     *       9X,'   NUMBER     NUMBER ',18X,'   NUMBER     NUMBER ',
     *      18X,'   NUMBER     NUMBER ',/,
     *       1X,130('-'),/)
13002 FORMAT((1X,3(I6,2X,2(I8,3X),9X)))
      GOTO 200
C
C.... 'IRTE'
C
131   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13101)
      WRITE(LUN,13102) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW)
13101 FORMAT(9X,'  CHANNEL    CHARGE  ',18X,'  CHANNEL    CHARGE  ',
     *      18X,'  CHANNEL    CHARGE  ',/,
     *       9X,'  (TOWER)  STREAMERS ',18X,'  (TOWER)  STREAMERS ',
     *      18X,'  (TOWER)  STREAMERS ',/,
     *       1X,130('-'),/)
13102 FORMAT((1X,3(I6,2X,2(I8,3X),9X)))
      GOTO 200
C
C.... 'ARCX', 'BRCX', 'CRYX', 'CRZX', 'PRDX', 'SRCX'
C
132   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13201)
      WRITE(LUN,13202) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW)
13201 FORMAT(9X,' LINK  TO   LINK TO  ',
     *      18X,' LINK  TO   LINK TO  ',
     *      18X,' LINK  TO   LINK TO  ',/,
     *       9X,' STR BANK  _R_E BANK ',
     *      18X,' STR BANK  _R_E BANK ',
     *      18X,' STR BANK  _R_E BANK ',/,
     *       1X,130('-'),/)
13202 FORMAT((1X,3(I6,2X,2(I8,3X),9X)))
      GOTO 200
C
C....no longer used
C
133   CONTINUE
      GOTO 200
C
C.... 'LRTE', 'LTL1'
C
134   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13401)
      WRITE(LUN,13402) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW)
13401 FORMAT(9X,' DETECTOR  VETO CODE ',18X,' DETECTOR  VETO CODE ',
     *      18X,' DETECTOR  VETO CODE ',/,
     *       9X,'  NUMBER             ',18X,'  NUMBER             ',
     *      18X,'  NUMBER             ',/,
     *           1X,130('-'),/)
13402 FORMAT((1X,3(I6,2X,2(I8,2X),9X)))
      GOTO 200
C
C.... 'TRAK' ('TRIP')
C     FETCH PARALLEL BANKS
C
135   CONTINUE
      IF(NAME.EQ.'TRAK') THEN
         IND1 = NLINK('TRIP',NR)
         IF(IND1.EQ.0) GOTO 9020
         WRITE(LUN,1800) 'TRIP'
      ELSE
         WRITE(LUN,1800) NAME
         GOTO 200
      ENDIF
C
      WRITE(LUN,1400)
      WRITE(LUN,13502)
      WRITE(LUN,13503) (I, RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I), RBTAB(IND,4,I), RBTAB(IND,5,I),
     *      RBTAB(IND,6,I), RBTAB(IND,7,I), IBTAB(IND,8,I),
     *      IBTAB(IND,9,I), IBTAB(IND,10,I), IBTAB(IND,11,I),
     *      IBTAB(IND1,1,I), I=1, NROW)
13502 FORMAT(9X,'           MOMENTUM (GEV)            ENERGY  ',
     *       '   CHARGE     CLOSEST DISTANCE   ',
     *       ' PARTICLE   VERTEX   POINTERS  LINK  TO ',
     *       9X,'      PX         PY         PZ        (GEV)  ',
     *       '               R-PHI        Z    ',
     *       '   TYPE     NUMBER             STR BANK ',/,
     *       1X,130('-'),/)
13503 FORMAT((3X,I3,2X,4(1X,F10.3),3(1X,F10.4),2X,I6,4X,I6,
     *        3X,2I4,1X,I8))
      GOTO 200
C
C.... 'CACE' ('CCEG')
C     FETCH PARALLEL BANKS
C
136   CONTINUE
      IF(NAME.EQ.'CACE') THEN
         IND1 = NLINK('CCEG',0)
         IF(IND1.EQ.0) GOTO 13603
         WRITE(LUN,1800) 'CCEG'
      ELSE
         WRITE(LUN,1800) NAME
         GOTO 200
      ENDIF
C
      WRITE(LUN,1400)
      WRITE(LUN,13601)
      WRITE(LUN,13602) (I, IBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND1,1,I), RBTAB(IND1,2,I), RBTAB(IND1,3,I),
     *      RBTAB(IND1,4,I), I=1, NROW)
13601 FORMAT(9X,'    TOWER    ENERGY ',
     *          ' CENTROID  CENTROID  CENTROID  CENTROID ',/,
     *       9X,'   NUMBER   DEPOSIT ',
     *          '     X         Y         Z      VOLUME  ',/,
     *           1X,130('-'),/)
13602 FORMAT((2X,I4,3X,I8,5F10.3))
      GOTO 200
C
13603 CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13604)
      WRITE(LUN,13605) (I, IBTAB(IND,1,I), RBTAB(IND,2,I), I=1, NROW)
13604 FORMAT(9X,'   TOWER     ENERGY ',18X,'   TOWER     ENERGY ',
     *      10X,'   TOWER     ENERGY ',/,
     *       9X,'  NUMBER    DEPOSIT ',18X,'  NUMBER    DEPOSIT ',
     *      10X,'  NUMBER    DEPOSIT ',/,
     *       1X,130('-'),/)
13605 FORMAT((1X,3(I6,2X,I8,1X,F10.3,12X)))
      GOTO 200
C
C.... 'MUON'
C
137   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13701)
      WRITE(LUN,13702) (I, RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      IBTAB(IND,3,I), IBTAB(IND,4,I), IBTAB(IND,5,I),
     *      I=1, NROW)
13701 FORMAT(9X,'  SMEARED    SIGMA  ',
     *          '   NUMBER     NUMBER    LINK  TO ',/,
     *       9X,' MOMENTUM    (1/P)  ',
     *          '  OF WIRES  OF STRIPS   STR BANK ',/,
     *           1X,130('-'),/)
13702 FORMAT((2X,I4,1X,2F10.3,3I10))
      GOTO 200
C
C.... 'TTSE'
C
138   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13801)
      WRITE(LUN,13802) (RBTAB(IND,1,I),I=1, NROW)
13801 FORMAT(9X,'ENERGIES IN DIFFERENT CALORIMETERS (GEV) ',/,
     *       9X,'TRANSVERSE   MISSING    FORWARD    FORWARD  ',
     *          '  CENTRAL      BEMC       PLUG     FORWARD  ',
     *          '   BARREL    BACKWARD    TOTAL',/,
     *       9X,'                          LAR    BARREL LAR ',
     *          'BARREL LAR                                  ',
     *          '                              ',/,
     *       1X,130('-'),/)
13802 FORMAT((8X,11(F10.3,1X)))
      GOTO 200
C
C.... 'MODS'
C
139   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,13901)
      WRITE(LUN,13902) (CHAINT(IBTAB(IND,1,I)),CHAINT(IBTAB(IND,2,I)),
     *                  IBTAB(IND,3,I)/1.E4,IBTAB(IND,4,I),I=1, NROW)
13901 FORMAT(9X,'MODULE NAME    VERSION NR     JOB NR',/,
     *       1X,130('-'),/)
13902 FORMAT((9X,2A4,6X,F7.4,4X,I8))
      GOTO 200
C
C.... 'MODI', 'MODO'
C
140   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,14001)
      WRITE(LUN,14002) (CHAINT(IBTAB(IND,1,I)),IBTAB(IND,2,I),I=1, NROW)
14001 FORMAT(9X,4('NAME  LINK TO MODULE   '),/,
     *       1X,130('-'),/)
14002 FORMAT((9X,4(A4,8X,I2,9X)))
      GOTO 200
C
C.... 'MODC'
C
141   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,14101)
      WRITE(LUN,14102) (CHAINT(IBTAB(IND,1,I)),IBTAB(IND,2,I),
     1                  IBTAB(IND,3,I),I=1, NROW)
14101 FORMAT(9X,4('NAME VERSION  LINK TO MODULE   '),/,
     *       1X,130('-'),/)
14102 FORMAT((9X,4(A4,3X,I9,2X,I2,11X)))
      GOTO 200
C
C.... 'SRCT' (Spacal hit bank)
C
142   WRITE(LUN,1400)
      WRITE(LUN,14201)
      DO 14200 I = 1, NROW
         ITRHIS = 0
         CALL IDUAL1( ITRHIS, 14, 1, IBIT )
         IENER  = IFRB16(IBTAB(ID,2,I))*ISCALA
         IEINV  = IFRB16(IBTAB(ID,3,I))*ISCALD
         IEEM   = IFRB16(IBTAB(ID,4,I))*ISCALD
         IEHAD  = IFRB16(IBTAB(ID,5,I))*ISCALD
         IEHVIS = IFRB16(IBTAB(ID,6,I))*ISCALD
         WRITE(LUN,14202) I, IBTAB(ID,1,I),
     *      FLOAT(IENER)/1.E3,
     *      IBIT,IBTAB(ID,7,I),
     *      FLOAT(IEINV)/1.E3, FLOAT(IEEM)/1.E3,
     *      FLOAT(IEHAD)/1.E3, FLOAT(IEHVIS)/1.E3
14200 CONTINUE
14201 FORMAT(6X,'  CHAN   E(MeV)          ITRHIS  TRACK',
     *       '     Einv      Eem     Ehad   Ehavis'
     *       /,1X,130('-'),/)
14202 FORMAT((2X,I4,I6,F9.1,2X,14I1,I7,4F9.1))
      GOTO 200

143   CONTINUE
      WRITE(LUN,1400)
      CALL PRATES(ID)
      GOTO 200
144   CONTINUE
      WRITE(LUN,1400)
      write(6,*)'to print the TEL1 banks, please call directly'
      write(6,*)'PRTEL1(ITYPE), ITYPE=0 for online version'
      write(6,*)'               ITYPE=1 for offline version'
*      next call works differently now...
*      CALL PRTEL1(IND)
      GOTO 200
145   CONTINUE
      WRITE(LUN,1400)
*  look for ATBX bank for combined printout of banks
      INXX=NLINK('ATBX',NR)
      ID2=0
      IF(INXX.NE.0)THEN
        CALL BKTOW(IW,'ATBX',NR,IW,ID2,*9000)
      ENDIF
      CALL PRATBE(ID,ID2)
      IF(ID2.NE.0)CALL WDROP(IW,ID2)
      GOTO 200
C
C.... 'JSRP', 'JSFT'
C
146   WRITE(LUN,1400)
      WRITE(LUN,14601)
      WRITE(LUN,14602) (I, RBTAB(IND,1,I), RBTAB(IND,2,I),
     *      RBTAB(IND,3,I), PDGNAM(IBTAB(IND,4,I)), RBTAB(IND,5,I),
     *      RBTAB(IND,6,I), RBTAB(IND,7,I), (1.0E+09*RBTAB(IND,8,I)),
     *      IBTAB(IND,9,I), I=1, NROW)
14601 FORMAT(9X,'           MOMENTUM (GEV)        PARTICLE ',
     *       'TYPE   COORD. AT ENTRY/EXIT POINT (CM)      TIME OF  ',
     *       '   TRACK    ',/,
     *       9X,'      PX         PY         PZ            ',
     *       '           X          Y          Z        FLIGHT (NS)',
     *       '  NUMBER    ',/,1X,130('-'),/)
14602 FORMAT((2X,I4,2X,3(1X,F10.3),1X,A13,3(1X,F10.3),
     *        3X,F10.3,5X,I8))
      GOTO 200
C
C.... 'JRHT' ('JRDT')
C     FETCH PARALLEL BANKS
C
147   CONTINUE
      IF(NAME.EQ.'JRHT') THEN
         IND1 = NLINK('JRDT',NR)
         IF(IND1.EQ.0) GOTO 14703
         CALL BKTOW(IW,'JRDT',NR,IW,ID2,*9000)
         WRITE(LUN,1800) 'JRDT'
      ELSE
         WRITE(LUN,1800) NAME
         GOTO 200
      ENDIF
C
      WRITE(LUN,1400)
      WRITE(LUN,14701)
      WRITE(LUN,14702) (I,IDUAL(IBTAB(ID,1,I),6),
     *      IDUAL(IBTAB(ID2,1,I),6), IBTAB(ID,2,I), I=1, NROW)
      WRITE(LUN,1400)
      CALL WDROP(IW,ID2)
14701 FORMAT(9X,' CHANNELS  CHANNELS    PARTICLE '/,
     *       9X,'      HIT    SIGNAL     IN JSPT',/,
     *           1X,130('-'),/)
14702 FORMAT((I5,6X,I7,3X,I7,4X,I8))
      GOTO 200
C
14703 CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,14704)
      WRITE(LUN,14705) (I, IDUAL(IBTAB(ID,1,I),6),
     *      IBTAB(ID,2,I), I=1, NROW)
      WRITE(LUN,1400)
14704 FORMAT(9X,' CHANNELS    PARTICLE '/,
     *       9X,'      HIT     IN JSPT',/,
     *           1X,130('-'),/)
14705 FORMAT((I5,6X,I7,4X,I8))
      GOTO 200
C
C.... 'JRDE'
C
148   CONTINUE
      WRITE(LUN,1400)
      WRITE(LUN,14801)
      WRITE(LUN,14802) (I, IBTAB(ID,1,I), IBTAB(ID,2,I), I=1, NROW)
14801 FORMAT(9X,' CHANNEL       HITS ',/,1X,130('-'),/)
14802 FORMAT(2X,I4,3X,I8,3X,I8)
      GOTO 200
C
C.... PRINT BANKS WITHOUT MINIHEADER
C
C.... 'GKI ', 'GHD ', 'HEAD'
C
500   CONTINUE
      IF(NAME.EQ.'GKI ') THEN
         WRITE(LUN,1400)
         IF( IW(IND) .GE. 29 ) THEN
           WRITE(LUN,511) IW(IND+1)
511        FORMAT(9X,' IRAD   = ',I13,'   initial/final radiation')
           WRITE(LUN,512) RW(IND+3), RW(IND+4)
512        FORMAT(9X,' GENPL  = ',E13.6,'   incident lepton momentum',/,
     *            9X,' GENPP  = ',E13.6,'   incident proton momentum')
           WRITE(LUN,513) RW(IND+5), RW(IND+6), RW(IND+7)
513        FORMAT(9X,' GENX   = ',E13.6,'   Bjorken X value ',/,
     *            9X,' GENY   = ',E13.6,'   Bjorken Y value ',/,
     *            9X,' GENQ2  = ',E13.6,'   Q**2 value ')
           WRITE(LUN,514) RW(IND+8), RW(IND+9)
514        FORMAT(9X,' GENNU  = ',E13.6,'   nu = P.q/m_proton ',/,
     *            9X,' GENW   = ',E13.6,'   W value ')
           WRITE(LUN,515) RW(IND+10), RW(IND+11)
515        FORMAT(9X,' X1     = ',E13.6,'   x in PDF lepton side',/,
     *            9X,' X2     = ',E13.6,'   x in PDF proton side')
           WRITE(LUN,516) RW(IND+12), RW(IND+13)
516        FORMAT(9X,' SCALE1 = ',E13.6,'   Q2 in PDF lepton side',/,
     *            9X,' SCALE2 = ',E13.6,'   Q2 in PDF proton side')
           WRITE(LUN,517) IW(IND+14), IW(IND+15)
517        FORMAT(9X,' PDFID1 = ',I13,'   PDF id. lepton side',/,
     *            9X,' PDFID2 = ',I13,'   PDF id. proton side')
           WRITE(LUN,518) RW(IND+16), RW(IND+17)
518        FORMAT(9X,' XPDF1  = ',E13.6,'   value of PDF lepton side',/,
     *            9X,' XPDF2  = ',E13.6,'   value of PDF proton side')
           WRITE(LUN,519) RW(IND+18), RW(IND+19)
519        FORMAT(9X,' KTI1   = ',E13.6,'   intr. k_t lepton side',/,
     *            9X,' KTI2   = ',E13.6,'   intr. k_t proton side')
           WRITE(LUN,520) RW(IND+20), RW(IND+21)
520        FORMAT(9X,' WTX1   = ',E13.6,'   event weight 1. variable',/,
     *            9X,' WTX2   = ',E13.6,'   event weight 2. variable')
           WRITE(LUN,521) RW(IND+22), RW(IND+23)
521        FORMAT(9X,' SIGMT  = ',E13.6,'   total cross section',/,
     *            9X,' DSIGMT = ',E13.6,'   error of cross section')
           WRITE(LUN,522) RW(IND+24), RW(IND+25)
522        FORMAT(9X,' SIGMS  = ',E13.6,'   subpr. cross section',/,
     *            9X,' DSIGMS = ',E13.6,'   error of cross section')
           WRITE(LUN,523) RW(IND+26)
523        FORMAT(9X,' WTX3   = ',E13.6,'   event weight mixing ')
           IF( IW(IND) .GE. 31 ) THEN
             WRITE(LUN,524) RW(IND+30), RW(IND+31)
524          FORMAT(9X,' PT2HAT = ',E13.6,'   DIS + photoprod.  ',/,
     *              9X,' SHAT   = ',E13.6,'   DIS + photoprod.  ')
           ENDIF
           IF( IW(IND) .GE. 34 ) THEN
             WRITE(LUN,525) RW(IND+32), RW(IND+33), RW(IND+34)
525          FORMAT(9X,' XP     = ',E13.6,'   DIS + photoprod.  ',/,
     *              9X,' ZP     = ',E13.6,'   DIS + photoprod.  ',/,
     *              9X,' PHI    = ',E13.6,'   DIS + photoprod.  ')
           ENDIF
         ELSE
           WRITE(LUN,501)
501        FORMAT(9X,'  PHYSICS  HARD GAMMA   BEAM MOMENTA (GEV/C) ',
     *               '      X           Y          Q**2          NU   ',
     *               '       W    ',/,
     *            9X,'    FLAG    RADIATION    LEPTON      PROTON  ',
     *               '                          (GEV/C)**2     (GEV)  ',
     *               '     (GEV)  ',/,1X,130('-'),/)
           WRITE(LUN,502) IW(IND+1), IW(IND+2), (RW(IND+I), I=3, 9)
502        FORMAT(9X,I5,5X,'  IRAD =',I2,1X,7(1X,E11.4))
         END IF
         WRITE(LUN,1400)
      ELSE IF(NAME.EQ.'GHD ') THEN
         WRITE(LUN,1400)
         J = IND
         DO 180, I = 1, IW (IND) / 6
           WRITE(LUN,503) CHAINT(IW(J+1)), CHAINT(IW(J+2)),
     *                    CHAINT(IW(J+3)), CHAINT(IW(J+4)),
     *                    CHAINT(IW(J+5)), CHAINT(IW(J+6))
           J = J + 6
180      CONTINUE
503      FORMAT(/,6X,'GENERATOR NAME  ',2A4,'   VERSION NUMBER ',
     *          2A4,'   CMZ Version ',2A4)
         WRITE(LUN,1400)


      ELSE IF(NAME.EQ.'GEVC') THEN
         CALL PRGEVC
      ELSE IF(NAME.EQ.'HEAD') THEN
         WRITE(LUN,1400)
         WRITE(LUN,504)
         WRITE(LUN,505) (IW(IND+I), I=1, 13)
504      FORMAT(9X,'VERS  NRUN  NEVT  WEIGHT ',
     *             '  U-TIME  RUNTYPE  BRERROR  DETSTAT  ',
     *             ' L1-CLASS  L2-CLASS  L3-CLASS  L4-CLASS  L5-CLASS',
     *               /,1X,130('-'),/)
505      FORMAT(9X,I4,I7,I7,I4,9I10)
         WRITE(LUN,1400)
      END IF
      RETURN
C
C.... CONTINUE HERE WITH NEW BANKS
C
200   CONTINUE
      IF(IBKFMT.LT.0) CALL WDROP(IW,ID)
      WRITE(LUN,1400)
      RETURN
C
9000  CONTINUE
      WRITE(LUN,1100) NAME, NR
      GOTO 200
9010  CONTINUE
      WRITE(LUN,1600) NAME
      WRITE(LUN,1400)
      IDUMMY = MYPRNT(NAME,NR,0)
      RETURN
9020  CONTINUE
      WRITE(LUN,1700)
      GOTO 200
1100  FORMAT(//,' +++++ H1PRNT. BANK ++ ',A,',',I2,' ++ DOES NOT ',
     *       'EXIST ON INPUT FILE. ')
1200  FORMAT('0+++++ H1PRNT. PRINT FORMAT FOR BANK ++ ',A,' ++ ',
     *       'IS NOT YET SPECIFIED. ')
1300  FORMAT(//,' +++++ ',A,',',I2,
     *       '    BANK LENGTH ',I5,
     *       '    NUMBER OF COLUMNS ',I5,
     *       '    NUMBER OF ROWS ',I5)
1400  FORMAT(1H0,130('-'))
1500  FORMAT('0+++++ H1PRNT. BANK LENGTH DOES NOT MATCH ',
     *       'MINI HEADER.',/)
1600  FORMAT(//,' +++++ H1PRNT. BANK ++ ',A,' ++ NOT FOUND IN ',
     *       'CURRENT BANK LIST.',/,
     *             ' +++++ H1PRNT. CALL MYPRNT INSTEAD.',//)
1700  FORMAT('0+++++ H1PRNT. NO PARALLEL BANK FOUND.')
1800  FORMAT('0+++++ ',A4,', 0    IS A PARALLEL BANK.')
1900  FORMAT(//,' +++++ ',A,',',I2,'     NO MINIHEADER.')
      END
*CMZU:          03/08/98  14.41.58  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FPFRQE
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*#    Print FRQE BANK                                                  *
*#    Created  BY SJM    02/03/90                                      *
*#                                                                     *
*#**********************************************************************
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
      COMMON/FPF3WW/IND
*     Locate FRQE Banks..
      IBK = 0
      IND  = NLINK('FRQE',IBK)
      IF (IND .EQ. 0) THEN
         WRITE(6,*) 'FRQE', IBK,' BANK NOT FOUND '
          RETURN
      ENDIF
      IND=0
      CALL BKTOW(IW,'FRQE',IBK,IW,IND,*900)
*     Compute number of responses...
      INUM = IW(IND+2)
      IF(INUM.LE.0) GOTO 999
      WRITE(6,100) IBK,INUM
      WRITE(6,110)
      INDST = IND+2
      DO 11 JJHIT = 1,INUM
*     Information from FRQE  response bank...
         ICLNUM=        IW(INDST + 1)
         IDRF  =        IW(INDST + 2)
         IQPL  =        IW(INDST + 3)
         IQMI  =        IW(INDST + 4)
         IFRFLA=        IW(INDST + 5)
         IFRFLB=        IW(INDST + 6)
         ISEPR   = 0
         ISEPL   = 0
         IHITS   = 0
         ILEN    = 0
         CALL MVBITS(IFRFLB, 0,4,ISEPL,0)
         CALL MVBITS(IFRFLB, 4,4,ISEPR,0)
         CALL MVBITS(IFRFLB, 8,4,ILEN,0)
         CALL MVBITS(IFRFLB,12,4,IHITS,0)
         INDST = INDST + IW(IND+1)
         WRITE(6,200)JJHIT,ICLNUM,IDRF,IQPL,IQMI,
     +               IFRFLA,IFRFLB,
     +               ISEPL,ISEPR,ILEN,IHITS
 11   CONTINUE
 100  FORMAT(' ',72('-'),/,5X, 'FRQE ',I2,' WITH',I5,' HITS')
 110  FORMAT('   Row  Cell     Drift     Qplus',
     +                   '    Qminus  Flag1  Flag2',
     +           '   ?   ?   ?   ?')
 200  FORMAT(2I6,3I10,2(3X,I8),4I4)
 999  CONTINUE
      CALL WDROP(IW,IND)
      RETURN
 900  CONTINUE
      WRITE(6,*) ' *****ERROR IN W BANK CREATION FPFRQE'
      RETURN
      END
*CMZU:          03/08/98  14.41.58  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FPFRQF
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*#    Print FRQF BANK                                                  *
*#    Created  BY SJM    02/03/90                                      *
*#                                                                     *
*#**********************************************************************
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
*     Locate FRQF Bank...
      IND  = NLINK('FRQF',0)
      IF (IND .EQ. 0) THEN
         WRITE(6,*) ' **FPFRQF>> FRQF BANK NOT FOUND '
          RETURN
      ENDIF
*     Compute number of responses...
      INUM = IW(IND+2)
      IF(INUM.LE.0) GOTO 999
         WRITE(6,100) INUM
         WRITE(6,110)
         INDST = IND+2
         DO 11 JJHIT = 1,INUM
*
         XIN    =           RW(INDST + 1)
         YIN    =           RW(INDST + 2)
         ZIN    =           RW(INDST + 3)
         PXIN   =           RW(INDST + 4)
         PYIN   =           RW(INDST + 5)
         PZIN   =           RW(INDST + 6)
         PPIN   =           RW(INDST + 7)
         XOUT   =           RW(INDST + 8)
         YOUT   =           RW(INDST + 9)
         ZOUT   =           RW(INDST +10)
         PXOUT  =           RW(INDST +11)
         PYOUT  =           RW(INDST +12)
         PZOUT  =           RW(INDST +13)
         PPOUT  =           RW(INDST +14)
         IPART  =           IW(INDST +15)
         ITRHIS =           IW(INDST +16)
         ICELL  =           IW(INDST +17)
         ITRKNM =           IW(INDST +18)
         WRITE(6,200)JJHIT,XIN ,YIN ,ZIN ,PXIN ,PYIN ,PZIN ,PPIN,
     +                     XOUT,YOUT,ZOUT,PXOUT,PYOUT,PZOUT,PPOUT,
     +                     IPART,ITRHIS,ICELL,ITRKNM
            INDST  = INDST + IW(IND+1)
 11      CONTINUE
 100  FORMAT(' ',72('-'),/,5X, 'FRQF WITH',I5,' HITS')
 110  FORMAT(' ',' Row','      x','      y','      z','   Px/P',
     +                  '   Py/P','   Pz/P','      P',' Typ',
     +                  ' His','  Cell',' Trk')
 200  FORMAT(1X,I4,7(1X,F6.2),/,5X,7(1X,F6.2),2I4,I6,I4)
 999  CONTINUE
      RETURN
      END
*CMZU:          03/08/98  14.41.58  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FPFRQH
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*#    Print FRQH BANK                                                  *
*#    Created  BY SJM    02/03/90                                      *
*#                                                                     *
*#**********************************************************************
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
*     Conversion GeV  -> keV
      PARAMETER(GEVKEV=1000000.)
*     Locate FRQH Bank...
      IND  = NLINK('FRQH',0)
      IF (IND .EQ. 0) THEN
         WRITE(6,*) 'FRQH BANK NOT FOUND '
          RETURN
      ENDIF
*     Compute number of responses...
      INUM = IW(IND+2)
      IF(INUM.LE.0) GOTO 999
         WRITE(6,100) INUM
         WRITE(6,110)
         INDST = IND+2
         DO 11 JJHIT = 1,INUM
*     Information from FRPH bank
            ICLNUM =           IW(INDST + 1)
            EDEP   =    GEVKEV*RW(INDST + 2)
            DRIF   =           RW(INDST + 3)
            IHTTYP =           IW(INDST + 4)
            ISIGN  =           IW(INDST + 5)
            ITRHIS =           IW(INDST + 6)
            ITRKNM =           IW(INDST + 7)
            WRITE(6,200)JJHIT,ICLNUM,EDEP,DRIF,
     +                  IHTTYP,ISIGN,ITRHIS,ITRKNM
            INDST  = INDST + IW(IND+1)
 11      CONTINUE
 100  FORMAT(' ',72('-'),/,5X, 'FRQH WITH',I5,' HITS')
 110  FORMAT('  Row','  Cell',
     +           '  Edep-keV      Drif',
     +           ' HTyp  Sgn  His  Trk')
 200  FORMAT(I5,I6,2F10.4,4I5)
 999  CONTINUE
      RETURN
      END
*CMZU:          03/08/98  14.41.58  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FPFRQT
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*#    Print FRQT BANK                                                  *
*#    Created  BY SJM    02/03/90                                      *
*#                                                                     *
*#**********************************************************************
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
      PARAMETER(NBN=0)
*     Locate FRQT banks...
      IND =NLINK('FRQT',NBN)
      IF(IND.NE.0) THEN
*     Number of hits in bank
         INUM=IW(IND+2)
         WRITE(6,100) NBN,INUM
*     Loop through hits in this bank
         INDST = IND+2
         WRITE(6,110)
         DO 11 JJHIT = 1,INUM
*     Information from track response bank...
            ICLNUM=  IW(INDST + 1)
            XIN   =  RW(INDST + 2)
            YIN   =  RW(INDST + 3)
            ZIN   =  RW(INDST + 4)
            XOUT  =  RW(INDST + 5)
            YOUT  =  RW(INDST + 6)
            ZOUT  =  RW(INDST + 7)
            EDEP  =  1000000.*RW(INDST + 8)
            ITRHIS=  IW(INDST + 9)
            ITRKNM=  IW(INDST +10)
            WRITE(6,200)JJHIT,ICLNUM,XIN,YIN,ZIN,XOUT,YOUT,ZOUT,
     +      EDEP,ITRHIS,ITRKNM
            INDST = INDST + IW(IND+1)
 11      CONTINUE
      END IF
 100  FORMAT(' ',72('-'),/,5X, 'FRQT BANK ',I3,' with',I5,' Hits')
 110  FORMAT('  Row Cell    Xin    Yin    Zin',
     +           '   Xout   Yout   Zout  E-keV His',
     +           ' Trk')
 200  FORMAT(2I5,7F7.2,2I4)
      RETURN
      END
*CMZU:          03/08/98  14.41.58  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE FPFRQX
*#**********************************************************************
*#                                                                     *
*#    VERSION: 30/07/98   Steve Burke                                  *
*#                                                                     *
*#    Print FRQX BANK                                                  *
*#    Created  BY SJM    02/03/90                                      *
*#                                                                     *
*#**********************************************************************
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEND.
      COMMON/FPF5WW/IND
*KEEP,STFUNCT.
*     index of element before row number IROW
      INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1)
*     index of L'th element  of row number IROW
      INDCR(IND,L,IROW)=INDR(IND,IROW) + L
*     L'th integer element of the IROW'th row of bank with index IND
      IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW))
*     L'th real element of the IROW'th row of bank with index IND
      RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW))
*KEND.
*     Locate FRQX Bank...
      IBK = 0
      IND  = NLINK('FRQX',IBK)
      IF (IND .EQ. 0) THEN
         WRITE(6,*) 'FRQX', IBK,' BANK NOT FOUND '
          RETURN
      ENDIF
      IND=0
      CALL BKTOW(IW,'FRQX',IBK,IW,IND,*900)
*     Compute number of responses...
      INUM = IW(IND+2)
      IF(INUM.LE.0) GOTO 999
      WRITE(6,100) IBK,INUM
      WRITE(6,*) ' Row','   IFlag',
     +                   '     Trk',
     +                   '   IFRQE'
      DO 11 K = 1,INUM
         WRITE(6,'(1X,I4,3(2X,I6))')
     +   K,(IBTAB(IND,J,K), J=1,3)
 11   CONTINUE
 100  FORMAT(' ',72('-'),/,5X, 'FRQX ',I2,' WITH',I5,' HITS')
 999  CONTINUE
      CALL WDROP(IW,IND)
      RETURN
 900  CONTINUE
      WRITE(6,*) ' *****ERROR IN W BANK CREATION FPFRQX'
      RETURN
      END
*CMZU:          03/08/98  14.42.18  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE UTQCRB
**********************************************************************
*                                                                    *
* Create unpacked versions of the digi pointer and hit relation      *
* banks for use by UTQSTR                                            *
*                                                                    *
* Banks created are: FTPY, FTQY, FTRY, CTJY, CVYY, CVZY,             *
*                    FRPY, FRQY, FRRY, CRJY, CRYY, CRZY and STRX     *
*                                                                    *
* See the DDL for details                                            *
*                                                                    *
* Updated 31/7/98 to allow for the new planar chambers               *
*                                                                    *
**********************************************************************

      PARAMETER (NSUBDT=6,NCDP=2,NCXR=5)

      DIMENSION IFLG(NSUBDT),ISTR(NSUBDT),IHIT(NSUBDT)
      CHARACTER*4 DPNAME(NSUBDT),XRNAME(NSUBDT)
      CHARACTER*4 DPNAMY(NSUBDT),XRNAMY(NSUBDT)
      LOGICAL LFIRST

      SAVE IFLG,ISTR,IHIT,DPNAME,XRNAME,DPNAMY,XRNAMY,LFIRST

      COMMON /IUSTRY/ INDDP(NSUBDT),INDXR(NSUBDT)

      DATA IFLG/1,1,1,0,0,0/,ISTR/2,2,2,1,1,1/,IHIT/3,3,3,2,2,2/
      DATA DPNAME/'FTPX','FTQX','FTRX','CTJX','CRYE','CRZE'/
      DATA DPNAMY/'FTPY','FTQY','FTRY','CTJY','CVYY','CVZY'/
      DATA XRNAME/'FRPX','FRQX','FRRX','CRJX','CRYX','CRZX'/
      DATA XRNAMY/'FRPY','FRQY','FRRY','CRJY','CRYY','CRZY'/
      DATA LFIRST/.TRUE./

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEEP,STFUNCT.
*     index of element before row number IROW
      INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1)
*     index of L'th element  of row number IROW
      INDCR(IND,L,IROW)=INDR(IND,IROW) + L
*     L'th integer element of the IROW'th row of bank with index IND
      IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW))
*     L'th real element of the IROW'th row of bank with index IND
      RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW))
*KEND.

**********************************************************************

      IF (LFIRST) THEN
         LFIRST = .FALSE.
* Define the bank formats (just in case they get written out)
         CALL BKFMT('STRX','I')
         DO JS=1,NSUBDT
            CALL BKFMT(DPNAMY(JS),'I')
            CALL BKFMT(XRNAMY(JS),'I')
         END DO
      ENDIF

* Zero work bank indices
      CALL VZERO(INDDP,NSUBDT)
      CALL VZERO(INDXR,NSUBDT)

      INSTR = NLINK('STR ',0)
      IF (INSTR.GT.0) THEN
* Create the STRX bank and add to R list
         NSTR   = IW(INSTR+2)
         INSTRX = NBANK('STRX',0,2+NSUBDT*NSTR)
         IF (INSTRX.LE.0) GOTO 9000
         CALL VZERO(IW(INSTRX+1),2+NSUBDT*NSTR)
         CALL BLIST(IW,'R+','STRX')
         IW(INSTRX+1) = NSUBDT
         IW(INSTRX+2) = NSTR
      ELSE
         NSTR = 0
      ENDIF

*
* Main loop over subdetectors
*

      DO 100 JS=1,NSUBDT
* Get rid of any pre-existing banks
         CALL BDROP(IW,DPNAMY(JS))
         CALL BDROP(IW,XRNAMY(JS))
* Do nothing if the banks don't exist
         IF (NLINK(DPNAME(JS),0).LE.0 .OR.
     &       NLINK(XRNAME(JS),0).LE.0) GOTO 100
* Unpack banks (all B16)
         CALL BKTOW(IW,DPNAME(JS),0,IW,INDDP(JS),*9000)
         CALL BKTOW(IW,XRNAME(JS),0,IW,INDXR(JS),*9000)
         NDP = IW(INDDP(JS)+2)
         NXR = IW(INDXR(JS)+2)
* Create the new banks and add to R list
         INDDPY = NBANK(DPNAMY(JS),0,2+NCDP*NDP)
         IF (INDDPY.LE.0) GOTO 9000
         CALL BLIST(IW,'R+',DPNAMY(JS))
         INDXRY = NBANK(XRNAMY(JS),0,2+NCXR*NXR)
         IF (INDXRY.LE.0) GOTO 9000
         CALL BLIST(IW,'R+',XRNAMY(JS))
         CALL VZERO(IW(INDDPY+1),2+NCDP*NDP)
         CALL VZERO(IW(INDXRY+1),2+NCXR*NXR)
         IW(INDDPY+1) = NCDP
         IW(INDDPY+2) = NDP
         IW(INDXRY+1) = NCXR
         IW(INDXRY+2) = NXR
* Loop over the cross-reference banks in reverse order
         DO JXR=NXR,1,-1
            IF (IFLG(JS).GT.0) THEN
* True hits only (this flag only exists for radials and planars)
               IFLAG = IBTAB(INDXR(JS),IFLG(JS),JXR)
            ELSE
               IFLAG = 0
            ENDIF
            IF (IFLAG.LT.512) THEN
               JDP  = IBTAB(INDXR(JS),IHIT(JS),JXR)
               JSTR = IBTAB(INDXR(JS),ISTR(JS),JXR)
* Fill in the various pointers
               IF (JDP.GT.0 .AND. JDP.LE.NDP) THEN
                  JXX = IBTAB(INDDPY,2,JDP)
                  IW(INDCR(INDDPY,2,JDP)) = JXR
                  IW(INDCR(INDXRY,1,JXR)) = JSTR
                  IW(INDCR(INDXRY,2,JXR)) = JDP
                  IW(INDCR(INDXRY,3,JXR)) = JXX
                  IW(INDCR(INDXRY,5,JXR)) = IFLAG
               ENDIF
               IF (JSTR.GT.0 .AND. JSTR.LE.NSTR) THEN
                  JXY = IBTAB(INSTRX,JS,JSTR)
                  IW(INDCR(INSTRX,JS,JSTR)) = JXR
                  IW(INDCR(INDXRY,4,JXR))   = JXY
               ENDIF
            ENDIF
         END DO
* Finally copy the "pointer to next digi" (meaningless for z-chambers)
         DO JDP=1,NDP
            IW(INDCR(INDDPY,1,JDP)) = IBTAB(INDDP(JS),1,JDP)
         END DO
 100  CONTINUE

 900  CONTINUE

*
* Must make sure all work banks are dropped!!!
*

      DO JS=1,NSUBDT
         CALL WDROP(IW,INDDP(JS))
         CALL WDROP(IW,INDXR(JS))
      END DO

      RETURN

 9000 CONTINUE

      CALL ERRLOG(1201,'S:UTQCRB: Error in bank creation')

      GOTO 900

      END
*CMZU:          03/08/98  14.42.18  by  Stephen Burke
*-- Author :    Stephen Burke   03/08/98
      SUBROUTINE UTQSTR(JDIGP,JDIGQ,JDIGR,JDIGJ,JCVPR,JSTR,NHIT,NPOSS)
**********************************************************************
*                                                                    *
* Find the best candidate for the 'true' track, given a list         *
* of digis.                                                          *
*                                                                    *
* Note that UTQCRB must be called once per event before this         *
* routine can be used.                                               *
*                                                                    *
* The arguments are pointers into the circular lists of digis, or    *
* for the z-chambers to the "pointering" bank:                       *
*                                                                    *
* JDIGP  -->  FTPX  (foward planars)                                 *
* JDIGQ  -->  FTQX  (foward new planars)                             *
* JDIGR  -->  FTRX  (forward radials)                                *
* JDIGJ  -->  CTJX  (CJC)                                            *
* JCVPR  -->  CVPR  (CIZ + COZ)                                      *
*                                                                    *
* The return values are:                                             *
*                                                                    *
* JSTR  - The 'true' track (STR) number                              *
* NHIT  - The number of hits from track JSTR in the digi list(s)     *
* NPOSS - The total number of hits from track JSTR                   *
*                                                                    *
* Thus NHIT/NPOSS is some sort of "hit-finding efficiency".          *
*                                                                    *
* Zero or negative pointers are ignored; the return value JSTR is    *
* the STR index of the "best" track (the one contributing most hits) *
* for those subdetectors with pointers > 0.                          *
*                                                                    *
* Pointers which are negative on entry will exclude that subdetector *
* from having its hits counted in NPOSS                              *
*                                                                    *
* If the FT unpacked banks (FPLC/FPG1, FQLC/FQG1 and FRLC/FRG1)      *
* exist, NPOSS does not include hits on dead wires (which may have   *
* been simulated and then killed in reconstruction). These banks     *
* can be generated by calling F{P/Q/R}LOCO and FTCORG (in H1REC).    *
* No similar banks currently exist for the CTD (to my knowledge).    *
* Note that these banks are also created by the FRCART routine,      *
* used e.g. in the event display.                                    *
*                                                                    *
* Note that H1SIM must be run with the secondary momentum cut        *
* (SKECUT) set to zero for each track to have a unique STR number;   *
* the default is for all secondaries to have the same number as      *
* the parent.                                                        *
*                                                                    *
* The following values are returned as error codes:                  *
*                                                                    *
* JSTR =  0 - track/digi cross-reference bank not found              *
*      = -1 - digi pointer bank not found                            *
*      = -2 - digi pointer invalid                                   *
*      = -3 - digi pointer list not circular                         *
*                                                                    *
* NHIT and NPOSS are zero in this case.                              *
*                                                                    *
**********************************************************************

      PARAMETER (NSUBDT=6,IWCHNK=1000)

      DIMENSION JDIG(NSUBDT),NNDIG(NSUBDT)
      DIMENSION INDDP(NSUBDT),INDXR(NSUBDT),INDLC(3),INDG1(3)
      LOGICAL LDWBK(NSUBDT),LCIRC(NSUBDT)
      CHARACTER*4 DPNAME(NSUBDT),DPNAMY(NSUBDT),XRNAMY(NSUBDT)
      CHARACTER*4 LCNAME(3),G1NAME(3)

      SAVE DPNAME,DPNAMY,XRNAMY,LCNAME,G1NAME,LCIRC

      COMMON /IUSTRZ/ INDDPX(NSUBDT),INCVPR,INDTRU

      DATA DPNAME/'FTPX','FTQX','FTRX','CTJX','CVYX','CVZX'/
      DATA DPNAMY/'FTPY','FTQY','FTRY','CTJY','CVYY','CVZY'/
      DATA XRNAMY/'FRPY','FRQY','FRRY','CRJY','CRYY','CRZY'/
      DATA LCIRC/.TRUE.,.TRUE.,.TRUE.,.TRUE.,.FALSE.,.FALSE./
      DATA LCNAME/'FPLC','FQLC','FRLC'/
      DATA G1NAME/'FPG1','FQG1','FRG1'/

*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEEP,STFUNCT.
*     index of element before row number IROW
      INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1)
*     index of L'th element  of row number IROW
      INDCR(IND,L,IROW)=INDR(IND,IROW) + L
*     L'th integer element of the IROW'th row of bank with index IND
      IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW))
*     L'th real element of the IROW'th row of bank with index IND
      RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW))
*KEND.

**********************************************************************

      JSTR  = -1
      NHIT  = 0
      NPOSS = 0

* Zero work bank indices
      CALL VZERO(INDDPX,NSUBDT)
      INCVPR = 0
      INDTRU = 0

* Copy pointers
      JDIG(1)  = JDIGP
      JDIG(2)  = JDIGQ
      JDIG(3)  = JDIGR
      JDIG(4)  = JDIGJ
      JDIG(5)  = JCVPR
      JDIG(6)  = JCVPR
      CALL VZERO(NNDIG,NSUBDT)

* Unpack the CVPR and z-chamber digi pointer banks if necessary
      IF (JCVPR.GT.0) THEN
         IF (NLINK('CVPR',0).LE.0) RETURN
         CALL BKTOW(IW,'CVPR',0,IW,INCVPR,*9000)
         JDIG(5)  = IBTAB(INCVPR,2,JCVPR)
         JDIG(6)  = IBTAB(INCVPR,4,JCVPR)
         NNDIG(5) = IBTAB(INCVPR,1,JCVPR)
         NNDIG(6) = IBTAB(INCVPR,3,JCVPR)
* Check that pointer banks exist and unpack (all B16)
         DO JS=5,6
            IF (JDIG(JS).GT.0) THEN
               IF (NLINK(DPNAME(JS),0).LE.0) GOTO 900
               CALL BKTOW(IW,DPNAME(JS),0,IW,INDDPX(JS),*9000)
            ENDIF
         END DO
      ENDIF

      JSTR = 0

* Get indices for unpacked banks
      DO JS=1,NSUBDT
         IF (JDIG(JS).GT.0) THEN
            INDDP(JS) = NLINK(DPNAMY(JS),0)
            INDXR(JS) = NLINK(XRNAMY(JS),0)
            IF (INDDP(JS).LE.0 .OR. INDXR(JS).LE.0) GOTO 900
         ELSEIF (JDIG(JS).EQ.0) THEN
            INDXR(JS) = NLINK(XRNAMY(JS),0)
         ENDIF
         IF (JS.LE.3) THEN
* See if FT unpacked banks exist
            INDLC(JS) = NLINK(LCNAME(JS),0)
            INDG1(JS) = NLINK(G1NAME(JS),0)
            LDWBK(JS) = INDLC(JS).GT.0 .AND. INDG1(JS).GT.0
         ELSE
* No dead wire info for CT (?)
            LDWBK(JS) = .FALSE.
         ENDIF
      END DO

* Create work bank to store true track numbers
      CALL WBANK(IW,INDTRU,IWCHNK,*9000)
      CALL VZERO(IW(INDTRU+1),IWCHNK)

*
* Main loop over subdetectors
*

      DO 500 JS=1,NSUBDT
         IF (JDIG(JS).LE.0) GOTO 500
* Get the starting digi pointer
         IF (LCIRC(JS)) THEN
            IDIG = JDIG(JS)
         ELSE
            IDIG = IBTAB(INDDPX(JS),2,JDIG(JS))
         ENDIF
         NDIG = IW(INDDP(JS)+2)
* Loop over digis looking for a corresponding hit ...
         INUM = 0
 100     CONTINUE
            INUM = INUM + 1
            IF (INUM.GT.NDIG) THEN
* Pointer list can't be circular
               JSTR = -3
               GOTO 900
            ELSEIF (IDIG.LE.0 .OR. IDIG.GT.NDIG) THEN
* Pointer is invalid
               JSTR = -2
               GOTO 900
            ENDIF
            JHIT = IBTAB(INDDP(JS),2,IDIG)
            IF (JHIT.LE.0) GOTO 400
 200        CONTINUE
* We have a match, so see if this track has been seen before
               KSTR   = IBTAB(INDXR(JS),1,JHIT)
               IFOUND = 0
               NSTR   = 0
 300           CONTINUE
                  NSTR = NSTR + 1
                  IMAX = IW(INDTRU)
                  IF (2*NSTR.GE.IMAX) THEN
* Extend work bank (probably won't happen, but ...)
                     CALL WBANK(IW,INDTRU,2*IMAX,*9000)
                     CALL VZERO(IW(INDTRU+IMAX+1),IMAX)
                  ENDIF
                  IF (KSTR.EQ.IW(INDTRU+2*NSTR-1)) THEN
                     IFOUND = NSTR
                  ELSEIF (IW(INDTRU+2*NSTR-1).GT.0) THEN
                     GOTO 300
                  ENDIF
               IF (IFOUND.EQ.0) THEN
* New track number, so store it ...
                  IW(INDTRU+2*NSTR-1) = KSTR
                  IW(INDTRU+2*NSTR)   = 1
               ELSE
* ... or increment the counter
                  IW(INDTRU+2*NSTR)   = IW(INDTRU+2*NSTR) + 1
               ENDIF
* Now see if there's another hit for this digi (can happen!)
               JHIT = IBTAB(INDXR(JS),3,JHIT)
            IF (JHIT.GT.0) GOTO 200
 400     CONTINUE
* Get the next digi pointer, and see if we're back where we started
         IF (LCIRC(JS)) THEN
            IDIG = IBTAB(INDDP(JS),1,IDIG)
            IF (IDIG.NE.JDIG(JS)) GOTO 100
         ELSEIF (INUM.LT.NNDIG(JS)) THEN
            IDIG = IBTAB(INDDPX(JS),2,JDIG(JS)+INUM)
            GOTO 100
         ENDIF
 500  CONTINUE

*
* Now search through the list of tracks to find the best
*

      NHIT = 0
      NSTR = 0
 600  CONTINUE
         NSTR = NSTR + 1
         IF (IW(INDTRU+2*NSTR).GT.NHIT) THEN
            NHIT = IW(INDTRU+2*NSTR)
            JSTR = IW(INDTRU+2*NSTR-1)
         ENDIF
      IF (IW(INDTRU+2*NSTR-1).GT.0) GOTO 600

*
* Finally, count the total number of hits on the "best" track
*

      NPOSS  = 0
      INSTRX = NLINK('STRX',0)
      IF (INSTRX.LE.0 .OR. JSTR.LE.0) GOTO 900

      DO 800 JS=1,NSUBDT
* Only mask out a subdetector if the pointer is negative
         IF (JDIG(JS).LT.0 .OR. INDXR(JS).LE.0) GOTO 800
* Get first hit for this track
         JHIT = IBTAB(INSTRX,JS,JSTR)
         IF (JHIT.LE.0) GOTO 800
 700     CONTINUE
* Don't count a hit with no digi as findable
            IDIG  = IBTAB(INDXR(JS),2,JHIT)
            IF (IDIG.GT.0) THEN
               IDEAD = 0
               IF (LDWBK(JS)) THEN
* Check dead wire map (FT only, and only if unpacked banks exist)
* NB A wedge-pair can be half dead, but it's a pain to check!
                  ICELL = IBTAB(INDLC(JS),1,IDIG)
                  IDEAD = IBTAB(INDG1(JS),1,ICELL+1)
               ENDIF
               IF (IDEAD.EQ.0) NPOSS = NPOSS + 1
            ENDIF
* Get next hit for this track
            JHIT = IBTAB(INDXR(JS),4,JHIT)
         IF (JHIT.GT.0) GOTO 700
 800  CONTINUE

 900  CONTINUE

*
* Must make sure all work banks are dropped!!!
*

      CALL WDROP(IW,INDTRU)
      CALL WDROP(IW,INCVPR)
      DO JS=1,NSUBDT
         CALL WDROP(IW,INDDPX(JS))
      END DO

      RETURN

 9000 CONTINUE

      CALL ERRLOG(1301,'S:UTQSTR: Error in bank creation')

      GOTO 900

      END

*-------------------------------------------------------------------------
      SUBROUTINE H1GEA
*#**********************************************************************
*#                                                                     *
*#     SUBROUTINE H1GEA                                                *
*#                                                                     *
*# PURPOSE: Perform GEANT simulation for one event.                    *
*#                                                                     *
*# Main steering routine of module 'H1GEA'                             *
*#                                                                     *
*# Changed by M. Korn 02.12.94: merge A.F.'s changes of version        *
*#                              3.03/11 to actual version 3.05/04 in   *
*#                              order to allow for use of GEANT 3.21:  *
*# Changed by A.F. 24.08.94: Make use of seq's GCFLAK and LGCBNK for   *
*#         common GCFLAG and GCBANK-size respectively                  *
*#**********************************************************************
*KEEP,BCS.
      INTEGER      NHROW,NHCOL,NHLEN
      PARAMETER   (NHROW = 2, NHCOL = 1, NHLEN=2)
      INTEGER      NBOSIW
      PARAMETER   (NBOSIW=1000000)
      INTEGER      IW(NBOSIW)
      REAL         RW(NBOSIW)
      COMMON /BCS/ IW
      EQUIVALENCE (RW(1),IW(1))
      SAVE   /BCS/
*KEEP,BOSMDL.
C     ------BOSMDL
      LOGICAL       BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT
      COMMON/BOSMDL/BEGJOB,ENDRUN,BEGRUN,REVENT,ENDJOB,OTHDAT,
     +              LCCRUN,NCCRUN,NEVENT,
     +              IHA,IBS,IDB,IDATEL,LUP,ISN,JSN
      SAVE  /BOSMDL/
C     ------
*KEEP,GCTIME.
      COMMON/GCTIME/TIMINT,TIMEND,ITIME,IGDATE,IGTIME
      INTEGER ITIME,IGDATE,IGTIME
      REAL TIMINT,TIMEND
C
*KEEP,H1OSGO.
      COMMON /H1OSGO/ LCONFG,IGEAND(13),RGEANC(16),IGEANP(12)
*KEND.
*      "reduced GCFLAG COMMON to avoid clash of NEVENT variables from
*      BOS and GEANT

      COMMON/GCFLAG/IDEBUG,IDEMIN,IDEMAX,ITEST,IDRUN,IDEVT,IEORUN
     +        ,IEOTRI,IEVENT,ISWIT(10),IFINIT(20)

      CHARACTER*8 VERSQQ
      LOGICAL FIRST,POSITR,FIRSTP

      PARAMETER (NG=1500000)
      COMMON/GCBANK/Q(NG)

      LOGICAL graph /.FALSE./

      DATA FIRST/.TRUE./,FIRSTP/.TRUE./
*
*KEEP,STFUNCT.
*     index of element before row number IROW
      INDR(IND,IROW)=IND+2+IW(IND+1)*(IROW-1)
*     index of L'th element  of row number IROW
      INDCR(IND,L,IROW)=INDR(IND,IROW) + L
*     L'th integer element of the IROW'th row of bank with index IND
      IBTAB(IND,L,IROW)=IW(INDCR(IND,L,IROW))
*     L'th real element of the IROW'th row of bank with index IND
      RBTAB(IND,L,IROW)=RW(INDCR(IND,L,IROW))
*KEEP,VERSQQ.
      VERSQQ = ' 3.06/36'
      IVERSQ =  30636
*KEND.

*     random number handling requested (negative IVERSQ)
      CALL MODULS('H1GEA',-IVERSQ,'GTR GVX STRBSVXB')
      CALL MODDEF(30441)

      IF(BEGJOB)THEN
*
*KEEP,DATEQQ.
      IDATQQ = 980710
*KEEP,TIMEQQ.
      ITIMQQ =   1126
*KEND.
        WRITE(6,1000)IDATQQ,ITIMQQ
 1000   FORMAT(
     +'1**********************************************************'/
     +' ******   ',
*KEEP,QFTITLE,N=40.
     + 40H* H1SIM   3.06/36  23/02/96  17.47.42   
*KEND.
     +,'   ******'/
     +' ******    Compiled at date ',I6,'  and time ',I4,'    ******'/
     +' **********************************************************')
        NAHEAD=NAMIND('HEAD')
        NAHEAR=NAMIND('HEAR')
      ENDIF

*  overwrite HEAD bank with correct field value (even before geometry
*  definition !). For new data overwrite HEAR bank.

      IF(REVENT.OR.BEGRUN)THEN
        INHEAR=IW(NAHEAR)
        CALL UGTBNK('FIEL',INFIEL)

        IF(INHEAR.NE.0)THEN

*  create HEAR bank with new length
          INHEAR=NBANK('HEAR',0,22)
*  put in correct field value
          IF(INFIEL.EQ.0)THEN
            IW(INHEAR+ 6)=11600
          ELSE
            IW(INHEAR+ 6)=NINT(1000.*RW(INFIEL+1))
          ENDIF
*  for REVENT also add the information about e+/e- beams (influences
*  e-magnets in simulation)
          IF(REVENT)THEN
* calculate POSITR flag only once:
            IF(FIRSTP)THEN
              FIRSTP=.FALSE.
*         check GTR banks and find first lepton, assume positron as default
              POSITR=.TRUE.
              INDGTR=IW(NAMIND('GTR '))
              IF(INDGTR.GT.0)THEN
                NTR=IW(INDGTR+2)
                DO 5 ITR=1,NTR
                  IPDG=IBTAB(INDGTR,7,ITR)
                  IF(IABS(IPDG).EQ.11)THEN
                    POSITR=IPDG.EQ.-11
                    GOTO 6
                  ENDIF
5               CONTINUE
6               CONTINUE
              ENDIF
              IF(POSITR)THEN
                WRITE(6,*)' Positron magnet setup used.'
              ELSE
                WRITE(6,*)' Electron magnet setup used.'
              ENDIF
              LL=LUNLOG()
              IF(LL.GT.0)THEN
                IF(POSITR)THEN
                  WRITE(LL,'(A)')'Magnet setup: Positron'
                ELSE
                  WRITE(LL,'(A)')'Magnet setup: Electron'
                ENDIF
              ENDIF
            ENDIF
*         and add POSITR flag to HEAR bank
            IF(POSITR)IW(14)=IBSET(IW(14),16)
          ENDIF
        ELSE
          INHEAD=IW(NAHEAD)
          IF(INFIEL.EQ.0)THEN
            IW(INHEAD+10)=11600
          ELSE
            IW(INHEAD+10)=NINT(1000.*RW(INFIEL+1))
          ENDIF
        ENDIF
      ENDIF

* initialize setup only at first event (not at BEGRUN, because the
* information about beam polarity and therefor magnet polarity is only
* available at first event)

      IF(REVENT) THEN
*      prevent second initialisation if run number changes
        IF(FIRST)THEN
          FIRST=.FALSE.
*         create or modify steering banks using the OTTO bank
          CALL OTTOST
*         unpack steering information from banks OSGO and OSGD
          CALL UH1GEA
          CALL GZEBRA(NG)
*         "user" initialization
          CALL GUINIT
c---------------------------------------
      if(graph) then
*     set up workstation
      CALL IGINIT(-1000000)
c      CALL IGINIT(0)
      CALL IOPKS(0)
      CALL IOPWK(1,1,1)
      CALL IGRNG(20.,20.)
      CALL IACWK(1)
*     initialise drawing package
      CALL GDINIT
      endif
c---------------------------------------
          CALL TIMEL(TIMINT)
        ENDIF
      END IF


      if(graph) then
        CALL GINTER
      endif



*  overwrite first word in HEAD bank with information about
*  configuration setup (LCONFG=1,2,... coming from OSGO bank)

      IF(REVENT.OR.BEGRUN)THEN
          INHEAD=IW(NAHEAD)
          IF(INHEAD.GT.0)IW(INHEAD+1)=1+LCONFG
      ENDIF

      IF(REVENT) THEN
         IEVENT=IEVENT + 1
*        create SIPA bank containing relevant simulation parameters
         CALL USIPA
*        turn GTR/GVX banks into STR/SVX banks
         CALL USTSV
*        initialize event partition
         CALL GTRIGI
*        process event (trigger)
         CALL GTRIG
*        clear event partition
         CALL GTRIGC
      END IF

      IF(ENDJOB) THEN
*        "user" termination
         CALL GULAST
      END IF

      CALL MODULF
      CALL MODDEF(0)

      RETURN
      END

      SUBROUTINE GINTER
      CHARACTER*6 NAME
      CHARACTER*4 VNAME

      CALL GDRAWC('FWDT',2,0.0,10.0,10.0,0.1,0.1)
      CALL GDSCAL(su,sv)

      write(6,*) ' GINTER entered....type name of GEANT drawing routine'
 
   10 read(5,'(A6)') NAME

      IF(NAME.EQ.'STOP') STOP
      IF(NAME.EQ.'GDRAWC') THEN
        WRITE(6,*) 'Enter VNAME,IAXIS,CUTVAL,U0,V0,SU,SV'
        READ(5,'(A4,1x,I1,1x,5F5.1)') vname,iaxis,cutval,u0,v0,su,sv
c        CALL ICLRWK(0,1)
        CALL GDRAWC(vname,iaxis,cutval,u0,v0,su,sv)
        CALL GDSCAL(su,sv)
        GO TO 10
      ENDIF
      IF(NAME.EQ.'GDRAWX') THEN
        WRITE(6,*) 'Enter VNAME,CUTTHE,CUTPHI,CUTVAL,TH,PHI,U0,V0,SU,SV'
        READ(5,'(A4,1x,9F6.2)') vname,cutthe,cutphi,cutval,
     &                                theta,phi,u0,v0,su,sv
        CALL ICLRWK(0,1)
        CALL GDRAWX(vname,cutthe,cutphi,cutval,theta,phi,u0,v0,su,sv)
        CALL GDSCAL(su,sv)
        GO TO 10
      ENDIF
      IF(NAME.EQ.'CLEAR') CALL ICLRWK(0,1)

      GO TO 10

      RETURN
      END


*-----------------------------------------------------------------------

