*CMZU:  8.06/00 10/10/96  14.50.17  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZ :  2.00/00 17/12/90  15.55.42  by  Girish D. Patel
*-- Author :    S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*     Function to calculate the Lorenz angle correction to the
*     radius of hits (along the wire).
*
*     The correction is simply linear with drift distance for now.
*
*HTMLI     : Describe the Input variables to the routine
*
*     RADIUS :  uncorrected radial coordinate,
*     DRIFT  :  drift coordinate and
*     DRFSGN :  sign of the drift (+1.0 or -1.0)
*
*HTMLO     : Describe the Output of the routine
*
*     Usage:
*     -----
*          Rcorrected = RADIUS + FLOREN(RADIUS,DRIFT,DRFSGN)
*
*HTMLE     : Terminates the HTML documentation
*
      FUNCTION FLOREN(RADIUS,DRIFT,DRFSGN)
*
*     Function to calculate the Lorenz angle correction to the
*     radius of hits (along the wire).
*
*     The correction is simply linear with drift distance for now.
*
*     Usage:
*     -----
*          Rcorrected = RADIUS + FLOREN(RADIUS,DRIFT,DRFSGN)
*
*     where RADIUS :  uncorrected radial coordinate,
*           DRIFT  :  drift coordinate and
*           DRFSGN :  sign of the drift (+1.0 or -1.0)
*     are the inputs to the function.
*     The tangent of the Lorenz angle, ATLORR, is provided in
*     COMMON block FRLORA.
*
*
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*KEND.
      FLOREN = - DRFSGN * ATLORR * DRIFT
      RETURN
      END
*CMZU:  8.06/00 10/10/96  14.47.44  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZU:  8.03/00 03/06/96  14.58.27  by  Katharina Mueller
*CMZU:  6.00/14 06/03/95  15.51.43  by  Stephen Burke
*CMZU:  5.03/00 03/11/94  17.54.01  by  Stephen Burke
*CMZ :  4.03/13 14/04/94  09.32.23  by  Gaby Raedel
*CMZU:  3.09/01 19/05/93  11.50.49  by  Stephen J. Maxfield
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*     This routine performs several initialisation functions for the
*     Forward tracker reconstruction. Parameters, flags etc are read
*     from steering banks
*
*HTMLI     : Describe the Input variables to the routine
*
*     Following steering banks are used:
*
*  <A HREF="FRCS.DDL.html">FRCS</A> - Diagnostic flags
*  <A HREF="FPRP.DDL.html">FPRP</A> - Radial pat.rec. parameters
*  <A HREF="FPPP.DDL.html">FPPP</A> - Planar pat.rec. parameters
*
*HTMLO     : Describe the Output of the routine
*
*  Calls:   FTDGEO - initialise geometry etc. for IOS
*           FTCORG - initialise geometrical constants
*
*  Creates  <A HREF="FRG1.DDL.html">FRG1</A> ,
*           <A HREF="FPG1.DDL.html">FPG1</A>
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTINT
**: FPTINT.......SM. Pick up pattern recognition parameters from bank.
**----------------------------------------------------------------------
*=====================================================================*
*                                                                     *
*     This routine performs several initialisation functions for the  *
*     Forward tracker reconstruction. Parameters, flags etc are read  *
*     from the following banks:-                                      *
*                                                                     *
*     FRCS  - Diagnostic flags                                        *
*     FPRP  - Flags and parameters used by pattern recognition        *
*     FPPP  - Flags and parameters used by pattern recognition        *
*                                                                     *
*     Calls FTDGEO - initialise geometry etc. for IOS                 *
*           FTCORG - initialise geometrical constants - create FRG1   *
*                                                              FPG1   *
*                                                                     *
*=====================================================================*
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
*
*KEEP,FGMIOS.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,FRWERR.
      COMMON /WERR/ERRVL,ERRV,ERRP,ERRRX
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FSGPAR.
      COMMON/FSGPAR/DMINX, PHIT, TSCUT, SLCUT, RCUT, TSLPC,
     +              MINHTS, MINPTS, MAXCLU, LSCUT, NWIRES, IPLOT
*KEEP,FJNPAR.
      COMMON/FJNPAR/
     +      CHT3, CHT12, CHT23, CHT13,
     +      PCT3, PCT12, PCT23, PCT13,
     +      PSC3, PSC12, PSC23, PSC13,
     +      RCT3, RCT12, RCT23, RCT13
*KEEP,FPJPAR.
      COMMON/FPJPAR/
     +      RRCUT1, RRCUT2, RRCUT3,
     +      PLCC3, PLCC12, PLCC23, PLCC13
*KEND.

      PARAMETER(TWOPI=6.2831853)

*     Access Steering (Diagnostics, Histograms etc.)
*
*
      CALL UGTBNK('FRCS',INDRCS)
      IF(INDRCS.EQ.0) THEN
*     Assume no diagnostics wanted but give warning...
       CALL ERRLOG(108,'F:FPTINT: No FRCS bank found. Defaults taken')
       IDIAG = 0
       IDIAG2= 0
       MAXPRT= 0
       IDOHIS= 0
       IREZ  = 0
*      Unit number for HBOOK Histogram output.
       LUNFP  = 17
*      Diagnostics applied only if measured momentum greater than...
       PMCUT = 10000.
      ELSE
       IVERS1= LW(INDRCS + 1)
       IF(IVERS1 .EQ. 290492) THEN
         IDIAG = LW(INDRCS + 2)
         IDIAG2= LW(INDRCS + 3)
         MAXPRT= LW(INDRCS + 4)
         IDOHIS= LW(INDRCS + 5)
         IREZ  = LW(INDRCS + 6)
         PMCUT = SW(INDRCS + 7)
       ELSE
         CALL ERRLOG(109,'F:FPTINT: Wrong FRCS version. Defaults taken')
       ENDIF
      ENDIF

*     Vertex.  Assume at zero for now.
      ZV   =   0.0
      XVV  =   0.0
      YVV  =   0.0

*     Cuts and parameters from FPRP bank.
*     Set default values...
*
*     Drift and radial coordinate errors...
      ERRP  = 0.04
      ERRRX = 4.5
      ERRV  = 0.02
      ERRVL = 10.0

*     Cuts and parameters for FTLSEG...

*     Maximum  distance ( in drift) for digitising
*     to be associated with cluster
*     ie road width is 2.*dminx  (cms.)
      DMINX=0.20
*     Maximum  distance ( in phi  ) for digitising
*     to be associated with cluster =  .1 cm/r  approx
      PHIT   = 0.05
*     Minimum size of cluster for starting triple finding
      MINHTS = 3
*     minimum number of points/track segment
      MINPTS = 4
*     max size of cluster for analysis
      MAXCLU = 50
*     ABS((D1+D3)/2 -D2 ).LT.TSCUT for triple
      TSCUT  = 0.1
*     Max slope for triple
      TSLPC  = 0.5
*     Slope cut for joining triples
      SLCUT  = 0.2
*     Min length of segment before extension by projection
      LSCUT  = 3
*     Cut in r for triple and projection
      RCUT   = 20.
*     Number of wires in radials
      NWIRES = 12
*     IPLOT=0 for no diagnostic t0, rms to line seg,  plots: max speed
      IPLOT  = 0


*     Cuts and parameters for Planar pickup.
      IPLAR = 1
      NIT   = 3

*     Road widths for single point pick-up...
      PCUT1 = 1.0
      PCUT2 = 0.5
      PCUT3 = 0.2
      CXP   = 0.0
      CYP   = 0.0
*     Road widths for segment pick-up (millimetres!)
      DRPCT1 = 30.
      DRPCT2 = 20.
      DRPCT3 = 20.
      DRCUT1  = 200.
      DRCUT2  = 75.
      DRCUT3  = 75.

*     Cuts and parameters for radial segment linking...
      CHT3  = 100.0
      CHT12 = 100.0
      CHT23 = 100.0
      CHT13 = 100.0

      PCT3  = 0.04
      PCT12 = 0.04
      PCT23 = 0.04
      PCT13 = 0.04

      PSC3  = 0.002
      PSC12 = 0.002
      PSC13 = 0.002
      PSC23 = 0.002

      RCT3  = 20.0
      RCT12 = 20.0
      RCT23 = 20.0
      RCT13 = 20.0


      CALL UGTRUN('FPRP',INDPRP)

      IF(INDPRP.EQ.0) THEN
*     Take defaults but give warning...
       CALL ERRLOG(110,'F:FPTINT: No FPRP bank found. Defaults taken')
      ELSE
       IVERS2=      LW(INDPRP + 1)
       IF(IVERS2 .EQ. 300994)THEN
         ERRP  =      SW(INDPRP + 2)
         ERRRX =      SW(INDPRP + 3)
         ERRV  =      SW(INDPRP + 4)
         ERRVL =      SW(INDPRP + 5)

         IPLAR =      LW(INDPRP + 6)
         NIT   =      LW(INDPRP + 7)
         PCUT1 =      SW(INDPRP + 8)
         PCUT2 =      SW(INDPRP + 9)
         PCUT3 =      SW(INDPRP +10)
         CXP   =      SW(INDPRP +11)
         CYP   =      SW(INDPRP +12)
         DRPCT1=      SW(INDPRP +13)
         DRPCT2=      SW(INDPRP +14)
         DRPCT3=      SW(INDPRP +15)
         DRCUT1=      SW(INDPRP +16)
         DRCUT2=      SW(INDPRP +17)
         DRCUT3=      SW(INDPRP +18)

         DMINX =      SW(INDPRP +19)
         PHIT  =      SW(INDPRP +20)
         MINHTS=      LW(INDPRP +21)
         MINPTS=      LW(INDPRP +22)
         MAXCLU=      LW(INDPRP +23)
         TSCUT =      SW(INDPRP +24)
         TSLPC =      SW(INDPRP +25)
         SLCUT =      SW(INDPRP +26)
         LSCUT =      LW(INDPRP +27)
         RCUT  =      SW(INDPRP +28)
         NWIRES=      LW(INDPRP +29)
         IPLOT =      LW(INDPRP +30)

         CHT3  =      SW(INDPRP +31)
         CHT12 =      SW(INDPRP +32)
         CHT23 =      SW(INDPRP +33)
         CHT13 =      SW(INDPRP +34)

         PCT3  =      SW(INDPRP +35)
         PCT12 =      SW(INDPRP +36)
         PCT23 =      SW(INDPRP +37)
         PCT13 =      SW(INDPRP +38)

         PSC3  =      SW(INDPRP +39)
         PSC12 =      SW(INDPRP +40)
         PSC13 =      SW(INDPRP +41)
         PSC23 =      SW(INDPRP +42)

         RCT3  =      SW(INDPRP +43)
         RCT12 =      SW(INDPRP +44)
         RCT23 =      SW(INDPRP +45)
         RCT13 =      SW(INDPRP +46)

       ELSE
         CALL ERRLOG(111,'F:FPTINT: Wrong FPRP version. Defaults taken')
       ENDIF
      ENDIF

*     Errors and cuts used in pattern recognition in Planars(RWCH)
      RESOL = 0.24
      ACUT  = 7.0
      RMIN = 185.0
      RMAX = 755.0
      NPLMAX = 10000
*     Cuts used in planar-planar linking.
      RRCUT1 = 5.0
      RRCUT2 = 1.0
      RRCUT3 = 1.0
      PLCC3  = 100.0
      PLCC12 = 100.0
      PLCC23 = 100.0
      PLCC13 = 100.0

      CALL UGTBNK('FPPP',INDPPP)
      IF(INDPPP.EQ.0) THEN
*     Take defaults but give warning...
       CALL ERRLOG(112,'F:FPTINT: No FPPP bank found. Defaults taken')
      ELSE
       IVERS3=      LW(INDPPP + 1)
       IF(IVERS3 .EQ.  11194) THEN
         RESOL =      SW(INDPPP + 2)
         ACUT  =      SW(INDPPP + 3)
         RMIN  =      SW(INDPPP + 4)
         RMAX  =      SW(INDPPP + 5)
         NPLMAX=      LW(INDPPP + 6)
         RRCUT1=      SW(INDPPP + 7)
         RRCUT2=      SW(INDPPP + 8)
         RRCUT3=      SW(INDPPP + 9)
         PLCC3 =      SW(INDPPP +10)
         PLCC12=      SW(INDPPP +11)
         PLCC23=      SW(INDPPP +12)
         PLCC13=      SW(INDPPP +13)
       ELSE
         CALL ERRLOG(113,'F:FPTINT: Wrong FPPP version. Defaults taken')
       ENDIF
      ENDIF



*     One small consistency check:-
      IF(IDOHIS .EQ. 0 .AND. IREZ .NE. 0) THEN
         IREZ=0
      ENDIF
*     Fill COMMONS FRDGEO and FPLGEO with nominal geometry...
*     ...and set up Geometry by wire plane number for IOS
      CALL FTDGEO
*     Create corrected geometry banks FRG1 and FPG1...
      CALL FTCORG
      WRITE(6,*)
     +  '  '
      WRITE(6,*)
     +  '  '
      WRITE(6,*)
     +  '+----------------------------------------------------------+'
      WRITE(6,*)
     +  '          FTREC Steering parameters and flags     '
      WRITE(6,*)
     +  '          ===== ======== ========== === =====     '
      WRITE(6,*)
     +  '  '
      WRITE(6,*)
     +  '--------- FRCS Steering Flags ------------------- '
      WRITE(6,'(A50,I10)')
     +  ' Bank version number                              ', IVERS1
      WRITE(6,'(A50,I10)')
     +  ' DIAGNOSTIC print FLAG 0 = None;1=more;2=yet more ', IDIAG
      WRITE(6,'(A50,I10)')
     +  ' DIAGNOSTIC print FLAG 1 = single line per event  ', IDIAG2
      WRITE(6,'(A50,I10)')
     +  ' Number of events for diag print out              ', MAXPRT
      WRITE(6,'(A50,I10)')
     +  ' Histograms 0=off   1=some   2=more(lots)         ', IDOHIS
      WRITE(6,'(A50,I10)')
     +  ' Additional residual histograms if >0             ', IREZ
      WRITE(6,'(A50,F10.3)')
     +  ' PMCUT (GeV) - no diags if pmeas < PMCUT          ', PMCUT
      WRITE(6,*)
     +  '  '
      WRITE(6,*)
     +  '--------- FPRP Parameters     ------------------- '
      WRITE(6,'(A50,I10)')
     +  ' Bank version number                              ', IVERS2
      WRITE(6,'(A50,F10.3)')
     +  ' Nominal drift coordinate error                   ', ERRP
      WRITE(6,'(A50,F10.3)')
     +  ' Nominal radial coordinate error                  ', ERRRX
      WRITE(6,'(A50,F10.3)')
     +  ' Nominal vertex error                             ', ERRV
      WRITE(6,'(A50,F10.3)')
     +  ' Nominal verex error 2                            ', ERRVL
      WRITE(6,'(A50,I10)')
     +  ' IPLAR  Pick up planar points as:-                ', IPLAR
      WRITE(6,'(A50,I10)')
     +  ' NIT      Number of iterations in point pick-up   ', NIT
      WRITE(6,'(A50,F10.3)')
     +  ' PCUT1  )      (mm)                               ', PCUT1
      WRITE(6,'(A50,F10.3)')
     +  ' PCUT2  ) road widths for planar point pick-up    ', PCUT2
      WRITE(6,'(A50,F10.3)')
     +  ' PCUT3  )                                         ', PCUT3
      WRITE(6,'(A50,F10.3)')
     +  ' CXP    ) planar displacements.                   ', CXP
      WRITE(6,'(A50,F10.3)')
     +  ' CYP    )                                         ', CYP
      WRITE(6,'(A50,F10.3)')
     +  ' DRPCT1 )                                         ', DRPCT1
      WRITE(6,'(A50,F10.3)')
     +  ' DRPCT2 ) r-Phi road for segment pick-up          ', DRPCT2
      WRITE(6,'(A50,F10.3)')
     +  ' DRPCT3 )                                         ', DRPCT3
      WRITE(6,'(A50,F10.3)')
     +  ' DRCUT1 )                                         ', DRCUT1
      WRITE(6,'(A50,F10.3)')
     +  ' DRCUT2 ) Max allowed r-sep                       ', DRCUT2
      WRITE(6,'(A50,F10.3)')
     +  ' DRCUT3 )                                         ', DRCUT3
*
      WRITE(6,'(''    '')')
      WRITE(6,'(10X,''   Ftlseg Cuts:-'')')
      WRITE(6,'(10X,''   ====== ====:-'')')
      WRITE(6,'(A50,F10.3)')
     +  ' DMINX    Max dist in drift digi->cluster         ', DMINX
      WRITE(6,'(A50,F10.3)')
     +  ' PHIT     Max dist in Phi   digi->cluster         ', PHIT
      WRITE(6,'(A50,I10)')
     +  ' MINHTS   Min cluster size to start triple        ', MINHTS
      WRITE(6,'(A50,I10)')
     +  ' MINPTS   Min points per radia segment            ', MINPTS
      WRITE(6,'(A50,I10)')
     +  ' MAXCLU   Max size of cluster for analysis        ', MAXCLU
      WRITE(6,'(A50,F10.3)')
     +  ' TSCUT    abs( (d1+d3)/2 - d2 )<tscut for triple  ', TSCUT
      WRITE(6,'(A50,F10.3)')
     +  ' TSLPC    max slope for triples                   ', TSLPC
      WRITE(6,'(A50,F10.3)')
     +  ' SLCUT    slope cut for joining triples           ', SLCUT
      WRITE(6,'(A50,I10)')
     +  ' LSCUT    min seg length for extension by proj    ', LSCUT
      WRITE(6,'(A50,F10.3)')
     +  ' RCUT     radius cut for triple and projection    ', RCUT
      WRITE(6,'(A50,I10)')
     +  ' NWIRES   Num wires in radial SM                  ', NWIRES
      WRITE(6,'(A50,I10)')
     +  ' IPLOT    diagnostic t0 etc. plots if =1          ', IPLOT
*
      WRITE(6,'(''    '')')
      WRITE(6,'(10X,''   Radial linking Cuts:-'')')
      WRITE(6,'(A50,F10.3)')
     +  ' CHT3     )                                       ', CHT3
      WRITE(6,'(A50,F10.3)')
     +  ' CHT12    )  Cut on Chisq from link fit           ', CHT12
      WRITE(6,'(A50,F10.3)')
     +  ' CHT23    )                                       ', CHT23
      WRITE(6,'(A50,F10.3)')
     +  ' CHT13    )                                       ', CHT13
      WRITE(6,'(A50,F10.3)')
     +  ' PCT3     )                                       ', PCT3
      WRITE(6,'(A50,F10.3)')
     +  ' PCT12    )  Phi continuity check                 ', PCT12
      WRITE(6,'(A50,F10.3)')
     +  ' PCT23    )                                       ', PCT23
      WRITE(6,'(A50,F10.3)')
     +  ' PCT13    )                                       ', PCT13
      WRITE(6,'(A50,F10.3)')
     +  ' PSC3     )                                       ', PSC3
      WRITE(6,'(A50,F10.3)')
     +  ' PSC12    )  Checksum cut for straight line in    ', PSC12
      WRITE(6,'(A50,F10.3)')
     +  ' PSC13    )  Phi.                                 ', PSC23
      WRITE(6,'(A50,F10.3)')
     +  ' PSC23    )                                       ', PSC13
      WRITE(6,'(A50,F10.3)')
     +  ' RCT3     )                                       ', RCT3
      WRITE(6,'(A50,F10.3)')
     +  ' RCT12    )  R vs. z line points to z=0           ', RCT12
      WRITE(6,'(A50,F10.3)')
     +  ' RCT23    )                                       ', RCT23
      WRITE(6,'(A50,F10.3)')
     +  ' RCT13    )                                       ', RCT13
      WRITE(6,*)
     +  '  '
      WRITE(6,*)
     +  '--------- FPPP Parameters     ------------------- '
      WRITE(6,'(A50,I10)')
     +  ' Bank version number                              ', IVERS3
      WRITE(6,'(A50,F10.3)')
     +  ' Nominal Resolution (mm)                          ', RESOL
      WRITE(6,'(A50,F10.3)')
     +  ' ACUT for segment finding                         ', ACUT
      WRITE(6,'(A50,F10.3)')
     +  ' RMIN  (mm)                                       ', RMIN
      WRITE(6,'(A50,F10.3)')
     +  ' RMAX  (mm)                                       ', RMAX
      WRITE(6,'(A50,I10)')
     +  ' NPLMAX max pla hits allowed for call to FPSEG    ', NPLMAX
      WRITE(6,'(A50,F10.3)')
     +  ' RRCUT1 linking cut for two primary segments      ', RRCUT1
      WRITE(6,'(A50,F10.3)')
     +  ' RRCUT2 linking cut for two secondary segments    ', RRCUT2
      WRITE(6,'(A50,F10.3)')
     +  ' RRCUT3 linking cut for two tertiary segments     ', RRCUT3
      WRITE(6,'(A50,F10.3)')
     +  ' PLCC3   Chi-squared-like cut for 3 mod links     ', PLCC3
      WRITE(6,'(A50,F10.3)')
     +  ' PLCC12  Chi-squared-like cut for 3 mod links     ', PLCC12
      WRITE(6,'(A50,F10.3)')
     +  ' PLCC23  Chi-squared-like cut for 3 mod links     ', PLCC23
      WRITE(6,'(A50,F10.3)')
     +  ' PLCC13  Chi-squared-like cut for 3 mod links     ', PLCC13
      WRITE(6,*)
     +  '  '
      WRITE(6,*)
     +  '+----------------------------------------------------------+'
*DEBUG - Check Geometry:
      IF(IDIAG.GE.4) THEN
        WRITE(6,776)
        DO 6 K=1,36
         WRITE(6,777)K,ZP(K),PHW(K),WS(K)
  6     CONTINUE
        WRITE(6,887)
        DO 204 K=1,36
         WRITE(6,888)K,ZPP(K),WZERO(K),C(K),S(K),ITYPE(K)
 204    CONTINUE
      ENDIF
 887  FORMAT(' ',' IOS Planar Geometry',/,
     +       ' WIR         Z     WZERO       COS       SIN TYP')
 888  FORMAT(' ',I4,2F10.3,2F10.6,I4)
 776  FORMAT(' ', '     Radial Geometry',/,
     +       ' WIR       ZPP       PHI      STAG')
 777  FORMAT(' ',I4,3F10.3)
*END DEBUG
      RETURN
      END
*CMZU:  8.06/00 11/10/96  10.35.37  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZU:  5.03/00 24/02/94  16.36.50  by  Stephen J. Maxfield
*CMZ :  2.00/00 12/12/90  17.35.39  by  Girish D. Patel
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Provides location of primary vertex for radial segment finding
*  code. Presently returns 0,0,0 but should in future return the
*  generated value for MC
*
*HTMLI     : Describe the Input variables to the routine
*
*  None at present / SVX bank in future?
*
*HTMLO     : Describe the Output of the routine
*
*  Returns vertex via common FPTVTX
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTVER
*========================================================
* Location of interaction point for the run.
* Dummy routine for now. Eventually get vertex from database?
* Get from elsewhere for Monte Carlo?
*========================================================
*
*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,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*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.
      XVV  = 0.0
      YVV  = 0.0
      ZV   = 0.0
      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.25.50  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.39  by  Girish D. Patel
* Wrong NUMWPL changed in previous correction
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Zero some arrays etc. in COMMON before processing each event
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTZER
*===============================================================*
*                                                               *
*     Zero some arrays etc. before processing each event        *
*                                                               *
*===============================================================*
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEND.
      LNARR=NUMWPL
      CALL VZERO(NDP,LNARR)
      CALL VZERO(NDPW,LNARR)
      LNARR=MAXHTS*NUMWPL
      CALL VZERO(IPFRRE,LNARR)
      CALL VZERO(IPFRPE,LNARR)
      LNARR=MAXDIG*2
      CALL VZERO(IRPIOS,LNARR)
      CALL VZERO(IPPIOS,LNARR)
      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.26.01  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZU:  7.00/04 27/04/95  15.13.59  by  Stephen Burke
*CMZU:  6.00/00 24/11/94  15.49.04  by  Stephen J. Maxfield
*CMZ :  4.03/03 22/01/94  19.22.17  by  Gaby Raedel
*CMZU:  3.09/07 26/07/93  10.00.24  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   08/03/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*     Build tables of corrected geometry for Radial and Planar
*     Drift Chambers. To be called at beginning of each New Run
*
*HTMLI     : Describe the Input variables to the routine
*
*     Nominal geometry:- <A HREF="FGAR.DDL.html">FGAR</A> and
*                        <A HREF="FGAP.DDL.html">FGAP</A>
*     Corrections     :- <A HREF="F1RC.DDL.html">F1RC</A> ,
*                        <A HREF="F1PC.DDL.html">F1PC</A> ,
*                        <A HREF="FCP1.DDL.html">FCP1</A>
*     Dead wire maps  :- <A HREF="FRDW.DDL.html">FRDW</A> ,
*                        <A HREF="FPDW.DDL.html">FPDW</A>
*     Later: shifts from 'shift banks' (not yet implemented)
*
*HTMLO     : Describe the Output of the routine
*
*     <A HREF="FRG1.DDL.html">FRG1</A> and
*     <A HREF="FPG1.DDL.html">FPG1</A> banks
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTCORG
*D: FTCORG.......SM.  Extension of FRG1 bank to include asymmetry.
*D: FTCORG.......SM.  Get effective stagger from new FCR3 bank.
*D: FTCORG.......SM.  Extension of FPG1 bank to include asymmetry.
*D: FTCORG.......SM.  Get effective stagger from FCP1 bank.
**: FTCORG 30907 RP.  Farm changes.
**----------------------------------------------------------------------
*     ========== ======
*     Build tables of corrected geometry for Radial and Planar
*     Drift Chambers.
*  *---------------------------------------------*
*  *  To be Called at beginning of each New Run  *
*  *---------------------------------------------*
*
*  INPUT: Nominal geometry:- FGAR and FGAP Banks
*         Corrections     :- F1RC, F1PC, FCP1
*         Dead wire maps  :- FRDW, FPDW
*         Later: shifts from 'shift banks'
*
*  OUTPUT:  FRG1 and FPG1 banks
*
*!       BANKname BANKtype      ! Comments
* TABLE  FRG1                   ! Corrected geometry of Radial Chambers
*                               ! Row number = Cell number + 1
*                               ! TEMPORARY.
*!   ATTributes:
*!   -----------
*!COL ATT-name FMT Min    Max   ! Comments
*!
*  1  IDEAD    I                !  Dead wire indicator: 0=OK 1=dead
*  2  PHIWP    F                !  Angle of +wire
*  3  STAGP    F                !  Stagger of +wire (effective)
*  4  ZWP      F                !  Z of +wire
*  5  PHIWM    F                !  Angle of -wire
*  6  STAGM    F                !  Stagger of -wire (effective)
*  7  ZWM      F                !  Z of -wire
*  8  STAGEP   F                !  Stagger of +wire (geometric)
*  9  STAGEM   F                !  Stagger of -wire (geometric)
*!
* END TABLE
*!       BANKname BANKtype      ! Comments
* TABLE  FPG1                   ! Corrected geometry of Planar Chambers
*                               ! Row number = Cell number
*                               ! TEMPORARY.
*!   ATTributes:
*!   -----------
*!COL ATT-name FMT Min    Max   ! Comments
*!
*  1  IDEAD    I                !  Dead wire indicator: 0=OK 1=dead
*  2  PHIW     F                !  Angle of wire
*  3  STAGE    F                !  Effective Stagger of wire
*  4  ZWP      F                !  Z of wire
*  5  STAGG    F                !  Geometric  Stagger of wire
*!
* END TABLE
*#**********************************************************************
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FWINDS.
*     Work bank indices...
      COMMON/FWINDS/ INFRRE, INFRPE, ILWPG1, ILWRG1
*KEND.
*
*
*
      PARAMETER(TWOPI=6.283185)
      PARAMETER(NBN=0)
*     Locators for geometrical data in F1RC bank...
      PARAMETER(ILDPPL=1)
      PARAMETER(ILDPMI=2)
      PARAMETER(ILDSPL=3)
      PARAMETER(ILDSMI=4)

*     Locators for geometrical data in F1PC bank...
      PARAMETER(ILPPHI=1)
      PARAMETER(ILPSTA=2)

*     Locators for data in FCP1 bank...
      PARAMETER(ILSTEP=21)

*     Locators for data in FCR3 bank...
      PARAMETER(ILSTER=51)

*     dead wire map...
      PARAMETER(ILDEAD=1)

      PARAMETER(ILENR=9)
      PARAMETER(ILENP=5)
*     Local arrays
      DIMENSION PPSTRT(0:8),PZSTRT(0:8),PSTAGG(0:8)
      DIMENSION RPSTRT(0:2),RZSTRT(0:2)
      DIMENSION BAR(ILENR), IAR(ILENR)
      EQUIVALENCE(BAR(1), IAR(1))
      LOGICAL FIRST
      DATA    FIRST/.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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

*----------------------------------------------------------------------
*----------------------------------------------------------------------
*     Access nominal geometry banks FGAR and FGAP
      IF(FIRST) THEN
*     --------------
        FIRST = .FALSE.
        CALL BKFMT('FRG1','2I,(6F)')
        CALL BKFMT('FPG1','2I,(3F)')
        IQFRG1 = NAMIND('FRG1')
        IQFPG1 = NAMIND('FPG1')
        CALL UGTBNK('FGAR',INFGAR)
        IF( INFGAR .EQ. 0) THEN
           WRITE(6,*)' ***FTCORG >> FGAR BANK NOT FOUND'
           CALL H1STOP
        ENDIF
        CALL UGTBNK('FGAP',INDP)
        IF( INDP .EQ. 0) THEN
           WRITE(6,*)' ***FTCORG >> FGAP BANK NOT FOUND'
           CALL H1STOP
        ENDIF

*       Get basic radial parameters...
        NMOD  = IW(INFGAR+3)
        NWED  = IW(INFGAR+4)
        NZPL  = IW(INFGAR+5)
        NCHANR = NMOD*NWED*NZPL/2
*
        DPHI  = TWOPI / FLOAT(NWED)
        STAG  = RW(INFGAR+6)
        ZSEP  = RW(INFGAR+7)
        KIND  = INFGAR + IW(INFGAR+1) + 1
*
        DO 1 KMOD = 0, NMOD-1
          RZSTRT(KMOD)  = RW(KIND+3)
          RPSTRT(KMOD)  = RW(KIND+4)
          KIND   = KIND + IW(KIND+1) + 1
 1      CONTINUE
*
*     Get basic planar parameters...
        NMODP = IW(INDP+3)
        NWEDP = IW(INDP+4)
        NZPLP = IW(INDP+5)
        NCHANP = NMODP*NWEDP*NZPLP
*
        ZSEPP = RW(INDP+6)
        WZERP = RW(INDP+7)
        WSEPP = RW(INDP+8)
        KIND  = INDP + IW(INDP+1) + 1
        DO 2 KMOD = 0, NMODP-1
          PZSTRT(KMOD)  = RW(KIND+3)
          PPSTRT(KMOD)  = RW(KIND+4) - TWOPI/4.
          PSTAGG(KMOD)  = RW(KIND+5)
          KIND   = KIND + IW(KIND+1) + 1
 2      CONTINUE
*
      ENDIF
*     -----
*
*     Hit database for bank with corrections to nominal geometry
      CALL UGTBNK('F1RC',INDC)
      IF( INDC .EQ. 0) THEN
         WRITE(6,*)' ***FTCORG >> F1RC BANK NOT FOUND'
         CALL H1STOP
      ENDIF
*     Hit database for effective stagger.
      CALL UGTBNK('FCR3',INDCR3)
      IF( INDCR3 .EQ. 0) THEN
         WRITE(6,*)' ***FTCORG >> FCR3 BANK NOT FOUND'
         CALL H1STOP
      ENDIF
*     Hit database for dead wire map
      CALL UGTRUN('FRDW',INDD)
      IF( INDD .EQ. 0) THEN
         WRITE(6,*)' ***FTCORG >> FRDW BANK NOT FOUND'
         CALL H1STOP
      ENDIF

*     Check if old FRG1 bank exists. If so drop it.
      INDDUM =  IW(IQFRG1)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FRG1')
      ENDIF
*
      DO 3 JJ = 0, NCHANR-1
*       Get dead wire flag...
        IAR(1)     =  IBTAB(INDD,ILDEAD,JJ+1)

*       Phi of wires at plus and minus end. Nominal...
        PWP        =  RPSTRT(IRMOD(JJ)) + DPHI*IRWPL(JJ) + DPHI/2
        PWM        =  RPSTRT(IRMOD(JJ)) + DPHI*IRWMI(JJ) + DPHI/2
*       ... add corrections
        BAR(2)     =  PWP  + RBTAB(INDC,ILDPPL,JJ+1)
        BAR(5)     =  PWM  + RBTAB(INDC,ILDPMI,JJ+1)


*       Geometric stagger of wire...
        PSTGR     =  STAG*( (-1)**IRZPL(JJ) )

*       Effective Stagger of wire.
        PSTEFR    =  RBTAB(INDCR3,ILSTER,1)

*       Attach sign of geometric stagger...
        IF(PSTGR .LT. 0.0) PSTEFR = -PSTEFR

*       Monte Carlo has no effective stagger...
        IF(MONTE)PSTEFR = PSTGR

*       Stagger of plus and minus wires (effective) corrected for
*       geometric offsets from nominal...
        BAR(3)       = PSTEFR + RBTAB(INDC,ILDSPL,JJ+1)
        BAR(6)       = PSTEFR + RBTAB(INDC,ILDSMI,JJ+1)


*       Z of wire (nominal only)
        BAR(4)      = RZSTRT(IRMOD(JJ)) + ZSEP*IRZPL(JJ) + ZSEP/2.0
        BAR(7)      = BAR(4)

*       Stagger of plus and minus wires (geometric) corrected for
*       geometric offsets from nominal...
        BAR(8)       = PSTGR + RBTAB(INDC,ILDSPL,JJ+1)
        BAR(9)       = PSTGR + RBTAB(INDC,ILDSMI,JJ+1)


*GDP
*      WRITE(6,'('' ** FTCORG.R *'',3I4,8(1X,F7.3))') JJ,IRMOD(JJ),
*    & IRZPL(JJ),IAR(1),(BAR(II),II=2,9)
*GDP
        IFRG1       = IADROW('FRG1',NBN,ILENR,BAR)

 3    CONTINUE
      IFRG1  = IADFIN('FRG1',NBN)
*
*
*
* ------------------------------------------------------------------
*
*             Planar Geometry
*
*
*     Hit database for bank with corrections to nominal geometry
      CALL UGTBNK('F1PC',INDC)
      IF( INDC .EQ. 0) THEN
         WRITE(6,*)' ***FTCORG >> F1PC BANK NOT FOUND'
         CALL H1STOP
      ENDIF
*     Hit database for effective stagger.
      CALL UGTBNK('FCP1',INDCP1)
      IF( INDCP1 .EQ. 0) THEN
         WRITE(6,*)' ***FTCORG >> FCP1 BANK NOT FOUND'
         CALL H1STOP
      ENDIF
*     Hit database for dead wire map
      CALL UGTRUN('FPDW',INDD)
      IF( INDD .EQ. 0) THEN
         WRITE(6,*)' ***FTCORG >> FPDW BANK NOT FOUND'
         CALL H1STOP
      ENDIF

*     Check if old FPG1 bank exists. If so drop it.
      INDDUM =  IW(IQFPG1)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FPG1')
      ENDIF

      DO 4 JJ = 0, NCHANP-1
*       Get dead wire flag...
        IAR(1)     =  IBTAB(INDD,ILDEAD,JJ+1)
        KWCL   = IPWCL(JJ)
        IF(KWCL .GE. 16) KWCL = KWCL - 6
*       Phi of the Wires defined st Phi wire = Phi of +w-axis - pi/2
        PHIW      =  PPSTRT(IPSMD(JJ))  + RBTAB(INDC,ILPPHI,JJ+1)
        BAR(2)    =  PHIW
*
*       Geometric stagger of wire...
        PSTG      =  PSTAGG(IPSMD(JJ))  * ( (-1)**IPZPL(JJ) )

*       Effective Stagger of wire...
        PSTEF     =  RBTAB(INDCP1,ILSTEP,1)

*       Attach sign of geometric stagger, convert from microns to cm...
        PSTE      =  PSTEF / 10000.
        IF(PSTG .LT. 0.0) PSTE = -PSTE

*       Monte Carlo has no effective stagger...
        IF(MONTE)PSTE = PSTG

*       W of wire (effective)
        BAR(3)    =  WZERP + KWCL*WSEPP + PSTE
     +                     + RBTAB(INDC,ILPSTA,JJ+1)

*       Z of wire in cell...
        BAR(4)    = PZSTRT(IPSMD(JJ)) + ZSEPP*IPZPL(JJ) + ZSEPP/2.

*       W of wire (geometric)
        BAR(5)    =  WZERP + KWCL*WSEPP + PSTG
     +                     + RBTAB(INDC,ILPSTA,JJ+1)

*GDP
*      WRITE(6,'('' ** FTCORG.P *'',6I4,6(1X,F8.3))') JJ,IPSMD(JJ),
*    & IPZPL(JJ),IPWCL(JJ),KWCL,IAR(1),(BAR(II),II=2,4)
*GDP
        IFPG1       = IADROW('FPG1',NBN,ILENP,BAR)

 4    CONTINUE
      IFPG1  = IADFIN('FPG1',NBN)


      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.26.18  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZU:  7.00/04 04/05/95  18.33.33  by  Stephen Burke
*CMZ :  3.03/01 01/05/92  11.52.42  by  Gregorio Bernardi
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*   Get certain geometrical data for IOS arrays
*
*HTMLI     : Describe the Input variables to the routine
*
*   Nominal geometry:- <A HREF="FGAR.DDL.html">FGAR</A> and
*                      <A HREF="FGAP.DDL.html">FGAP</A>
*
*HTMLO     : Describe the Output of the routine
*
*   Fill COMMONs FGMIOS and FPLGEO.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTDGEO
*#**********************************************************************
*#                                                                     *
*#    VERSION: 12/04/90   Steve Maxfield                               *
*#                                                                     *
*#                                                                     *
*# PURPOSE: Get certain geometrical data for IOS arrays                *
*#                                                                     *
*#                                                                     *
*#**********************************************************************
*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,FGMIOS.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
*
*
*
      PARAMETER(TWOPI=6.283185)
      LOGICAL FIRST
      DATA FIRST/.TRUE./

*----------------------------------------------------------------------
*     Set up some nominal Geometry a la IOS.
      IF(FIRST) THEN
*     --------------
        FIRST = .FALSE.
        CALL UGTBNK('FGAR',INFGAR)
        IF( INFGAR .EQ. 0) THEN
           WRITE(6,*)' ***FTDGEO >> FGAR BANK NOT FOUND'
           CALL H1STOP
        ENDIF
        CALL UGTBNK('FGAP',INDP)
        IF( INDP .EQ. 0) THEN
           WRITE(6,*)' ***FTDGEO >> FGAP BANK NOT FOUND'
           CALL H1STOP
        ENDIF

*       Get basic radial parameters...
*       Everything is labelled by wire-plane number (1-36)
        NMOD  = IW(INFGAR+3)
        NPLANE= IW(INFGAR+5)
*
        DPHI  = TWOPI / FLOAT(IW(INFGAR+4))
        STAG  = RW(INFGAR+6)
        ZSEP  = RW(INFGAR+7)
        KIND  = INFGAR + 5
*
        DO 1 KMOD = 0, NMOD-1
          KIND   = KIND + 4
          PHIWIR = RW(KIND+4) + DPHI/2.
          DO 4   KK= 1, NPLANE
            K = KMOD*12 + KK
            ZP(K)  =  RW(KIND+3) - ZSEP/2.0 + KK*ZSEP
            PHW(K) =  PHIWIR
            WS(K)  =  -STAG * ( (-1)**KK)
 4        CONTINUE
 1      CONTINUE
*
*       Get basic planar parameters...
        NMODP = IW(INDP+3)
        NPLANP= IW(INDP+5)
*
        ZSEPP = RW(INDP+6)
        KIND  = INDP + IW(INDP+1) + 1
        DO 2 KMOD = 0, NMODP-1
         DO 202  KK= 1, NPLANP
            K = KMOD*4 + KK
            ZPP(K)  =  RW(KIND+3) - ZSEPP/2.0 + KK*ZSEPP
*    Cosine and Sine of WIRES:-
            C(K) =  COS( RW(KIND+4) - TWOPI/4.)
            S(K) =  SIN( RW(KIND+4) - TWOPI/4.)
*           For RWCH Planar code
            TP(KMOD+1)  =  RW(KIND+4) - TWOPI/4.
            CTP(KMOD+1) =  C(K)
            STP(KMOD+1) =  S(K)
            ZPLAN(K)    =  ZPP(K)*10.0
 202     CONTINUE
          KIND   = KIND + IW(KIND+1) + 1
 2      CONTINUE


      ENDIF
*     -----
      RETURN
      END
*CMZ :  8.07/00 21/11/96  19.23.24  by  Stephen Burke
*CMZU:  8.06/00 11/10/96  13.26.34  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZU:  5.03/00 03/11/94  18.09.22  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.24  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   17/02/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Outputs the results of the Planar pattern recognition
*
*HTMLI     : Describe the Input variables to the routine
*
*  Planar COMMON blocks
*
*HTMLO     : Describe the Output of the routine
*
*  Planar segment <A HREF="FPSG.DDL.html">FPSG</A> bank.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPSOUT
**: FPSOUT 30907 RP. Farm changes.
**----------------------------------------------------------------------
**: FPSOUT 30907 SM. Fix histogram handling.
*------------------------------------------------------------------*
*  OUTPUT RESULTS OF PLANAR PATTERN RECOGNITION                    *
*                                                                  *
*------------------------------------------------------------------*
*                                                                  *
*  OUTPUT:     FPSG,0     Planar segments                          *
*  =====                                                           *
*------------------------------------------------------------------*
*      FORMAT OF BANKS FROM FORWARD TRACK RECONSTRUCTION           *
*                                                                  *
*      FPSG    TABLE  FMT =        (7F,15I)                        *
*      ====                                                        *
*                                                                  *
*  1  X         F        x    )                                    *
*  2  Y         F        y    )  at beginning of sm                *
*  3  Z         F        z    )                                    *
*  4  X         F        x    )                                    *
*  5  Y         F        y    )  at end       of sm                *
*  6  Z         F        z    )                                    *
*                                                                  *
*  7  PRCHI     F        Chisq prob of segment                     *
*  8  ISM       I        Supermodule number                        *
*  9  MASKSG    I        MASK                                      *
*  10 INEXT     I        Pointer to next segment on track          *
*  11 IDIG      I             ) Row numbers in FPRE bank(0if none) *
*  ...                        ) SIGNED!                            *
*  22                         )                                    *
*                                                                  *
********************************************************************

*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPSTSG.
      COMMON/FPSTSG/ NSTC(9),NFSSEG(3),NFTSEG(3)
C---
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.
      COMMON/FWBIND/IWFRUX,IWFPUX,IWFPUR

*  Bank formatting data...
      PARAMETER(NCFPSG=22)
      PARAMETER(NBNN=0)

*  Local arrays...

      DIMENSION BAR(NCFPSG),   IAR(NCFPSG)
      EQUIVALENCE(BAR(1), IAR(1))

      LOGICAL FIRST
      DATA FIRST/.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))
*KEND.
*------------------------BEGIN ROUTINE-------------------------------
      IF(FIRST) THEN
        FIRST = .FALSE.
*       Format output banks...
        CALL BKFMT('FPSG','2I,(7F,15I)')
      ENDIF

* Make bank
      NFPSG = NFSEG(1) + NFSEG(2) + NFSEG(3)
      IFPSG = NBANK('FPSG',NBNN,2+NCFPSG*NFPSG)
      IW(IFPSG+1) = NCFPSG
      IW(IFPSG+2) = NFPSG

*  Loop over supermodules...
      NUMSEG=0
      DO 1 ISM = 1,3
       ISMOD = ISM -1
       DO 2 IP = 1,NFSEG(ISM)
        NUMSEG = NUMSEG + 1
*       z at beginning and end of this segment
        ZBG = ZSEG(1, IP, ISM)/ 10.
        ZND = ZSEG(2, IP, ISM)/ 10.
*       extrapolate x,y to ZMM. Converting from mm to cm!
        BAR(1)  = (XYDXY(1,IP,ISM)/10.)  +  ZBG * XYDXY(3,IP,ISM)
        BAR(2)  = (XYDXY(2,IP,ISM)/10.)  +  ZBG * XYDXY(4,IP,ISM)
        BAR(3)  =  ZBG
        BAR(4)  = (XYDXY(1,IP,ISM)/10.)  +  ZND * XYDXY(3,IP,ISM)
        BAR(5)  = (XYDXY(2,IP,ISM)/10.)  +  ZND * XYDXY(4,IP,ISM)
        BAR(6)  =  ZND

        BAR(7)  =  PRCHI(IP,ISM)

        IAR(8)  =  ISMOD

        IF (IP.GT.(NFSEG(ISM)-NFTSEG(ISM))) THEN
           IAR(9)  =  MASKSG(IP,ISM) + SIGN(2,MASKSG(IP,ISM))
        ELSEIF (IP.GT.(NFSEG(ISM)-NFSSEG(ISM)-NFTSEG(ISM))) THEN
           IAR(9)  =  MASKSG(IP,ISM) + SIGN(1,MASKSG(IP,ISM))
        ELSE
           IAR(9)  =  MASKSG(IP,ISM)
        ENDIF
C---               NFSSEG(3) --- Number of secondary Segments formed.
C---               NFTSEG(3) --- Number of Tertiary segments formed.
        IAR(10) =  0

*       Write(6,'(5F10.3, 2I10)') (BAR(JJ), JJ=1,5), IAR(6), IAR(7)

        IHITS = 0
        DO 3 IWIR = 1, 12
*        Get FRPE row numbers of hits in this segment...
         KWIR = IWIR + ISMOD*12
         IOSP = IDGISG(IWIR,IP,ISM)
         ISP  = ISIGN(1,IOSP)
         JP   = IABS(IOSP)
         IF(JP.NE.0) THEN
          IAR(10+IWIR) = ISP*IPFRPE(JP,KWIR)
          IHITS = IHITS + 1
         ELSE
          IAR(10+IWIR) = 0
         ENDIF
*       Write(6,'(3I10)') IOSP, ISP, IAR(10+IWIR)
 3      CONTINUE
        IF (MOD(NEVENT,10).EQ.0) THEN
           CALL SHS(320,     0, FLOAT(IHITS))
           CALL SHS(320+ISM, 0, FLOAT(IHITS))
        ENDIF

         CALL UCOPY(BAR,IW(INDCR(IFPSG,1,NUMSEG)),NCFPSG)
C        IFPSG  = IADROW('FPSG',NBNN,NCFPSG,BAR)
 2     CONTINUE
 1    CONTINUE


*   Close banks...
C      IF(NUMSEG.GT. 0) THEN
C        IFPSG  = IADFIN('FPSG',NBNN)
C      ELSE
*       make empty banks
C        IFPSG = NBANK('FPSG',NBNN,2)
C        IW(IFPSG+1) = NCFPSG
C        IW(IFPSG+2) = 0
C      ENDIF

      CALL BLIST(IW,'R+','FPSG')

      IF(IDOHIS.GE.2)CALL FPSGST

      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.26.49  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZU:  3.09/01 06/04/93  15.03.55  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   17/02/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Make diagnostic histograms of planar segments. (MC only)
*
*HTMLI     : Describe the Input variables to the routine
*
*  Planar segment <A HREF="FPSG.DDL.html">FPSG</A> and
*  Planar hit     <A HREF="FPLC.DDL.html">FPLC</A> banks
*
*HTMLO     : Describe the Output of the routine
*
*  Various histograms filled
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPSGST

**: FPSGST.......SM. More diagnostic histograms.
**----------------------------------------------------------------------
**: FPSGST 30207 GB. comment lines moved inside the routine
**: FPSGST 30205 SM. Add extra diagnostics for segments.
**----------------------------------------------------------------------
*
*     Make diagnostic histograms of planar segments.
*     (Monte Carlo only!!)
*
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
*
      DIMENSION KDIG(12), KSTR(12), KSGN(12), KBAD(12), IDX(12)
*
      PARAMETER (MAXSTR=2000)
      DIMENSION IPLHIT(MAXSTR,3)
      DIMENSION IPPHIT(MAXSTR,3)
      DIMENSION KSEG(3)
      DIMENSION NSGSTR(3)
      DIMENSION NSGFND(3,2)
      DIMENSION NSTRPR(3)
      DIMENSION NFNDPR(3,2)
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.



* Planar segment bank...
      IFPSG = NLINK('FPSG',0)
      IF(IFPSG .EQ. 0)RETURN
* Planar hit bank...
      IFPLC = NLINK('FPLC',0)
      IF(IFPLC .EQ. 0)RETURN

      NSEG = IW(IFPSG+2)
      NPHT = IW(IFPLC+2)


*     Count number of (disconnected) segments found in each SM
*     and total number of hits attached to segments...
      CALL VZERO(KSEG, 3)
      KUSED = 0
      KSUM  = 0
      DO 300 JSEG = 1, NSEG
       IMSK = IBTAB(IFPSG,9,JSEG)
       IF(IMSK.NE.0) GO TO 300
       IMOD = IBTAB(IFPSG,8,JSEG)+ 1
       KSEG(IMOD) = KSEG(IMOD) + 1
       DO 301 KDP = 1, 12
          KDG  = IABS(IBTAB(IFPSG,10+KDP,JSEG))
          IF(KDG.NE.0) THEN
            KUSED = KUSED + 1
            CHARGE= RBTAB(IFPLC,5,KDG)
*           separate inner and outer wires...
            KTEST = MOD(KDP,4)
            IF(KTEST.LT.2) THEN
*            outer...
             CALL SHS(253,0,CHARGE)
             CALL SHD(254,0,CHARGE,FLOAT(KDP))
            ELSE
             CALL SHS(255,0,CHARGE)
             CALL SHD(256,0,CHARGE,FLOAT(KDP))
            ENDIF
          ENDIF
 301   CONTINUE
 300  CONTINUE

      CALL SHS(221,0,FLOAT(KSEG(1)))
      CALL SHS(222,0,FLOAT(KSEG(2)))
      CALL SHS(223,0,FLOAT(KSEG(3)))
      KSUM = KSEG(1) + KSEG(2) + KSEG(3)
      CALL SHS(261,0,FLOAT(KSUM))
      IF(NPHT .GT. 30) THEN
        FRUSED = FLOAT(KUSED) / FLOAT(NPHT)
        CALL SHS(262,0,FRUSED)
      ENDIF

      RETURN
      END
*CMZ :  8.07/00 21/11/96  19.16.05  by  Stephen Burke
*CMZU:  8.06/00 11/10/96  13.27.01  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.08  by  Stephen Burke
*CMZU:  7.02/11 24/10/95  14.16.37  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.25  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   30/03/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Outputs the results of the Radial pattern recognition
*
*HTMLI     : Describe the Input variables to the routine
*
*  Radial COMMON blocks
*
*HTMLO     : Describe the Output of the routine
*
*  Radial segment <A HREF="FRSG.DDL.html">FRSG</A> bank.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRSOUT
**: FRSOUT 30907 RP. Farm changes.
**----------------------------------------------------------------------
**: FRSOUT 30907 SM. Fix histogram handling.
**: FRSOUT 30907 SM. New routine for monitoring.
**----------------------------------------------------------------------
*------------------------------------------------------------------*
*  OUTPUT RESULTS OF RADIAL PATTERN RECOGNITION                    *
*                                                                  *
*------------------------------------------------------------------*
*                                                                  *
*  OUTPUT:     FRSG,0     radial segments                          *
*  =====                                                           *
*------------------------------------------------------------------*
*      FORMAT OF BANKS FROM FORWARD TRACK RECONSTRUCTION           *
*                                                                  *
*      FRSG    TABLE  FMT =        (7F,15I)                        *
*      ====                                                        *
*                                                                  *
*  1  X         F        x    )                                    *
*  2  Y         F        y    )  at beginning of sm                *
*  3  Z         F        z    )                                    *
*  4  X         F        x    )                                    *
*  5  Y         F        y    )  at end       of sm                *
*  6  Z         F        z    )                                    *
*                                                                  *
*  7  CHSQ      F        Chisq of segment                          *
*  8  ISM       I        Supermodule number                        *
*  9   -        I        Not used                                  *
*  10 INEXT     I        Pointer to next segment on track          *
*  11 IDIG      I             ) Row numbers in FRRE bank(0if none) *
*  ...                        ) SIGNED!                            *
*  22                         )                                    *
*                                                                  *
********************************************************************

*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.
      COMMON/FWBIND/IWFRUX,IWFPUX,IWFPUR

*  Bank formatting data...
      PARAMETER(NCFRSG=22)
      PARAMETER(NBNN=0)

*  Local arrays...

      DIMENSION BAR(NCFRSG),   IAR(NCFRSG)
      EQUIVALENCE(BAR(1), IAR(1))

      LOGICAL FIRST
      DATA FIRST/.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))
*KEND.
*------------------------BEGIN ROUTINE-------------------------------
      IF(FIRST) THEN
        FIRST = .FALSE.
*       Format output banks...
        CALL BKFMT('FRSG','2I,(7F,15I)')
      ENDIF

*  Loop over supermodules...
      NUMSEG=0
      DO 1 ISM = 1,3
       ISMOD = ISM -1

*  Loop over segments...
       DO 2 IP = 1,NTRAKS(ISM)
        IF (CHSQ(IP,ISM).GT.1000.) GOTO 2
        NUMSEG = NUMSEG + 1

*       Get FRRE row numbers of hits in this segment...
*       First and last wire planes...
        IFPNT = 0
        ILPNT = 0
        IHITS = 0
        DO 3 IWIR = 1, 12
         KWIR = IWIR + ISMOD*12
         IOSP = IRPT(IWIR,IP,ISM)
         ISP  = SDRFT(IWIR,IP,ISM)
         IF(IOSP.NE.0) THEN
          IHITS = IHITS + 1
          ILPNT  =  KWIR
          IF(IFPNT.EQ.0)IFPNT  =  KWIR
          IAR(10+IWIR) = ISP*IPFRRE(IOSP,KWIR)
         ELSE
          IAR(10+IWIR) = 0
         ENDIF
*       Write(6,'(3I10)') IOSP, ISP, IAR(10+IWIR)
 3      CONTINUE
        IF (MOD(NEVENT,10).EQ.0) THEN
           CALL SHS(200,     0, FLOAT(IHITS))
           CALL SHS(200+ISM, 0, FLOAT(IHITS))
        ENDIF

*       z at beginning and end of this segment...
        ZBG = ZP(IFPNT)
        ZND = ZP(ILPNT)
*       convert R-z Phi-z to x,y at beginning and end...
        PHIBEG  = PHZL(IP,ISM) + ZBG*PCOSL(IP,ISM)
        RBEG    = RZI (IP,ISM) + ZBG*PSINL(IP,ISM)
        PHIEND  = PHZL(IP,ISM) + ZND*PCOSL(IP,ISM)
        REND    = RZI (IP,ISM) + ZND*PSINL(IP,ISM)
        BAR(1)  = RBEG*COS(PHIBEG)
        BAR(2)  = RBEG*SIN(PHIBEG)
        BAR(3)  = ZBG
        BAR(4)  = REND*COS(PHIEND)
        BAR(5)  = REND*SIN(PHIEND)
        BAR(6)  = ZND

        BAR(7)  = CHSQ(IP,ISM)

        IAR(8)  =  ISMOD
        IAR(9)  =  0
        IAR(10) =  0

*       Write(6,'(5F10.3, 2I10)') (BAR(JJ), JJ=1,5), IAR(6), IAR(7)

        IFRSG  = IADROW('FRSG',NBNN,NCFRSG,BAR)
 2     CONTINUE
 1    CONTINUE


*   Close banks...
      IF(NUMSEG.GT. 0) THEN
        IFRSG  = IADFIN('FRSG',NBNN)
      ELSE
*       make empty banks
        IFRSG = NBANK('FRSG',NBNN,2)
        IW(IFRSG+1) = NCFRSG
        IW(IFRSG+2) = 0
      ENDIF

      CALL BLIST(IW,'R+','FRSG')

      IF(IDOHIS .GE. 2)CALL FRSGST
      IF(IDOHIS .GE. 2)CALL FRPCHK

      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.27.13  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.25  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   30/03/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Make diagnostic histograms of radial segments.
*
*HTMLI     : Describe the Input variables to the routine
*
*  Radial segment  <A HREF="FRSG.DDL.html">FRSG</A> ,
*  Radial hit      <A HREF="FRLC.DDL.html">FRLC</A> ,
*  Radial geometry <A HREF="FRG1.DDL.html">FRG1</A> banks
*
*HTMLO     : Describe the Output of the routine
*
*  Various histograms filled
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRSGST
**: FRSGST 30907 SM. Allow for 12-wire readout.
**----------------------------------------------------------------------
**: FRSGST 30907 SM. New routine for monitoring.
**----------------------------------------------------------------------
*
*     Make diagnostic histograms of radial segments.
*
*
*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,FSGPAR.
      COMMON/FSGPAR/DMINX, PHIT, TSCUT, SLCUT, RCUT, TSLPC,
     +              MINHTS, MINPTS, MAXCLU, LSCUT, NWIRES, IPLOT
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
*
*
      DIMENSION NSGFND(3)
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.



* Radial segment bank...
      IFRSG = NLINK('FRSG',0)
      IF(IFRSG .EQ. 0)RETURN
* Radial hit bank...
      IFRLC = NLINK('FRLC',0)
      IF(IFRLC .EQ. 0)RETURN
      NRLC = IW(IFRLC+2)
      IF(NRLC .EQ. 0) RETURN
* Radial geometry bank...
      IFRG1 = NLINK('FRG1',0)
      IF(IFRG1 .EQ. 0)RETURN


      CALL VZERO(NSGFND, 3)
      NSEG = IW(IFRSG+2)
      NTOTHT = 0
      DO 50 JSEG = 1, NSEG
       CHIS = RBTAB(IFRSG,7,JSEG)
       IMOD = IBTAB(IFRSG,8,JSEG)+ 1
       NSGFND(IMOD) = NSGFND(IMOD) + 1
       XIN  = RBTAB(IFRSG,1,JSEG)
       YIN  = RBTAB(IFRSG,2,JSEG)
       ZIN  = RBTAB(IFRSG,3,JSEG)
       XOUT = RBTAB(IFRSG,4,JSEG)
       YOUT = RBTAB(IFRSG,5,JSEG)
       ZOUT = RBTAB(IFRSG,6,JSEG)

       RIN    = SQRT(XIN**2  + YIN**2)
       ROUT   = SQRT(XOUT**2 + YOUT**2)
       PHIIN  = ATAN2(YIN,ZIN)
       PHIOUT = ATAN2(YOUT,XOUT)

       SLPPHI = (PHIOUT - PHIIN) / (ZOUT - ZIN)
       SLPR   = (ROUT   - RIN)   / (ZOUT - ZIN)

       NUMRHT = 0
       DO 60 KDP = 1,  NWIRES
          KDS       = IBTAB(IFRSG,10+KDP,JSEG)
          KD        = IABS(KDS)
          KSG       = ISIGN(1,KDS)

          IF(KD  .NE. 0) THEN
             NUMRHT = NUMRHT + 1
             NTOTHT = NTOTHT + 1
*            Cell number and flag...
             ICLNUM = IBTAB(IFRLC,1,KD)
             ISGNW  = IBTAB(IFRLC,6,KD)
*            Pointer to geometry for this hit (+ or - wedge)
             KPOINT = 1 + 3*MOD(ISGNW,2)
*            geometry...
             PHIWIR = RBTAB(IFRG1,KPOINT+1,ICLNUM+1)
             STGWIR = RBTAB(IFRG1,KPOINT+2,ICLNUM+1)
             ZEDWIR = RBTAB(IFRG1,KPOINT+3,ICLNUM+1)
*            Predict the drift from the segment parameters...
             PHIHIT = PHIIN + SLPPHI*(ZEDWIR-ZIN)
             RHIT   = RIN   + SLPR  *(ZEDWIR-ZIN)
*            expected drift not including wire stagger...
             DRFE   = RHIT*SIN(PHIHIT-PHIWIR)
*            measured drift, signed and corrected for stagger...
             DRIFT  = KSG*RBTAB(IFRLC,2,KD)+ STGWIR

             QPLUS  = RBTAB(IFRLC,7,KD)
             QMINUS = RBTAB(IFRLC,8,KD)
             QSUM   = QPLUS+QMINUS
             CALL SHS(251,  0,QSUM)
             CALL SHS(251,KDP,QSUM)
             CALL SHD(252,0,QSUM,FLOAT(KDP))
          ENDIF
 60    CONTINUE
       FNMRHT = FLOAT(NUMRHT)
 50   CONTINUE

      F1=FLOAT(NSGFND(1))
      F2=FLOAT(NSGFND(2))
      F3=FLOAT(NSGFND(3))
      FALL = F1 + F2 + F3
      CALL SHS(204, 0, F1  )
      CALL SHS(205, 0, F2  )
      CALL SHS(206, 0, F3  )
      CALL SHS(207, 0, FALL)
      IF(NRLC .GT. 12) THEN
       USED = FLOAT(NTOTHT) / FLOAT(NRLC)
       CALL SHS(260, 0, USED)
      ENDIF


      END
*CMZU:  8.06/00 11/10/96  13.27.31  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.04/01 02/06/92  17.12.30  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Compare the calculated z-vertex value with the truth. (MC only)
*
*HTMLI     : Describe the Input variables to the routine
*
*  <A HREF="SVX.DDL.html">SVX</A> bank for primary vertex
*
*HTMLO     : Describe the Output of the routine
*
*  Histograms filled.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVCHEK(FVVEC)
*-----------------------------------------Updates 02/06/92-------
**: FVCHEK.......SB. Change loop indices to please farm.
*-----------------------------------------Updates 06/05/92-------
**: FVCHEK.......SB. New deck to check FVFIT output.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Compare the calculated z-vertex value with the truth               *
*                                                                    *
**********************************************************************

      DIMENSION FVVEC(4)

*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.

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

      INSVX = NLINK('SVX ',0)
      IF (INSVX.LE.0) THEN
         CALL ERRLOG(531,'W:FVCHEK: No SVX bank')
         RETURN
      ENDIF

      JPRIM = 0
      ILOOP = IW(INSVX+2)
      DO 100 JVX=ILOOP,1,-1
         IF (IBTAB(INSVX,4,JVX).EQ.1) JPRIM = JVX
 100  CONTINUE

      IF (JPRIM.LE.0) THEN
         CALL ERRLOG(532,'W:FVCHEK: No primary vertex!')
         RETURN
      ENDIF

      ZERR   = RBTAB(INSVX,3,JPRIM) - FVVEC(1)
      ZPULL  = ZERR/FVVEC(2)
      CHPROB = PROB(ZPULL**2,1)

      CALL HFILL(101,ZERR,0.,1.)
      CALL HFILL(102,ZPULL,0.,1.)
      CALL HFILL(103,CHPROB,0.,1.)

      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.27.49  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  7.00/06 15/05/95  12.39.55  by  Stephen Burke
*CMZU:  5.03/00 31/10/94  14.26.17  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.25  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*   Calculate z-vertex by weighted mean
*
*HTMLI     : Describe the Input variables to the routine
*
*   INFTKR - <A HREF="FTKR.DDL.html">FTKR</A> bank index
*   NFTKR  - The number of FTKR rows (= size of work bank)
*   ZNOM   - the nominal z-vertex position
*   LFIRST - TRUE for the first call (primary vertex)
*
*HTMLO     : Describe the Output of the routine
*
*   FVVEC - the four words of the <A HREF="FTGR.DDL.html">FTGR</A> bank
*   IERR  - non-zero if the weighted mean fails
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVZWM(INFTKR,NFTKR,ZNOM,LFIRST,FVVEC,IERR)
*-----------------------------------------Updates 26/07/93-------
**: FVZWM  30907 RP. Farm changes.
*-----------------------------------------Updates 30/10/92-------
**: FVZWM  30907 SB. New debug histogram numbers.
*-----------------------------------------Updates 06/05/92-------
**: FVZWM  30907 SB. New deck to take a weighted mean of z values.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Calculate z-vertex by weighted mean                                *
*                                                                    *
* INPUT;                                                             *
*       INFTKR - FTKR bank index                                     *
*       NFTKR  - The number of FTKR rows (= size of work bank)       *
*       ZNOM   - the nominal z-vertex position                       *
*       LFIRST - TRUE for the first call (primary vertex)            *
*                                                                    *
* OUTPUT;                                                            *
*       FVVEC - the four words of the FTGR bank                      *
*       IERR  - non-zero if the weighted mean fails                  *
*                                                                    *
**********************************************************************

      DIMENSION FVVEC(4)
      LOGICAL LFIRST,LRJCT,LPRIM

*KEEP,FVSTEE.
      LOGICAL LTRUTH,LCUT,LRESID
      COMMON /FVSTEE/ IDIAG,LUN,LUNHB,LTRUTH,LCUT,LRESID
*KEEP,FVPAR.
      DOUBLE PRECISION ZWALL1,ZWALL2,RADLEN
      COMMON /FVPAR/ ZWALL1,ZWALL2,RADLEN,MINHTP,MINHTR,ZSQMAX
     &,              PMIN,DCAMAX,Z0MAX,CHIMAX
*KEEP,FVSCAL.
* Various counters
      PARAMETER (NSCAL=16)
      COMMON /FVSCAL/ NNEVNT,NNVTX,NNFTKR,NNXTR,NNFIT,NNOUT,NNSIN
     &,               NNFTKP,NNXTRP,NNFITP,NNOUTP,NNSINP
     &,               NNVTXC,NNSINC,NNFVNC,NNFSNC
*KEEP,FVWBI.
* Work bank indices
      PARAMETER (NFVWBI=2)
      COMMON /FVWBI/ INFTPR,INFVWK
*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.

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

* Default is failure
      IERR = 1

*
* Take a weighted mean of the z0 values
*

      SIGZW = 0.
      SIGW  = 0.
      NDF   = -1
      DO 200 JFT=1,NFTKR-1,2
         WZ0 = RW(INFVWK+JFT+1)
* Rejected tracks have weight zero
         IF (WZ0.LE.0.) GOTO 200
         Z0 = RW(INFVWK+JFT)
         IF (SIGW.GT.0.) THEN
            ZMEAN = SIGZW/SIGW
            CHI = (Z0 - ZMEAN)**2*WZ0
         ELSE
            CHI = 0.
         ENDIF
         IF (CHI.LE.10*CHIMAX) THEN
* Accept new value if reasonably consistent with current estimate
            SIGZW = SIGZW + Z0*WZ0
            SIGW  = SIGW  + WZ0
            NDF   = NDF + 1
* Mark value used by setting weight negative
            RW(INFVWK+JFT+1) = -WZ0
         ELSEIF (ABS(Z0-ZNOM).LT.ABS(ZMEAN-ZNOM)) THEN
* New value is closer to nominal z, so discard previous estimate
            SIGZW = Z0*WZ0
            SIGW  = WZ0
            NDF   = 0
* Mark used by setting weight negative
            RW(INFVWK+JFT+1) = -WZ0
* Reset used flag for previous tracks
            DO 100 JJFT=1,JFT-2,2
               WZ0 = RW(INFVWK+JJFT+1)
               IF (WZ0.LT.0.) RW(INFVWK+JJFT+1) = -WZ0
 100        CONTINUE
         ENDIF
 200  CONTINUE

* First guess at z0 and error
      IF (SIGW.LE.0.) RETURN
      CZMEAN = 1./SIGW
      ZMEAN  = SIGZW*CZMEAN

 300  CONTINUE

*
* Now work out a chi-squared, and throw away any tracks
* which are too far from the mean
*

      CHISQ = 0.
      NOUTP = 0
      LRJCT = .FALSE.
      DO 400 JFT=1,NFTKR-1,2
         WZ0 = RW(INFVWK+JFT+1)
* Used tracks now have negative weight
         IF (WZ0.GE.0.) GOTO 400
         WZ0 = -WZ0
         Z0  = RW(INFVWK+JFT)
* Primary flag for diagnostics
         LPRIM = IBTAB(INFTKR,7,JFT).EQ.0
         IF (LPRIM) NOUTP = NOUTP + 1
         IF (NDF.EQ.0) THEN
* If there's only one track, accept it
            IF (LFIRST) THEN
               NNSIN = NNSIN + 1
               IF (LPRIM) NNSINP = NNSINP + 1
            ENDIF
            CHISQ = 0.
         ELSE
            CHI = (Z0 - ZMEAN)**2*WZ0
            IF (CHI.LE.CHIMAX) THEN
* Accept if close enough to the mean
               CHISQ = CHISQ + CHI
            ELSE
* Remove this track (but don't yet update ZMEAN)
               SIGZW = SIGZW - Z0*WZ0
               SIGW  = SIGW  - WZ0
               NDF   = NDF - 1
* Reset used flag
               RW(INFVWK+JFT+1) = WZ0
               LRJCT = .TRUE.
            ENDIF
            IF (LCUT .AND. LPRIM) THEN
               CALL HFILL(213,CHI,0.,1.)
            ELSEIF (LCUT) THEN
               CALL HFILL(214,CHI,0.,1.)
            ENDIF
         ENDIF
 400  CONTINUE

* Iterate if necessary
      IF (LRJCT) THEN
         IF (SIGW.LE.0.) RETURN
         CZMEAN = 1./SIGW
         ZMEAN  = SIGZW*CZMEAN
         IF (NDF.GT.0) GOTO 300
      ENDIF

      IF (LFIRST) THEN
         NNOUTP = NNOUTP + NOUTP
* Create FTGX bank
         INFTGX = NBANK('FTGX',0,2+NFTKR/2)
         IF (INFTGX.LE.0) THEN
            CALL ERRLOG(512,'S:FVZWM:  Unable to create FTGX')
            RETURN
         ENDIF
         IW(INFTGX+1) = 1
         IW(INFTGX+2) = 0
      ENDIF

* Remove all tracks used for this vertex
      DO 500 JFT=1,NFTKR-1,2
         WZ0 = RW(INFVWK+JFT+1)
         IF (WZ0.LT.0.) THEN
            RW(INFVWK+JFT+1) = 0.
            IW(INFTGX+2) = IW(INFTGX+2) + 1
            IW(INDCR(INFTGX,1,IW(INFTGX+2))) = JFT
         ENDIF
 500  CONTINUE

* Fill the output vector
      FVVEC(1) = ZMEAN
      FVVEC(2) = SQRT(CZMEAN)
      FVVEC(3) = CHISQ
      CALL UCOPY(NDF,FVVEC(4),1)

      IERR = 0

      IF (LCUT) THEN
         PRAT = FLOAT(NOUTP)/FLOAT(NDF+1)
         IF (PRAT.GT.0.999) PRAT = 0.999
         CALL HFILL(300,PRAT,0.,1.)
      ENDIF

      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.28.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  4.00/01 21/09/93  16.21.30  by  Stephen Burke
*CMZU:  3.06/06 01/12/92  14.13.02  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Read parameters from steering banks
*
*HTMLI     : Describe the Input variables to the routine
*
*  Steering banks :- <A HREF="FVRS.DDL.html">FVRS</A> and
*                    <A HREF="FVRP.DDL.html">FVRP</A>
*
*HTMLO     : Describe the Output of the routine
*
*  Fills steering COMMONs FVSTEE,FVPAR
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVTEXT
*-----------------------------------------Updates 21/09/93-------
**: FVTEXT.......SB. Turn off momentum cuts for zero field.
*-----------------------------------------Updates 30/10/92-------
**: FVTEXT.......SB. Separate cuts on # of planar/radial hits.
**: FVTEXT.......SB. FVRP steering bank format changed.
*-----------------------------------------Updates 06/05/92-------
**: FVTEXT.......SB. New steering banks FVRS and FVRP from db:
*!: FVRP  .......SB. New steering bank for forward z-vertex fit.
*!: FVRS  .......SB. New steering bank for forward z-vertex fit.
**: FVTEXT.......SB. New deck to read z-vertex fit steering banks.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Read parameters from steering banks                                *
*                                                                    *
**********************************************************************

      DIMENSION R(3),B(3)

*KEEP,FVSTEE.
      LOGICAL LTRUTH,LCUT,LRESID
      COMMON /FVSTEE/ IDIAG,LUN,LUNHB,LTRUTH,LCUT,LRESID
*KEEP,FVPAR.
      DOUBLE PRECISION ZWALL1,ZWALL2,RADLEN
      COMMON /FVPAR/ ZWALL1,ZWALL2,RADLEN,MINHTP,MINHTR,ZSQMAX
     &,              PMIN,DCAMAX,Z0MAX,CHIMAX
*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.

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

* Get the steering bank
      CALL UGTBNK('FVRS',INDS)
      IF (INDS.GT.0) THEN
         IVERS = IW(INDS+1)
         IF (IVERS.NE.6592) THEN
            INDS = 0
            CALL ERRLOG(551,'F:FVTEXT: Wrong version of bank FVRS;'//
     &                     ' defaults used')
         ENDIF
      ELSE
         CALL ERRLOG(552,'W:FVTEXT: Bank FVRS not found;'//
     &                  ' defaults used')
      ENDIF
      IF (INDS.LE.0) THEN
         LUN   = 6
         IDIAG = 0
         LUNHB = 0
      ELSE
         LUN   = IW(INDS+2)
         IDIAG = IW(INDS+3)
         LUNHB = IW(INDS+4)
      ENDIF

* Decode the histogram steering
      LTRUTH = MOD(IDIAG,10).NE.0
      IF (MOD(IDIAG/100,10).GT.0 .AND. LTRUTH) THEN
         LRESID = .TRUE.
      ELSE
         LRESID = .FALSE.
      ENDIF
      IF (MOD(IDIAG/10,10).GT.0) THEN
         LCUT = .TRUE.
      ELSE
         LCUT = .FALSE.
      ENDIF

* Get the parameter bank
      CALL UGTBNK('FVRP',INDP)
      IF (INDP.GT.0) THEN
         IVERS = IW(INDP+1)
         IF (IVERS.NE.301092) THEN
            INDP = 0
            CALL ERRLOG(553,'F:FVTEXT: Wrong version of bank FVRP;'//
     &                     ' defaults used')
         ENDIF
      ELSE
         CALL ERRLOG(554,'W:FVTEXT: Bank FVRP not found;'//
     &                  ' defaults used')
      ENDIF
      IF (INDP.LE.0) THEN
         ZWALL1 = 108.0
         ZWALL2 = 123.6
         RADLEN = 43.9
         MINHTP = 9
         MINHTR = 6
         ZSQMAX = 100.*100.
         PMIN   = 1.0
         DCAMAX = 10.
         Z0MAX  = 50.
         CHIMAX = 10.
      ELSE
         ZWALL1 = RW(INDP+2)
         ZWALL2 = RW(INDP+3)
         RADLEN = RW(INDP+4)
         MINHTP = IW(INDP+5)
         MINHTR = IW(INDP+6)
         ZSQMAX = RW(INDP+7)
         PMIN   = RW(INDP+8)
         DCAMAX = RW(INDP+9)
         Z0MAX  = RW(INDP+10)
         CHIMAX = RW(INDP+11)
      ENDIF

* Don't cut on momentum if field is too small
      CALL VZERO(R,3)
      CALL GUFLD(R,B)
      IF (ABS(B(3)).LT.1.0) PMIN = -1.0

* Check print flag
      IF (IW(6).LE.0) RETURN

      WRITE(LUN,*)
      WRITE(LUN,*)
      WRITE(LUN,*) '            *** FVFIT steering parameters ***'
      WRITE(LUN,*)
      WRITE(LUN,*)

      WRITE(LUN,1001) MINHTP
      WRITE(LUN,1002) MINHTR
      WRITE(LUN,1003) ZSQMAX
      WRITE(LUN,1004) PMIN
      WRITE(LUN,1005) DCAMAX
      WRITE(LUN,1006) Z0MAX
      WRITE(LUN,1007) CHIMAX

 1001 FORMAT(' Minimum number of planar hits:',I4)
 1002 FORMAT(' Minimum number of radial hits:',I4)
 1003 FORMAT(' Maximum initial z0 squared: ',F8.1)
 1004 FORMAT(' Minimum momentum:               ',F5.2)
 1005 FORMAT(' Maximum dca:                  ',F6.1)
 1006 FORMAT(' Maximum z0:                   ',F6.1)
 1007 FORMAT(' Maximum chi-squared:          ',F6.1//)

      RETURN
      END
*CMZU:  8.06/00 11/10/96  13.28.18  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.06/06 01/12/92  14.13.02  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Book diagnostic histograms for z-vertex
*
*HTMLI     : Describe the Input variables to the routine
*
*  CDIR - PAW subdirectory name into which histograms placed
*
*HTMLO     : Describe the Output of the routine
*
*  No output parameters
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVHBK(CDIR)
*-----------------------------------------Updates 30/10/92-------
**: FVHBK .......SB. New debug histograms/numbers.
*-----------------------------------------Updates 06/05/92-------
**: FVHBK .......SB. New deck to book z-vertex diagnostic histograms.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Book diagnostic histograms                                         *
*                                                                    *
**********************************************************************

      CHARACTER*(*) CDIR

*KEEP,FVSTEE.
      LOGICAL LTRUTH,LCUT,LRESID
      COMMON /FVSTEE/ IDIAG,LUN,LUNHB,LTRUTH,LCUT,LRESID
*KEND.

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

      CALL HCDIR('//PAWC',' ')
      CALL HMDIR(CDIR,'S')

      IF (LRESID) THEN
         CALL HBOOK1(100,'CT Z-RESOLUTION$',100,-10.,10.,0.)
         CALL HBOOK1(101,'Z RESOLUTION$',100,-10.,10.,0.)
         CALL HBOOK1(102,'PULL ON Z$',100,-5.,5.,0.)
         CALL HBOOK1(103,'TRUE P(CHISQ)$',100,0.,1.,0.)
      ENDIF

      IF (LCUT) THEN
         CALL HBOOK1(201,'NHITP (PRIMARY)$',73,0.,73.,0.)
         CALL HBOOK1(202,'NHITP (SECONDARY)$',73,0.,73.,0.)
         CALL HBOOK1(203,'NHITR (PRIMARY)$',73,0.,73.,0.)
         CALL HBOOK1(204,'NHITR (SECONDARY)$',73,0.,73.,0.)
         CALL HBOOK1(205,'ZSQ (PRIMARY)$',100,0.,10000.,0.)
         CALL HBOOK1(206,'ZSQ (SECONDARY)$',100,0.,10000.,0.)
         CALL HBOOK1(207,'P (PRIMARY)$',100,0.,10.,0.)
         CALL HBOOK1(208,'P (SECONDARY)$',100,0.,10.,0.)
         CALL HBOOK1(209,'DCA (PRIMARY)$',100,0.,20.,0.)
         CALL HBOOK1(210,'DCA (SECONDARY)$',100,0.,20.,0.)
         CALL HBOOK1(211,'Z0 (PRIMARY)$',100,-50.,50.,0.)
         CALL HBOOK1(212,'Z0 (SECONDARY)$',100,-50.,50.,0.)
         CALL HBOOK1(213,'CHI (PRIMARY)$',100,0.,20.,0.)
         CALL HBOOK1(214,'CHI (SECONDARY)$',100,0.,20.,0.)
         CALL HBOOK1(300,'FRACTION OF TRACKS PRIMARY$',100,0.,1.,0.)
      ENDIF

      CALL HBPRO(0,0.)
      CALL HMINIM(0,0.)
      CALL HIDOPT(0,'INTE')

      CALL HCDIR('//PAWC',' ')

      RETURN
      END
*CMZU:  8.06/00 04/11/96  14.20.28  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  18.00.35  by  Stephen Burke
*CMZU:  3.04/01 02/06/92  17.12.30  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*  For MC, attempts to associate a reconstructed track to
*  a 'true' track and to put a primary/secondary flag into FTKR bank.
*
*HTMLI     : Describe the Input variables to the routine
*
*  INFTKR  : Row number of reconsructed track in the FTKR bank.
*
*HTMLO     : Describe the Output of the routine
*
*  Primary/secondary flag inserted in Word 7 of FTKR row.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVTRUE(INFTKR)
*-----------------------------------------Updates 02/06/92-------
**: FVTRUE.......SB. Change loop indices to please farm.
*-----------------------------------------Updates 06/05/92-------
**: FVTRUE.......SB. New deck to mark tracks as primary/secondary.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Find true track numbers and write primary/secondary flag into      *
* word 7 of FTKR row.                                                *
*                                                                    *
**********************************************************************

      LOGICAL FVXPRM
      CHARACTER*4 BANK

*KEEP,FVWBI.
* Work bank indices
      PARAMETER (NFVWBI=2)
      COMMON /FVWBI/ INFTPR,INFVWK
*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.

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

      INSTR = NLINK('STR ',0)
      INSVX = NLINK('SVX ',0)
      IF (INSTR.LE.0 .OR. INSVX.LE.0) RETURN

      BANK = 'FTPR'
      IF (NLINK(BANK,0).LE.0) GOTO 1000
      CALL BKTOW(IW,BANK,0,IW,INFTPR,*1000)

*
* Loop over forward tracks
*

      ILOOP = IW(INFTKR+2) - 1
      DO 100 JFT=1,ILOOP,2
* Find true track
         JPR   = IBTAB(INFTKR,21,JFT)
         JDIGP = IBTAB(INFTPR,4,JPR)
         JDIGR = IBTAB(INFTPR,2,JPR)
         CALL UTSTR(JDIGP,JDIGR,0,0,0,JMAX,NHIT,NPOSS)
         IF (JMAX.LE.0) THEN
            CALL ERRLOG(561,'S:FVTRUE: Funny FT digi list')
         ELSE
* Overwrite IPTYPE (must be 2)
            IF (FVXPRM(INSVX,INSTR,JMAX)) THEN
               IW(INDCR(INFTKR,7,JFT)) = 0
            ELSE
               IW(INDCR(INFTKR,7,JFT)) = 1
            ENDIF
         ENDIF
 100  CONTINUE

 9000 CONTINUE

* Must make sure work banks are dropped!!!
      CALL WDROP(IW,INFTPR)

      RETURN

 1000 CALL ERRLOG(562,'S:FVTRUE: Bank '//BANK//' not found')
      GOTO 9000

      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.05/07 20/08/92  11.33.37  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   18/06/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRPCHK
      PARAMETER(TWOPI=6.2831853)
      PARAMETER(PWED=0.13089969)
      DIMENSION ITS(3)
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
* Radial segment bank...
      IFRSG = NLINK('FRSG',0)
      IF(IFRSG .EQ. 0)RETURN
* Planar segment bank...
      IFPSG = NLINK('FPSG',0)
      IF(IFPSG .EQ. 0)RETURN
* Radial hit bank...
      IFRLC = NLINK('FRLC',0)
      IF(IFRLC .EQ. 0)RETURN
      NRLC = IW(IFRLC+2)
      IF(NRLC .EQ. 0) RETURN
*     Locate FRG1 bank...
      IFRG1 = NLINK('FRG1',0)
      IF(IFRG1 .EQ. 0)RETURN

      NRSEG = IW(IFRSG+2)
      NPSEG = IW(IFPSG+2)


*     Loop over the planar segments...
      DO 3  JSEG = 1, NPSEG
       IMODP= IBTAB(IFPSG,8,JSEG)
       IMSK = IBTAB(IFPSG,9,JSEG)
       IF(IMSK.EQ.0) THEN

         XPSGI = RBTAB(IFPSG, 1,JSEG)
         YPSGI = RBTAB(IFPSG, 2,JSEG)
         ZPSGI = RBTAB(IFPSG, 3,JSEG)

         XPSGO = RBTAB(IFPSG, 4,JSEG)
         YPSGO = RBTAB(IFPSG, 5,JSEG)
         ZPSGO = RBTAB(IFPSG, 6,JSEG)

         DZG   = (ZPSGO - ZPSGI)
         XSLPG = (XPSGO - XPSGI) / DZG
         YSLPG = (YPSGO - YPSGI) / DZG
*        look for nearest radial segment...search in 'nearby' radials
*        only.
         IF(IMODP.EQ.0) THEN
          ITS(1)=-1
          ITS(2)= 0
          ITS(3)= 1
         ELSEIF(IMODP.EQ.1) THEN
          ITS(1)=0
          ITS(2)=1
          ITS(3)=2
         ELSEIF(IMODP.EQ.2) THEN
          ITS(1)=1
          ITS(2)=2
          ITS(3)=0
         ENDIF

*        Now loop over the radial segments. Look for closest in Phi.
         DO 1 K=1,3

         KMIN = -1
         PMIN = 100000.
         DO 4  KSEG = 1, NRSEG
          IMOD = IBTAB(IFRSG, 8,KSEG)
          IF(IMOD.NE.ITS(K)) GOTO 4

          XRSGI = RBTAB(IFRSG, 1,KSEG)
          YRSGI = RBTAB(IFRSG, 2,KSEG)
          ZRSGI = RBTAB(IFRSG, 3,KSEG)

          XRSGO = RBTAB(IFRSG, 4,KSEG)
          YRSGO = RBTAB(IFRSG, 5,KSEG)
          ZRSGO = RBTAB(IFRSG, 6,KSEG)
          ZTEST = 0.5*(ZRSGO + ZRSGI)
          XTEST = 0.5*(XRSGO + XRSGI)
          YTEST = 0.5*(YRSGO + YRSGI)
          PTEST = ATAN2(YTEST,XTEST)
          IF(PTEST.LT.0)PTEST=PTEST+TWOPI

*         Planar prediction...
          XG   = XPSGI + (ZTEST-ZPSGI) * XSLPG
          YG   = YPSGI + (ZTEST-ZPSGI) * YSLPG
          PG   = ATAN2(YG,XG)
          IF(PG.LT.0)PG=PG+TWOPI
          DELP = ABS(PTEST-PG)
          IF(DELP.GT.(TWOPI/2.0))DELP = TWOPI-DELP
          IF(DELP.LT.PMIN) THEN
           PMIN=DELP
           KMIN=KSEG
          ENDIF
 4       CONTINUE

*        Now look at the rad seg which was closest in Phi...
         IF(KMIN.GT.0.AND.PMIN.LT.PWED) THEN
          DO 5 KDP = 1,  12
            KDS     = IBTAB(IFRSG,10+KDP,KMIN)
            KD      = IABS(KDS)
            IF(KD .GT. 0) THEN
             ICLNUM = IBTAB(IFRLC, 1, KD)
             DDD    = RBTAB(IFRLC, 2, KD)
             RADIUS = RBTAB(IFRLC, 4, KD)
             ISGNW  = IBTAB(IFRLC, 6, KD)
             ISG    = MOD(ISGNW, 2)
             PHIW   =  RBTAB(IFRG1,2+3*ISG,ICLNUM+1)
             STAGGR =  RBTAB(IFRG1,3+3*ISG,ICLNUM+1)
             ZZ     =  RBTAB(IFRG1,4+3*ISG,ICLNUM+1)
             IF(KDS.GT.0) THEN
               DRIFT = DDD - STAGGR
               DRFSGN = 1.0
             ELSE
               DRIFT = -DDD - STAGGR
               DRFSGN =-1.0
             ENDIF

             RR =   RADIUS + FLOREN(RADIUS,ABS(DRIFT),DRFSGN)
             RR   = SQRT(DRIFT**2 + RR**2)

*            Planar prediction...
             XG   = XPSGI + (ZZ-ZPSGI) * XSLPG
             YG   = YPSGI + (ZZ-ZPSGI) * YSLPG
             RP   = SQRT(XG**2 + YG**2)
*            Predicted drift...
             DPRED   = YG*COS(PHIW) - XG*SIN(PHIW)

             DELD = DRIFT - DPRED
             DELR = RR - RP

             CALL SHS(300,0,DELR)
             CALL SHD(301,0,RP,DELR)
             CALL SHD(302,0,RP,RR)
             CALL SHS(310,0,DELD)
             CALL SHD(311,0,DPRED,DRIFT)

             IF(DPRED.LT.0.0) THEN
              CALL SHS(316,0,DELD)
             ELSE
              CALL SHS(317,0,DELD)
             ENDIF

*            long projection...
             IF(K.GT.1) THEN
               CALL SHS(303,0,DELR)
               CALL SHD(304,0,RP,DELR)
               CALL SHD(305,0,RP,RR)
               CALL SHS(312,0,DELD)
               CALL SHD(313,0,DPRED,DRIFT)
             ELSE
*            short projection...
               CALL SHS(306,0,DELR)
               CALL SHD(307,0,RP,DELR)
               CALL SHD(308,0,RP,RR)
               CALL SHS(314,0,DELD)
               CALL SHD(315,0,DPRED,DRIFT)
             ENDIF
            ENDIF
 5         CONTINUE
          ENDIF

 1        CONTINUE

       ENDIF
 3    CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.06/06 28/10/92  08.58.45  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   22/07/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
C   22/07/92 207221019  MEMBER NAME  FPREZI   (FTREC)    M  FVS
      SUBROUTINE FPREZI

**: FPREZI.......SM. New deck for planar seg residuals.
**----------------------------------------------------------------------
*
*     Make diagnostic histograms of planar segments.
*
*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,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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.


* Planar segment bank...
      IFPSG = NLINK('FPSG',0)
      IF(IFPSG .EQ. 0)RETURN
* Planar hit bank...
      IFPLC = NLINK('FPLC',0)
      IF(IFPLC .EQ. 0)RETURN
* Planar geometry...
      IFPG1 = NLINK('FPG1',0)
      IF(IFPG1 .EQ. 0)RETURN

      NSEG = IW(IFPSG+2)
      NPLC = IW(IFPLC+2)
      IF(NPLC .EQ. 0) RETURN

      IMTST = 0
      DO 1 JSEG = 1, NSEG
       IMSK = IBTAB(IFPSG,9,JSEG)
       IF(IMSK.NE.IMTST) GO TO 1

*      Get segment parameters...
       PRCH = RBTAB(IFPSG,7,JSEG)
       IMOD = IBTAB(IFPSG,8,JSEG)+ 1
       XPSGI = RBTAB(IFPSG, 1,JSEG)
       YPSGI = RBTAB(IFPSG, 2,JSEG)
       ZPSGI = RBTAB(IFPSG, 3,JSEG)

       XPSGO = RBTAB(IFPSG, 4,JSEG)
       YPSGO = RBTAB(IFPSG, 5,JSEG)
       ZPSGO = RBTAB(IFPSG, 6,JSEG)

       DZG   = (ZPSGO - ZPSGI)
       XSLPG = (XPSGO - XPSGI) / DZG
       YSLPG = (YPSGO - YPSGI) / DZG

*      Loop through the (up to) 12 hits on this segment...
       NUMD  = 0
       DO 2 KDP = 1, 12
         KDIG = IBTAB(IFPSG,10+KDP,JSEG)
         KDG  = IABS(KDIG)
         K36  = 12*(IMOD-1)+KDP
         IF(KDG .NE. 0) THEN
          NUMD   = NUMD + 1
*         Get the cellnumber, hence the orientation...
          ICLNUM = IBTAB(IFPLC,1,KDG)
          IORI   = IPORI(ICLNUM)

*         Locate the hit in space...
          CALL FPWHIT(KDG,WPL, WMI, PHIDUM, WWIR, ZZ, IBB)
          WMEAS = WPL
          IF(KDIG .LT. 0)WMEAS = WMI
*         distance from wire...
          WDRIF = ABS(WMEAS-WWIR)

*         Predict x, y, U and V from segment, at z of this hit.
          XG   = XPSGI + (ZZ-ZPSGI) * XSLPG
          YG   = YPSGI + (ZZ-ZPSGI) * YSLPG
          UG   = 0.5*XG  + YG*SQRT(3.0)/2.0
          VG   = 0.5*XG  - YG*SQRT(3.0)/2.0
*         depending on wire orientation, one of these is drift!
          IF    (IORI .EQ. 0) THEN
            DELMG = WMEAS - XG
          ELSEIF(IORI .EQ. 1) THEN
            DELMG = WMEAS - UG
          ELSEIF(IORI .EQ. 2) THEN
            DELMG = WMEAS - VG
          ENDIF
*         histogram the 'residuals'...
*         by orientation...
          CALL SHS(243+IORI,0,DELMG)
          CALL SHS(     246,0,DELMG)
          CALL SHD(     247,0,WDRIF,DELMG)
         ELSE
*         Histogram missing wire...
*         Cell number of 1st cell on this wire plane...
          ICL1 = 32*(K36-1)
          IORI = IPORI(ICL1)
          ZZ   = RBTAB(IFPG1,4,ICL1+1)
*         Predict x, y, U and V from segment, at this z...
          XG   = XPSGI + (ZZ-ZPSGI) * XSLPG
          YG   = YPSGI + (ZZ-ZPSGI) * YSLPG
          UG   = 0.5*XG  + YG*SQRT(3.0)/2.0
          VG   = 0.5*XG  - YG*SQRT(3.0)/2.0
*         depending on wire orientation, one of these is drift!
          IF    (IORI .EQ. 0) THEN
            WPRED = XG
          ELSEIF(IORI .EQ. 1) THEN
            WPRED = UG
          ELSEIF(IORI .EQ. 2) THEN
            WPRED = VG
          ENDIF
          CALL SHS(263,0,FLOAT(K36))
          CALL SHD(264,0,FLOAT(K36),WPRED)
         ENDIF

 2     CONTINUE
       CALL SHS(248,0,FLOAT(NUMD))
       CALL SHS(249,0,PRCH)


 1    CONTINUE

      RETURN

      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.05/07 19/08/92  18.34.08  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   19/08/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      FUNCTION FRDSYS(RAD, LINT)

*     Calculate systematic correction to charge division coordinate

      DIMENSION ALPHA(7), BETA(7), GAMMA(7)
      DATA ALPHA/-17.0, -14.0, -12.3, -10.5,  -9.4,  -8.6,  -7.8/
      DATA BETA/ 0.361, 0.307, 0.298, 0.275, 0.264, 0.270, 0.281/
      DATA GAMMA/-0.00123, -0.00092, -0.00105, -0.00096,
     +           -0.00093, -0.00109, -0.00133/

      IF(LINT .GT.12) LINT = 12
      IF(LINT .LT. 6) LINT = 6

      J = LINT - 5

      ERRSYS = ALPHA(J) + BETA(J) * RAD + GAMMA(J) * RAD * RAD

      FRDSYS = RAD + ERRSYS

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.06/02 05/09/92  12.07.09  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   04/09/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTKRAN
*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,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.

      INDTKR = NLINK('FTKR',0)
      IF(INDTKR .EQ.0) RETURN

      NTRKS  = IW(INDTKR+2)
      DO 1 J = 1, NTRKS
        NX   = IBTAB(INDTKR, 19, J)
        IF(NX .GE. 0) THEN
          X  = RBTAB(INDTKR, 4, J)
          Y  = RBTAB(INDTKR, 5, J)
          Z  = RBTAB(INDTKR, 6, J)
          CALL SHD(900, 0, X, Y)
          CALL SHD(901, 0, Z, Y)
        ENDIF
 1    CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.09/01 05/05/93  09.53.05  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   10/09/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FEFFIC
*
*     Estimate radial segment finding efficiency
*

*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,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 FRSX bank - one of these per pattern recognised track...
      INDPSX = NLINK('FPSX',0)
      IF(INDPSX .EQ. 0) RETURN
      INDPSG = NLINK('FPSG',0)
      IF(INDPSG .EQ. 0) RETURN

      INDRSX = NLINK('FRSX',0)
      IF(INDRSX .EQ. 0) RETURN
      INDRSG = NLINK('FRSG',0)
      IF(INDRSG .EQ. 0) RETURN

      NTRK = IW(INDRSX+2)
      NSEG = IW(INDPSG+2)
      IF(NTRK .EQ. 0) RETURN
      ICAND = 0
      IFOUND= 0
      N3MOD = 0

      DO 1 J = 1, NTRK
*      Row of first planar segment on track...
       IPG1 = IBTAB(INDPSX,1,J)
       IF(IPG1 .EQ. 0) THEN
        GO TO 1
       ENDIF
       IF(IPG1 .GT. NSEG) THEN
        Write(6,*) ' FEFFIC WARNING!!>> Bad segment pointer in FPSX'
        RETURN
       ENDIF

*      Row of second segment on track...
       IPG2 = IBTAB(INDPSG,10,IPG1)
       IF(IPG2 .EQ. 0 .OR. IPG2.EQ. IPG1) THEN
        GO TO 1
       ENDIF
       IF(IPG2 .GT. NSEG) THEN
        Write(6,*) ' FEFFIC WARNING!!>> Bad segment pointer in FRSX'
        RETURN
       ENDIF
       IPG3 = IBTAB(INDPSG,10,IPG2)
       IF(IPG3 .EQ. IPG1) THEN
*       Two-module track. Extract Track data...
*       Write(6,*) ' FEFFIC >> Two-P seg track found'
        ISM1 = IBTAB(INDPSG, 8,IPG1)
        ISM2 = IBTAB(INDPSG, 8,IPG2)

*       radial sandwich config...
        IEXPEC = -1
        IF(    ISM1.EQ.0 .AND. ISM2 .EQ.1) THEN
          IEXPEC=0
        ELSEIF(ISM1.EQ.1 .AND. ISM2 .EQ.2) THEN
          IEXPEC=1
        ELSE
          GO TO 1
        ENDIF
        ICAND = ICAND + 1
        CALL SHS(2010,0,1.1)

*       Look for appropriate radial segment...
*       Row of first radial segment on track...
        IRG1 = IBTAB(INDRSX,1,J)
        IF(IRG1 .NE. 0) THEN
         IRM1 = IBTAB(INDRSG, 8,IRG1)
         IF(IRM1 .EQ. IEXPEC) THEN
           IFOUND = IFOUND + 1
           CALL SHS(2010,0,2.1)
           GO TO 1
         ELSE
*          Row of second segment on track...
           IRG2 = IBTAB(INDRSG,10,IRG1)
           IF(IRG2 .NE. IRG1 .AND. IRG2.NE.0) THEN
            IRM2 = IBTAB(INDRSG, 8,IRG2)
            IF(IRM2 .EQ. IEXPEC) THEN
              IFOUND = IFOUND + 1
              CALL SHS(2010,0,2.1)
              GO TO 1
            ELSE
              IRG3 = IBTAB(INDRSG, 8,IRG2)
              IF(IRG3 .NE. IRG1 .AND. IRG3.NE.0) THEN
               IRM3 = IBTAB(INDRSG, 8,IRG3)
               IF(IRM3 .EQ. IEXPEC) THEN
                 IFOUND = IFOUND + 1
                 CALL SHS(2010,0,2.1)
                 GO TO 1
               ENDIF
              ENDIF
            ENDIF
           ENDIF
         ENDIF
        ENDIF

       ELSE
*       Three Module track. Nice...
        ICAND = ICAND + 2
        CALL SHS(2010,0,1.1)
        CALL SHS(2010,0,1.1)

*       Look for appropriate radial segments...
*       Row of first radial segment on track...
        IRG1 = IBTAB(INDRSX,1,J)
        IF(IRG1 .NE. 0) THEN
         IRM1 = IBTAB(INDRSG, 8,IRG1)
         IF(IRM1 .EQ. 0 .OR. IRM1 .EQ. 1) THEN
           IFOUND = IFOUND + 1
           CALL SHS(2010,0,2.1)
           GO TO 1
         ELSE
*          Row of second segment on track...
           IRG2 = IBTAB(INDRSG,10,IRG1)
           IF(IRG2 .NE. IRG1 .AND. IRG2.NE.0) THEN
            IRM2 = IBTAB(INDRSG, 8,IRG2)
            IF(IRM2 .EQ. 0 .OR. IRM2 .EQ. 1) THEN
              IFOUND = IFOUND + 1
              CALL SHS(2010,0,2.1)
              GO TO 1
            ELSE
              IRG3 = IBTAB(INDRSG, 8,IRG2)
              IF(IRG3 .NE. IRG1 .AND. IRG3.NE.0) THEN
               IRM3 = IBTAB(INDRSG, 8,IRG3)
               IF(IRM3 .EQ. 0 .OR. IRM3 .EQ. 1) THEN
                 IFOUND = IFOUND + 1
                 CALL SHS(2010,0,2.1)
                 GO TO 1
               ENDIF
              ENDIF
            ENDIF
           ENDIF
         ENDIF
        ENDIF

       ENDIF

 1    CONTINUE
*
      IF(ICAND .GT. 0) THEN
        EFF = FLOAT(IFOUND) / FLOAT(ICAND)
        CALL SHS(2001,0,EFF)
      ENDIF


      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.06/02 21/09/92  11.41.20  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   21/09/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FOXY
*
*
*  Make scatter plots of digitisation locations in FTD.
*
*  For Radials, space points from FRLC are used.
*  For Planars, where space points are not defined at the hit level,
*  the x-y coordinates of segment start positions are used (ex FPSG)
*
*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)
*     Locators for FRG1 bank
      PARAMETER(IPDEAD=1)
      PARAMETER(IPRPHP=2)
      PARAMETER(IPRSTP=3)
      PARAMETER(IPRPHM=5)
      PARAMETER(IPRSTM=6)
*     Locators for FRLC bank
      PARAMETER(IPRCLN=1)
      PARAMETER(IPRDRF=2)
      PARAMETER(IPRRAD=4)
      PARAMETER(IPRSGW=6)

      LOGICAL FIRST
      DATA FIRST/.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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
*----------------------------------------------------------------------
*     Initialisations on first call...
      IF(FIRST) THEN
         FIRST  = .FALSE.
         IQFRLC = NAMIND('FRLC')
         IQFRG1 = NAMIND('FRG1')
      ENDIF
*-----------------------------------------------------------
*     Space points in Radials ex FRLC bank...

      IFRG1 = IW(IQFRG1)
      IF(IFRG1.EQ.0) THEN
*       Create FRLC bank...
        CALL FTCORG
        IFRG1 = IW(IQFRG1)
        IF(IFRG1.EQ.0) THEN
          WRITE(6,'('' FRCART : failure to create FRG1 bank'')')
          CALL H1STOP
        ENDIF
      ENDIF

      IFRLC = IW(IQFRLC)
      IF(IFRLC.EQ.0) THEN
*       Create FRLC bank...
        CALL FRLOCO
        IFRLC = IW(IQFRLC)
        IF(IFRLC.EQ.0) THEN
          WRITE(6,'('' FRCART : failure to create FRLC bank'')')
          CALL H1STOP
        ENDIF
      ENDIF

      NFRLC = IW(IFRLC+2)
      DO 1 IROW = 1, NFRLC
        ICLNUM=        IBTAB(IFRLC,IPRCLN,IROW)
        DRIFT =        RBTAB(IFRLC,IPRDRF,IROW)
        RADIUS=        RBTAB(IFRLC,IPRRAD,IROW)
        ISGNW =    MOD(IBTAB(IFRLC,IPRSGW,IROW),2)

*       Phi, Stagger and Z of wire
        PHI         =  RBTAB(IFRG1,2+3*ISGNW,ICLNUM+1)
        STAGGR      =  RBTAB(IFRG1,3+3*ISGNW,ICLNUM+1)
        ZZ          =  RBTAB(IFRG1,4+3*ISGNW,ICLNUM+1)

        DSIGN   =  1.
        DDD     =  DRIFT*DSIGN + STAGGR
        RR      =  RADIUS + FLOREN(RADIUS,ABS(DDD),DSIGN)
        XXP     =  RR*COS(PHI) - DDD*SIN(PHI)
        YYP     =  RR*SIN(PHI) + DDD*COS(PHI)
        DSIGN   = -1.
        DDD     =  DRIFT*DSIGN + STAGGR
        RR      =  RADIUS + FLOREN(RADIUS,ABS(DDD),DSIGN)
        XXM     =  RR*COS(PHI) - DDD*SIN(PHI)
        YYM     =  RR*SIN(PHI) + DDD*COS(PHI)

        ISM     =  IRMOD(ICLNUM)

        CALL SHD(703,    0,XXP,YYP)
        CALL SHD(703,    0,XXM,YYM)
        CALL SHD(700+ISM,0,XXP,YYP)
        CALL SHD(700+ISM,0,XXM,YYM)
 1    CONTINUE

*     Planar and radial segment data...
      IFRSG = NLINK('FRSG',0)
      IFPSG = NLINK('FPSG',0)
      IF(IFRSG .NE. 0) THEN
        NFRSG = IW(IFRSG+2)
      ELSE
        NFRSG = 0
      ENDIF

      IF(IFPSG .NE. 0) THEN
        NFPSG = IW(IFPSG+2)
      ELSE
        NFPSG = 0
      ENDIF

      DO 2 JROW = 1, NFRSG
        XIN = RBTAB(IFRSG, 1, JROW)
        YIN = RBTAB(IFRSG, 2, JROW)
        ISM = IBTAB(IFRSG, 8, JROW)

        CALL SHD(713,     0, XIN, YIN)
        CALL SHD(710+ISM, 0, XIN, YIN)
 2    CONTINUE
      DO 3 JROW = 1, NFPSG
        XIN = RBTAB(IFPSG, 1, JROW)
        YIN = RBTAB(IFPSG, 2, JROW)
        ISM = IBTAB(IFPSG, 8, JROW)

        CALL SHD(723,     0, XIN, YIN)
        CALL SHD(720+ISM, 0, XIN, YIN)
 3    CONTINUE
*     Done
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.09/01 25/04/93  18.56.10  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   02/03/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTEND(JEVENT)
*
*     Print summary information at end of job
*
      PARAMETER(NDIM=50)
      DIMENSION AVEC(50), ICN(50), XSTAT(4), YSTAT(4)
      CHARACTER*40 TXT101(14)
      CHARACTER*40 TXT716(8)
      CHARACTER*40 TXT711(5)
      CHARACTER*40 TXT712(9)
      CHARACTER*40 TXT713(5)
      CHARACTER*40 TXT714(4)
      DATA TXT101/
     +           '    Total number of pattern-rec   tracks',
     +           '    Mean number of patrec tracks /event ',
     +           '    Min  number of patrec tracks /event ',
     +           '    Max  number of patrec tracks /event ',
     +           '    Mean number hits/radial segment     ',
     +           '    Mean number hits/radial segment SM0 ',
     +           '    Mean number hits/radial segment SM1 ',
     +           '    Mean number hits/radial segment SM2 ',
     +           '    Mean number hits/planar segment     ',
     +           '    Mean number hits/planar segment SM0 ',
     +           '    Mean number hits/planar segment SM1 ',
     +           '    Mean number hits/planar segment SM2 ',
     +           '    Frac of Rad hits on segments        ',
     +           '    Frac of Pla hits on segments        '/
      DATA TXT716/
     +           '    Number of P0P1P2 planar-based tracks',
     +           '    Number of P0P1   planar-based tracks',
     +           '    Number of   P1P2 planar-based tracks',
     +           '    Number of P0  P2 planar-based tracks',
     +           '    Total number     planar-based tracks',
     +           '    Number of single-planar ->rad tracks',
     +           '    Number of single planar       tracks',
     +           '    Total number of tracks with p-segs  '/
      DATA TXT711/
     +           '    Num rad-based trks verified by P    ',
     +           '    Num rad-based trks not verified by P',
     +           '    Num rad-based trks rejected by P    ',
     +           '    Number of single radial tracks      ',
     +           '    Total number of radial based tracks '/
      DATA TXT712/
     +           '    Planar-1 -> Radial-0                ',
     +           '    Planar-2 -> Radial-1                ',
     +           '    Planar-0 -> Radial-0                ',
     +           '    Planar-1 -> Radial-1                ',
     +           '    Planar-2 -> Radial-2                ',
     +           '    1P->R tracks with 1 radial segment  ',
     +           '    1P->R tracks with 2 radial segments ',
     +           '    1P->R tracks with 3 radial segments ',
     +           '    Total 1P->R linked tracks           '/
      DATA TXT713/
     +           '    Num pla-based trks verified by R    ',
     +           '    Rad segments on R- and P-based trks ',
     +           '    Pla segments on R- and P-based trks ',
     +           '    Tot ambiguities R- and P-based trks ',
     +           '    R-based tracks split by planars     '/
      DATA TXT714/
     +           '    Num rad segs in SM 0 1 2            ',
     +           '    Num rad segs in SM 0 1 2 unlinked   ',
     +           '    Num pla segs in SM 0 1 2            ',
     +           '    Num pla segs in SM 0 1 2 unlinked   '/


*     Statement function for extracting content from histograms...
      ICON(X) = IFIX(AVEC(IFIX(2.0*X + 1.0)))
*     Extract scalar data from histograms...

      Write(6,'('' '')')
      Write(6,'('' '',62(''-''))')
      Write(6,'('' '',20X,''FTREC Pattern Recognition Summary'')')
      Write(6,'('' '',62(''-''))')
      Write(6,'('' '')')
      Write(6,'('' '',5X,'' => Number of Events analysed           '',
     +          8X,I8)')JEVENT
      Write(6,'('' '')')

*     Number of pattern-recognised tracks:-
      CALL SAREA('FTREC',2)
      CALL RWDATA('HS', 711, 0)
      CALL GDATA( 'HS', 711, 0, NREAD, AVEC, NDIM)
      NTTRKS = ICON( 7.0)

      CALL SAREA('FTREC',1)
*     CALL GHSTAT('HS', 101, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,I6)')  TXT101( 1), NTTRKS
*     Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 2),XSTAT(3)
*     Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 3),XSTAT(1)
*     Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 4),XSTAT(2)
      Write(6,'('' '')')

      CALL GHSTAT('HS', 200, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 5),XSTAT(3)
      CALL GHSTAT('HS', 201, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 6),XSTAT(3)
      CALL GHSTAT('HS', 202, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 7),XSTAT(3)
      CALL GHSTAT('HS', 203, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 8),XSTAT(3)

      CALL GHSTAT('HS', 320, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101( 9),XSTAT(3)
      CALL GHSTAT('HS', 321, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101(10),XSTAT(3)
      CALL GHSTAT('HS', 322, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101(11),XSTAT(3)
      CALL GHSTAT('HS', 323, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
      Write(6,'('' '',5X,A40,10X,F6.2)')TXT101(12),XSTAT(3)

*     Write(6,'('' '')')
*     CALL GHSTAT('HS', 260, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
*     Write(6,'('' '',5X,A40,10X,F6.2)')TXT101(10),XSTAT(3)
*     CALL GHSTAT('HS', 262, 0, NENT, SUMW, RNEFF, XSTAT, YSTAT)
*     Write(6,'('' '',5X,A40,10X,F6.2)')TXT101(11),XSTAT(3)
      Write(6,'('' '')')

      CALL SAREA('FTREC',2)
      Write(6,'('' '',5X,'' -> Planar-based Tracks...  '')')
      CALL RWDATA('HS', 716, 0)
      CALL GDATA( 'HS', 716, 0, NREAD, AVEC, NDIM)
      ICN(1) = ICON( 1.0)
      ICN(2) = ICON( 3.0)
      ICN(3) = ICON( 5.0)
      ICN(4) = ICON( 7.0)
      ICN(5) = ICN(1) + ICN(2) + ICN(3) + ICN(4)
      ICN(6) = ICON(10.0)
      ICN(7) = ICON(11.0)
      ICN(8) = ICN(5) + ICN(6) + ICN(7)
      DO 1 K = 1, 8
       WRITE(6,'('' '',5X,A40,10X,I6)')TXT716(K), ICN(K)
1     CONTINUE
*     Need one number from His 713 here
      CALL RWDATA('HS', 713, 0)
      CALL GDATA( 'HS', 713, 0, NREAD, AVEC, NDIM)
      ICN(1) = ICON( 1.0)
      WRITE(6,'('' '',5X,A40,10X,I6)')TXT713(1), ICN(1)

      Write(6,'('' '')')
      Write(6,'('' '',5X,'' -> Single-P extrapolated to rads'')')
      CALL RWDATA('HS', 712, 0)
      CALL GDATA( 'HS', 712, 0, NREAD, AVEC, NDIM)
      ICN(1) = ICON( 1.0)
      ICN(2) = ICON( 3.0)
      ICN(3) = ICON( 5.0)
      ICN(4) = ICON( 7.0)
      ICN(5) = ICON( 9.0)
      ICN(6) = ICON(21.0)
      ICN(7) = ICON(22.0)
      ICN(8) = ICON(23.0)
      ICN(9) = ICON(10.0)
      DO 2 K = 1, 9
       WRITE(6,'('' '',5X,A40,10X,I6)')TXT712(K), ICN(K)
2     CONTINUE

      Write(6,'('' '')')
      Write(6,'('' '',5X,'' -> R-based tracks...'')')
      CALL RWDATA('HS', 711, 0)
      CALL GDATA( 'HS', 711, 0, NREAD, AVEC, NDIM)
      ICN(1) = ICON( 2.0)
      ICN(2) = ICON( 3.0)
      ICN(3) = ICON( 4.0)
      ICN(4) = ICON( 6.0)
      ICN(5) = ICN(4) + ICN(1) + ICN(2)
      DO 3 K = 1, 5
       WRITE(6,'('' '',5X,A40,10X,I6)')TXT711(K), ICN(K)
3     CONTINUE

      Write(6,'('' '')')
      Write(6,'('' '',5X,'' -> R-based/P-based overlaps...'')')
      CALL RWDATA('HS', 713, 0)
      CALL GDATA( 'HS', 713, 0, NREAD, AVEC, NDIM)
      ICN(1) = ICON( 1.0)
      ICN(2) = ICON( 2.0)
      ICN(3) = ICON( 3.0)
      ICN(4) = ICON( 4.0)
      ICN(5) = ICON( 4.5)
      DO 4 K = 2, 5
       WRITE(6,'('' '',5X,A40,10X,I6)')TXT713(K), ICN(K)
4     CONTINUE

      Write(6,'('' '')')
      Write(6,'('' '',5X,'' -> Single Radial and Planars...'')')
      CALL RWDATA('HS', 714, 0)
      CALL GDATA( 'HS', 714, 0, NREAD, AVEC, NDIM)

      ICN(1)  = ICON( 1.0)
      ICN(2)  = ICON( 2.0)
      ICN(3)  = ICON( 3.0)

      ICN(5)  = ICON( 6.0)
      ICN(6)  = ICON( 7.0)
      ICN(7)  = ICON( 8.0)

      ICN(11) = ICON(11.0)
      ICN(12) = ICON(12.0)
      ICN(13) = ICON(13.0)

      ICN(16) = ICON(16.0)
      ICN(17) = ICON(17.0)
      ICN(18) = ICON(18.0)

      WRITE(6,'('' '',5X,A40, 4X,3I6)')TXT714(1),(ICN(J), J=11,13)
      WRITE(6,'('' '',5X,A40, 4X,3I6)')TXT714(2),(ICN(J), J= 1, 3)
      WRITE(6,'('' '',5X,A40, 4X,3I6)')TXT714(3),(ICN(J), J=16,18)
      WRITE(6,'('' '',5X,A40, 4X,3I6)')TXT714(4),(ICN(J), J= 5, 7)

      Write(6,'('' '')')
      Write(6,'('' '')')
      Write(6,'('' '')')
      Write(6,'('' '')')
      Write(6,'('' '')')

      CALL SAREA('FTREC',1)
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.09/01 22/04/93  19.02.18  by  Stephen J. Maxfield
*-- Author :    J. V. Morris          17/04/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      FUNCTION FPLT2D(TICK,SGN,IWCH)
**********************************************************************
*                                                                    *
* Planar Time-to-Distance model.                                     *
* TICK is drift time in ticks with Tzero already subtracted          *
* SGN is +1.0 for "near" wires -1.0 for "far" wires                  *
* if SGN = 0.0, then then no near/far asymmetry adjustment is made   *
* IWCH is the planar channel number (0 to 1151)                      *
* FPLT2D   is the computed drift distance in cm.                     *
*                                                                    *
* The function uses microns and nsecs internally                     *
* JVM 04/01/93                                                       *
*                                                                    *
* Include 6% velocity asymmetry beta                                 *
* JVM 21/01/93                                                       *
*                                                                    *
* The velocity asymmetry is disabled until it can be tested!         *
* Include different T-2-D for "inner" and "outer" wires.             *
* JVM 08/04/93                                                       *
*                                                                    *
* Change interface to calibration constants.                         *
* Add SGN = 0.0 option.                                              *
* SJM 17/04/93                                                       *
**********************************************************************


*>>>>>>>>>>>>> interface to calibration constants
*     Common for time-to-distance relation
      COMMON/T2DISP/ VEL(24), XPT(18)

*SJM  VEL(1:4)   = Vout. VEL(5:8)   = Vin. far wires
*SJM  VEL(9:12)  = Vout. VEL(13:16) = Vin. symmetric case
*SJM  VEL(17:20) = Vout. VEL(21:24) = Vin. near wires
*SJM  XPT(1:3)   = Xout. XPT(4:6)   = Xin. far wires
*SJM  XPT(7:9)   = Xout. XPT(10:12) = Xin. symmetric case
*SJM  XPT(13:15) = Xout. XPT(16:18) = Xin. near wires


*JVM  VIN  = 44.93, 32.93, 33.12, 28.92        for run 34469
*JVM  VOUT = 46.55, 31.80, 32.99, 29.17        for run 34469
*JVM  X0IN = 5025., 16360., 28100.             for all runs
*JVM  X0OUT= 5025., 17080., 28100.             for all runs
*>>>>>>>>>>>>> end of calibration constants


* The parameters V(1) to V(4) (local drift velocities in micron/nsec),
* X(1) and X(2) have been determined by a fit to the drift time
* distribution from run 34469 with the constraint that the resulting
* drift distance distribution be flat. X(3) is the nominal Planar cell
* depth in microns.

*     channel  outer, inner => IOFF = 0, 1
      IWW = MOD(IWCH,4)
      IF( IWW.EQ.0 .OR. IWW.EQ.3 )THEN ! outer
         IOFF  = 0
      ELSE                             ! inner
         IOFF  = 1
      ENDIF
*     Far, symmetric, near => ISGN = -1,0,+1
      IF(SGN .EQ. 0.0) THEN
        ISGN = 0
      ELSE
        ISGN = INT(SIGN(1.1,SGN))
      ENDIF

      IV = (ISGN + 1)*8 + IOFF*4
      IX = (ISGN + 1)*6 + IOFF*3

*     Write(6,'('' Vel'',4F10.6)')(VEL(IV+LL), LL = 1,4)
*     Write(6,'('' Xpt'',4F10.2)')(XPT(IX+LL), LL = 1,3)

*     T in nsecs
      T      = TICK * 0.1923077
      FPLT2D = 0.0


      IF( T.LE.0.) THEN
         FPLT2D = VEL(IV+1)*T
         GOTO 1000
      ENDIF

*     Drift time to X(1)
      TL1 = XPT(IX+1)*ALOG(VEL(IV+2)/VEL(IV+1))/(VEL(IV+2)-VEL(IV+1))

      IF( T.LE.TL1 ) THEN
         D = XPT(IX+1)
         DV = VEL(IV+2)-VEL(IV+1)
         FPLT2D = D*VEL(IV+1)*( EXP(DV*T/D)-1.0 )/DV
         GOTO 1000
      ENDIF

      D = XPT(IX+2)-XPT(IX+1)
      DV= VEL(IV+3)-VEL(IV+2)
*     Drift time to X(2)
      TL2 = TL1 + D*ALOG(VEL(IV+3)/VEL(IV+2))/DV

      IF( T.LE.TL2 ) THEN
         FPLT2D = XPT(IX+1)+D*VEL(IV+2)*( EXP(DV*(T-TL1)/D)-1.0 )/DV
         GOTO 1000
      ENDIF

      D = XPT(IX+3)-XPT(IX+2)
      DV= VEL(IV+4)-VEL(IV+3)
*     Drift time to X(3)
      TL3 = TL2 + D*ALOG(VEL(IV+4)/VEL(IV+3))/DV

      IF( T.LE.TL3 ) THEN
         FPLT2D = XPT(IX+2)+D*VEL(IV+3)*( EXP(DV*(T-TL2)/D)-1.0 )/DV
         GOTO 1000
      ENDIF

      FPLT2D = XPT(IX+3) + VEL(IV+4)*(T-TL3)

*     Microns to cm
 1000 FPLT2D = FPLT2D * 1.0E-4

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZ :  7.00/14 29/06/95  19.53.51  by  G. Raedel
*CMZ :  6.00/09 13/01/95  16.28.02  by  Stephen J. Maxfield
*CMZU:  4.03/01 18/01/94  13.12.34  by  Stephen Burke
*CMZU:  3.09/01 20/05/93  17.45.39  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   18/05/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FSETMC
*
*     Set version numbers of the appropriate steering/cal banks
*     to be picked up from database.
*     Only applicable to Monte Carlo Events.
*
*           FDIGI Vers -+
*                       |
      PARAMETER(IMCV1=21300)
*                       |
*                       +------MC versions < this are 'old' MC
*
*                       +------Use 'old' versions of recon banks
*                       |
      PARAMETER(IRCV1=30115)
*
*                       +------otherwise new new versions.
*                       |
*
* set version number for steering banks according to H1REC version
* > 7.00/00 -> H1TEXT version >3.04/20
      PARAMETER(IRECV1=70000)
      PARAMETER(IBANK1=30420)


      IDAT  = JRDATA('RUNTYPE',IRET)

      IF(IRET.EQ.0 .AND. IDAT.EQ.1) THEN
*       Get Monte Carlo version number for steering and calibration...
        MCVER = MDVERS('FDIGI')
        RECVER = MDVERS('FTREC')
        IF(    MCVER .LT. IMCV1) THEN
          CALL MODDEF(IRCV1)
        ELSEIF(RECVER.LT.IRECV1)THEN
          CALL MODDEF(IBANK1)
        ELSE
          CALL MODDEF(0)
        ENDIF

      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.09  by  Stephen Burke
*CMZU:  3.09/01 18/05/93  19.47.09  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   18/05/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRSTMC
*
*     Reset DB version to defaults for MC events.
*

      IDAT  = JRDATA('RUNTYPE',IRET)

      IF(IRET.EQ.0 .AND. IDAT.EQ.1) THEN

          CALL MODDEF(0)

      ENDIF

      RETURN
      END
*CMZ :  8.07/00 20/11/96  17.54.31  by  Stephen Burke
*CMZ :  8.04/00 22/07/96  17.19.47  by  Stephen Burke
*CMZ :  8.03/00 27/06/96  11.47.33  by  Stephen Burke
*CMZ :  7.09/08 05/03/96  21.31.00  by  Stephen Burke
*CMZU:  7.03/08 12/12/95  17.37.45  by  Stephen Burke
*CMZU:  7.02/11 01/11/95  18.43.49  by  Stephen Burke
*CMZU:  7.02/00 24/08/95  13.18.26  by  Stephen Burke
*CMZU:  5.03/00 03/05/94  16.18.24  by  Stephen J. Maxfield
*CMZ :  4.00/11 07/12/93  08.51.12  by  Gregorio Bernardi
*CMZ :  4.00/08 02/12/93  21.42.15  by  Gregorio Bernardi
*CMZ :  4.00/00 31/08/93  16.48.46  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.22  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   06/03/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPLOCO
**: FPLOCO.......SM. Allow for near/far asymmetry. Extend FPLC bank,
**: FPLOCO.......SM. get stagger from FGAP.
**: FPLOCO.......SB. Correct for trigger in wrong bunch crossings.
**----------------------------------------------------------------------
**: FPLOCO 30907 RP. Farm changes.
**----------------------------------------------------------------------
**: FPLOCO 30907 SM. Add event T0 from CEVT0.
**: FPLOCO 30907 SM. Bug fix. Drop banks at begin for display.
**----------------------------------------------------------------------
**: FPLOCO 30207 GB. comment lines moved inside the routine
**: FPLOCO 30205 SM. Modifications fror Filter Farm. Add histogram.
**----------------------------------------------------------------------
*==================================================================
*     Calculate LOCAL COORDINATES of digitisations in the Planar
*     Drift Chambers from contents of FRPE bank and database.
*     The drift distance is computed and corrected as described
*     in the in-line comments below.
*     The following effects are NOT corrected for here:
*         * Geometrical displacements and distortions
*         * Track angle effects
*     However, the parameter DR, needed for the track angle correction,
*     is obtained from the F0P8 bank and stored in COMMON FRLORA along
*     with the tangent of the Lorentz angle for completeness.
*     A temporary bank is created, FPLC containing the results.
*     This bank is parallel to the FRPE bank. It is a named bank but
*     is not put on the E-list:
*
*!       BANKname BANKtype      ! Comments
* TABLE  FPLC                   ! Local coordinates and data for hits
*                               ! in Planar Drift Chambers.
*                               ! TEMPORARY. Parallel to FRPE bank.
*!   ATTributes:
*!   -----------
*!COL ATT-name FMT Min    Max   ! Comments
*!
*  1  ICLNUM   I                !  Drift cell number
*  2  DRIFT    F                !  Abs drift distance (cms)
*  3  ERRDRF   F                !  Error in  drift distance (cms)
*  4  ISGNW    I                !  Bit 0 not used.
*                               !  Bit 1 not used.
*                               !  Bit 2 0=>O.K. 1=> dubius drift
*                               !  Bits3-6 not used.
*                               !  Bit 7 0=>O.K. 1=> bad timing
*                               !                    don't use.
*  5  CHARGE                    !  Charge integral
*
*
*  6  DRIFTP                    !  Drift distance for +side tracks
*  7  DRIFTM                    !  Drift distance for -side tracks
*
*!
* END TABLE
*     NOTES:
*
*     The drift error is a parametrised function of distance.
*     The error has been inflated where bit 2 is set.
*
*     The drift distances are NOT signed.
*
*     DRIFT is the drift distance to be used in conjunction with
*     the EFFECTIVE stagger when it is not known which side of the
*     wire plane the track went. There are then 2 possible space
*     points given by:
*            EFFECTIVE stagger + DRIFT
*       and  EFFECTIVE stagger - DRIFT
*
*     DRIFTP and DRIFTM should be used when the drift sign is known:
*            Geometric Stagger + DRIFTP
*       or   Geometric Stagger - DRIFTM
*
*       >>>> Exception: If drift time comes out negative after
*                       subtraction of T0, then DRIFTs will be negative.
*                       They should however be used as described above.
*
*!       BANKname BANKtype      ! Comments
* TABLE  FPHC                   ! Map showing number of hits in each
*                               ! Cell. Row number = Cell number + 1
*                               ! TEMPORARY.
*!   ATTributes:
*!   -----------
*!COL ATT-name FMT Min    Max   ! Comments
*!
*  1  NHITS    I                !  Number of hits in Drift cell
*  2  IFRPE    I                !  Pointer to 1st hit in FRPE/FPLC
*!
* END TABLE
*======================================================================

*     bank number forvarious banks.
      PARAMETER(NBN=0)
      PARAMETER(NCFPLC=7)

      PARAMETER(NCFPHC=2)
      PARAMETER(NRFPHC=1152)

*     Locators for stuff in F0P8 bank (overall constants)
      PARAMETER(ITZER=1)
      PARAMETER(IVDRF=4)
      PARAMETER(ID0=5)
      PARAMETER(ID1=6)
      PARAMETER(ID2=7)
      PARAMETER(IC0=8)
      PARAMETER(IC1=9)
      PARAMETER(IDR=10)


*     Locators for stuff in F1PA bank (wire-by-wire constants)
      PARAMETER(IT0=1)

*     Locators for stuff in FCP1 bank (time-to-distance run dependent)
      PARAMETER(IVEL=2)
      PARAMETER(IXPT=10)
      PARAMETER(IBETA=16)
      PARAMETER(ISTAG=21)
      PARAMETER(IDRMAX=22)
      PARAMETER(ITBMIN=23)

*     Locators for stuff in FCP2 bank (resolution function)
      PARAMETER(IERRD0=2)
      PARAMETER(IERRD1=3)
      PARAMETER(IERRD2=4)
      PARAMETER(IERRD3=5)
      PARAMETER(IFUN=6)

*     Parameter for scaling microns->cms.
      PARAMETER(EMTOC=10000.)

*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,FWINDS.
*     Work bank indices...
      COMMON/FWINDS/ INFRRE, INFRPE, ILWPG1, ILWRG1
*KEND.

*     Common for time-to-distance relation
      COMMON/T2DISP/ VEL(24), XPT(18)

*     Local arrays, variables.
      DIMENSION PSTAGG(0:8)

*     Local arrays, variables.
      DIMENSION BAR(NCFPLC),   IAR(NCFPLC)
      EQUIVALENCE(BAR(1), IAR(1))

      LOGICAL FIRST
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
      DATA    FIRST/.TRUE./
      DATA NEGRUN /-1/



      IF(FIRST) THEN
         FIRST  =  .FALSE.
         IQFRPE = NAMIND('FRPE')
         IQFTDC = NAMIND('FTDC')
         IQF0P8 = NAMIND('F0P8')
         IQF1PA = NAMIND('F1PA')
         IQFCP1 = NAMIND('FCP1')
         IQFCP2 = NAMIND('FCP2')
         IQFGAP = NAMIND('FGAP')

         CALL BKFMT('FPLC','2I,(I,2F,I,3F)')
         CALL BKFMT('FPHC','2I,(2I)')
         CALL BKFMT('FTT0','2I,(F,I)')

      ENDIF
*
*
      IF(BEGRUN .OR. NCCRUN .NE.NEGRUN) THEN
          NEGRUN  = NCCRUN
*
*       Hit database to update overall (F0P8) and
*       wire-by-wire (F1P8) constants.
*
        CALL UGTBNK('F0P8',IND)
        CALL UGTBNK('F1PA',IND)
        CALL UGTBNK('FCP1',IND)
        CALL UGTBNK('FCP2',IND)
        CALL UGTBNK('FGAP',IND)

*       Extract needed overall constants...
        IND0P8 = IW(IQF0P8)
        TZER   = RBTAB(IND0P8,ITZER,1)

*       Extract drift velocity parameters...
        INDCP1 = IW(IQFCP1)
        INDGAP = IW(IQFGAP)

*       Geometric Stagger...
*       Geometric Stagger...
        NMODP    = IW(INDGAP+3)
        KIND  = INDGAP + IW(INDGAP+1) + 1
        DO 2 KMOD = 0, NMODP-1
          PSTAGG(KMOD)  = RW(KIND+5)
          KIND   = KIND + IW(KIND+1) + 1
*         Write(6,*) 'Stagger:', KMOD, PSTAGG(KMOD)
 2      CONTINUE
        STAG     = ABS(PSTAGG(0))

*Run validity number for check...
        IVALR  = IBTAB(INDCP1, 1, 1)

        DO 10 KP = 1, 4
          BETA       = RBTAB(INDCP1, IBETA +KP, 1)

*> outer-far, inner-far, outer-symm, inner-symm, outer-near, inner-near

          VEL(KP)    = RBTAB(INDCP1, IVEL  +KP, 1)*(1.0- BETA)
          VEL(KP+4)  = RBTAB(INDCP1, IVEL+4+KP, 1)*(1.0- BETA)
          VEL(KP+8)  = RBTAB(INDCP1, IVEL  +KP, 1)
          VEL(KP+12) = RBTAB(INDCP1, IVEL+4+KP, 1)
          VEL(KP+16) = RBTAB(INDCP1, IVEL  +KP, 1)*(1.0+ BETA)
          VEL(KP+20) = RBTAB(INDCP1, IVEL+4+KP, 1)*(1.0+ BETA)
 10     CONTINUE

        DO 12 KP = 1, 6
*> outer-far, inner-far, outer-symm, inner-symm, outer-near, inner-near
          XPT(KP)   = RBTAB(INDCP1, IXPT  + KP, 1)+ STAG
          XPT(KP+6) = RBTAB(INDCP1, IXPT  + KP, 1)
          XPT(KP+12)= RBTAB(INDCP1, IXPT  + KP, 1)- STAG
 12     CONTINUE

*       <v> for this run...
        VDRFT    = RBTAB(INDCP1, IVEL , 1)

*       fiducial cuts...
        DRMAX    = RBTAB(INDCP1, IDRMAX, 1)
        TBMIN    = RBTAB(INDCP1, ITBMIN, 1)

*       Extract resolution parameters...
        INDCP2 = IW(IQFCP2)
        ERRD0    = RBTAB(INDCP2, IERRD0, 1)
        ERRD1    = RBTAB(INDCP2, IERRD1, 1)
        ERRD2    = RBTAB(INDCP2, IERRD2, 1)
        ERRD3    = RBTAB(INDCP2, IERRD3, 1)
        IFUNNY   = IBTAB(INDCP2, IFUN,   1)

*       Correction parameter for track angle effect
        DTANGP = RBTAB(IND0P8,IDR,1)




      ENDIF
*---------------------------------------------------------
*     Normal Event processing...
*     Check if old FPHC and FPLC banks exist. If so drop them...
      INDDUM =  MLINK(IW,'FPHC',NBN)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FPHC')
      ENDIF
      INDDUM =  MLINK(IW,'FPLC',NBN)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FPLC')
      ENDIF
      INDDUM =  MLINK(IW,'FTT0',NBN)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FTT0')
      ENDIF

*     Create FPHC bank...
      INDPHC   = NBANK('FPHC',NBN,2+2*NRFPHC)
      CALL VZERO(IW(INDPHC+1), 2+2*NRFPHC)
      IW(INDPHC+1) = NCFPHC
      IW(INDPHC+2) = NRFPHC

*     Get Event Time zero.
      TFTDC  = 0.0
*     CALL CEVT0(TFTDC, LTTYP)

* Apply correction for wrong bunch crossing
      CALL T0GET (ITRGT0)

      TZERO = TZER + TFTDC + 500.0*FLOAT(ITRGT0)


*
*     Access FRPE bank...
      IND  = IW(IQFRPE)
      IF(IND .EQ.0) THEN
*       FRPE bank not found. No data. Make 'zero=length FPLC...
        INDF = NBANK('FPLC',NBN,2)
        IW(INDF+1) = NCFPLC
        IW(INDF+2) = 0
        INDF = NBANK('FTT0',NBN,2)
        IW(INDF+1) = 2
        IW(INDF+2) = 0
         CALL BLIST(IW,'E+','FTT0')
        RETURN
      ENDIF

*     Copy B16 format bank to work bank
      INFRPE=0
      CALL BKTOW(IW,'FRPE',NBN,IW,INFRPE,*999)
*                                             error making w/bank

*     Determine number of hits in FRPE bank
      NFRPE = IW(INFRPE+2)
      IF(NFRPE.LE.0) THEN
*       There were no digis. Should have been no bank!
*       Make 'zero=length FPLC...
        INDF = NBANK('FPLC',NBN,2)
        IW(INDF+1) = NCFPLC
        IW(INDF+2) = 0
        CALL WDROP(IW,INFRPE)
        INDF = NBANK('FTT0',NBN,2)
        IW(INDF+1) = 2
        IW(INDF+2) = 0
         CALL BLIST(IW,'E+','FTT0')
        RETURN
      ENDIF

      IND1PA = IW(IQF1PA)

*     Extract Digitisations in planar chambers:-
      ICLOLD = -1

* Create banks
      IFPLC = NBANK('FPLC',NBN,2+NCFPLC*NFRPE)
      IF (IFPLC.LE.0) GOTO 997
      IW(IFPLC+1) = NCFPLC
      IW(IFPLC+2) = NFRPE

      JFIRST = 0
      JLAST  = 0
      TAVG   = 0.
      NTT    = 0
      DO 1  KDIG = 1, NFRPE
         ICLNUM=        IBTAB(INFRPE,1,KDIG)

         IF(ICLNUM .LT. 0 .OR. ICLNUM .GT. 1151) THEN
           GO TO 998
         ENDIF

* Fix for swapped channels in '95 data
         IF ((ICLNUM/128).EQ.5) THEN
            IWCELL = MOD(ICLNUM,128)/4
            IF (IWCELL.GE.20 .AND. IWCELL.LE.23) THEN
               IF (JFIRST.LE.0) JFIRST = KDIG
               JLAST = KDIG
            ENDIF
         ENDIF

*        Fill FPHC bank...
         IF(ICLNUM .NE. ICLOLD) THEN
           IW(INDPHC+ICLNUM*2 + 3) = 1
           IW(INDPHC+ICLNUM*2 + 4) = KDIG
           ICLOLD = ICLNUM
         ELSE
           IW(INDPHC+ICLNUM*2 + 3) = IW(INDPHC+ICLNUM*2 + 3) + 1
         ENDIF

*        Drift time in ticks...
         DTIME =  FLOAT(IBTAB(INFRPE,2,KDIG))
         CHARGE=  FLOAT(IBTAB(INFRPE,3,KDIG))

         IFLAG0=        IBTAB(INFRPE,4,KDIG)
         IFLAG1=        IBTAB(INFRPE,5,KDIG)
         IFLAG2=        IBTAB(INFRPE,6,KDIG)

*        Extract wire dependent constants for Channel ICLNUM...
         T0    = RBTAB(IND1PA,IT0   ,ICLNUM+1)
*
*        Compute drift distance...
*
*        Subtract Tzeros.
         TT    = DTIME - (TZERO + T0)
*
* Fine correction for T0 difference on inner/outer wires - real data only
*
         IF(.NOT.MONTE) THEN
            IF (MOD(ICLNUM,4).EQ.0 .OR. MOD(ICLNUM,4).EQ.3) THEN
               TT = TT - 0.48*500./96.
            ELSE
               TT = TT + 0.48*500./96.
            ENDIF
         ENDIF


         IF(TT.LT.TBMIN) THEN
           IBADT = 1
         ELSE
           IBADT = 0
           IF (TT.LT.5000.) THEN
              TAVG  = TAVG + TT
              NTT = NTT + 1
           ENDIF
         ENDIF

*        Apply time-to-distance function...
         IF(.NOT.MONTE) THEN
            DRIFT = FPLT2D(TT,  0.0, ICLNUM)
            DRIFTN= FPLT2D(TT,  1.0, ICLNUM)
            DRIFTF= FPLT2D(TT, -1.0, ICLNUM)
         ELSE
*        T-to-d for M/C...convert ticks to ns...
            TNS   = TT * 0.192
*           ...and microns to cms (v in microns/ns)
            DRIFT = TNS*VEL(1)*0.0001
*           ...and no asymmetry
            DRIFTN= DRIFT
            DRIFTF= DRIFT
         ENDIF

*        Is the wire near or far for +ve, -ve drift?
*        Get stagger of wire. Alternating sign but stagger of 1st
*        wire not same in all orientations...

         PSTG = PSTAGG(IPSMD(ICLNUM))  * ( (-1)**IPZPL(ICLNUM) )

         IF(PSTG .GT. 0.0) THEN
*          This means hits with +drift are near, -drift far...
           DRIFTP = DRIFTN
           DRIFTM = DRIFTF
         ELSE
*          Other way round...
           DRIFTP = DRIFTF
           DRIFTM = DRIFTN
         ENDIF


*        Histograms for monitoring... (factor 10 downscale)
         IF (MOD(NEVENT,10).EQ.0) THEN
            CALL SHS(109,0,DRIFT)
            CALL SHS(612,0,TT)
         ENDIF
         IF (NFRPE.GE.2000) CALL SHS(616,0,TT)

*        Determine errors. sig**2=e0**2 +d.e1**2 + e3**2.exp(-e4*d)
*        Drift is in cms. Error is converted back to cms.
         ISGNW  = 0
         IF(DRIFT .LT. DRMAX) THEN
           ERRDRF = ERRD0**2 +  DRIFT*ERRD1*ERRD1
     +                       +  ERRD2*ERRD2*EXP(-ERRD3*DRIFT)
           ERRDRF = SQRT(ERRDRF) / EMTOC
         ELSE
           ERRDRF = DRIFT-DRMAX
           ISGNW  = IOR(ISGNW,128)
         ENDIF

         IF(IFUNNY.NE.0) THEN
*        only react to flags if 'new model' Qt's...
         IF(IFLAG1 .NE.1) THEN

           IF(IFLAG2 .GT. IFUNNY) THEN
*             unpack rest of flags...
*             DOS sum of this hit...
              IDOS = IAND( IFLAG0,255)
*             Dist to prev hit...
*             ISPL = IAND( IFLAG1, 31)
              ISPL = ISHFT(IFLAG0, -8)
              ISPL = IAND( ISPL,  255)

*             Relinearised pedestal level...
              IPED = IAND( IFLAG1,255)
*             DOS sum of previous hit.
*             IDPR = IAND( IFLAG1, 31)
              IDPR = ISHFT(IFLAG1, -8)
              IDPR = IAND( IDPR,  255)

*             Dist from beginning of cluster...
              IDCS = IAND( IFLAG2,127)
*             Num adjacent bins above DOS threshold (leading edge)...
              LHIT = ISHFT(IFLAG2, -7)
              LHIT = IAND( LHIT, 15)
*             Number of previous hits in the cluster...
              INDX = ISHFT(IFLAG2,-11)
              INDX = IAND( INDX,   15)
*             React to flags here.
           ENDIF

         ENDIF

         ELSE
*        Old format flag in Monte Carlo, extract number of hits...
           IHITS =0
           IHITS = ISHFT(IFLAG2,-12)
           IHITS = IAND(IHITS,15)
           IF(IHITS .GT. 1) THEN
              ERRDRF = 2.0*ERRDRF
           ENDIF
         ENDIF
         IF(IBADT .EQ. 1) THEN
            ISGNW  = IOR(ISGNW,128)
         ENDIF

*        Fill row in output bank
         IAR(1) = ICLNUM
         BAR(2) = DRIFT
         BAR(3) = ERRDRF
         IAR(4) = ISGNW
         BAR(5) = CHARGE
         BAR(6) = DRIFTP
         BAR(7) = DRIFTM

C         IFPLC  = IADROW('FPLC',NBN,NCFPLC,BAR)
         CALL UCOPY(BAR,IW(INDCR(IFPLC,1,KDIG)),NCFPLC)
 1    CONTINUE

      IF (NTT.GT.0) THEN
         TAVG = TAVG/FLOAT(NTT)
      ELSE
         TAVG = -10000.
      ENDIF
      INFTT0 = NBANK('FTT0',0,4)
      IF (INFTT0.GT.0) THEN
         IW(INFTT0+1) = 2
         IW(INFTT0+2) = 1
         RW(INFTT0+3) = TAVG
         IW(INFTT0+4) = NTT
      ELSE
         CALL ERRLOG(113,'S:FPLOCO: Cant create FTT0 bank')
      ENDIF
      CALL BLIST(IW,'E+','FTT0')
      CALL SHS(650,0,TAVG)
      IF (NTT.LE.500) THEN
         CALL SHS(651,0,TAVG)
      ELSEIF (NTT.LE.2000) THEN
         CALL SHS(652,0,TAVG)
      ELSE
         CALL SHS(653,0,TAVG)
      ENDIF
      INCJCC = NLINK('CJCC',0)
      IF (INCJCC.GT.0 .AND. IW(INCJCC+2).GT.0) THEN
         CJCT0 = RBTAB(INCJCC,2,1)
         CALL SHS(654,0,TAVG-CJCT0)
         IF (NTT.LE.500) THEN
            CALL SHS(655,0,TAVG-CJCT0)
         ELSEIF (NTT.LE.2000) THEN
            CALL SHS(656,0,TAVG-CJCT0)
            CALL SHD(658,0,TAVG,CJCT0)
         ELSE
            CALL SHS(657,0,TAVG-CJCT0)
            CALL SHD(659,0,TAVG,CJCT0)
         ENDIF
      ENDIF

C      IFPLC  = IADFIN('FPLC',NBN)
      CALL WDROP(IW,INFRPE)

* Channels were swapped at least in '94 and '95, and probably through '96
      IF (MONTE .OR. NCCRUN.LT.70000) RETURN

* Fix for swapped channels in '95 data
      IF (JLAST.GT.0) CALL FPFIX(JFIRST,JLAST)

      RETURN

 998  CONTINUE
      CALL ERRLOG(114,'S:FPLOCO: Illegal Channel number!!')
      GOTO 996

 997  CONTINUE
      CALL ERRLOG(115,'S:FPLOCO: Cant create bank')

 996  CONTINUE
*     FPLC bank may be partially made. Finish it, drop it and
*     make empty version...
C      IFPLC  = IADFIN('FPLC',NBN)
      CALL BDROP(IW, 'FPLC')
      INDF = NBANK('FPLC',NBN,2)
      IW(INDF+1) = NCFPLC
      IW(INDF+2) = 0
      CALL WDROP(IW,INFRPE)
      CALL BDROP(IW, 'FTT0')
      INDF = NBANK('FTT0',NBN,2)
      IW(INDF+1) = 2
      IW(INDF+2) = 0
      CALL BLIST(IW,'E+','FTT0')
      RETURN

 999  CONTINUE
      CALL ERRLOG(105,'S:FPLOCO: Error in FRPE work bank creation')
      CALL WDROP(IW,INFRPE)
      RETURN

      END
*CMZ :  8.04/00 27/06/96  20.28.10  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.47  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.23  by  Stephen Burke
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTPDT
**: FPTPDT 40000 SM. New definition of dead wire flag.
**----------------------------------------------------------------------
**: FPTPDT 30907 RP. Farm changes.
**----------------------------------------------------------------------
*
*
*     Unpack Digitisations from bank FRPE.
*     Create intermediate bank FPLC containing local
*     coordinates
*
*     Store hits in IOS COMMONs for Pattern Recognition
*
*     Called once per event. Needs previous call to FTCORG
*     to create corrected geometry bank FPG1
*
*
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEND.
      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)
*     Max allowable bad hit flag...(To be gotten from bank sometime)
      PARAMETER(IFRBAD=128)

      PARAMETER(NBN=0)
*     Locators for FPG1 bank
      PARAMETER(IPDEAD=1)
      PARAMETER(IPPPHP=2)
      PARAMETER(IPPSTP=3)
*     Locators for FPLC bank
      PARAMETER(IPPCLN=1)
      PARAMETER(IPPDRF=2)
      PARAMETER(IPPERD=3)
      PARAMETER(IPPERF=4)

      LOGICAL FIRST
      DATA FIRST/.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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEEP,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEND.

*-------------------------------------------------------------------
      IF(FIRST) THEN
         FIRST  = .FALSE.
         IQFPG1 = NAMIND('FPG1')
         IQFPLC = NAMIND('FPLC')
      ENDIF

*
      IFPG1= IW(IQFPG1)
      IFPLC = IW(IQFPLC)

      IF(IFPG1.EQ.0) THEN
        CALL ERRLOG(106,'S:FPTPDT: FPG1 bank not found')
        RETURN
      ENDIF
      IF(IFPLC.EQ.0) THEN
        RETURN
      ENDIF
      NFPLC = IW(IFPLC+2)
      IF(NFPLC.LE.0) THEN
        RETURN
      ENDIF

*     Extract Hits...
      DO 300  K= 1, NFPLC

       ICLNUM=        IBTAB(IFPLC,IPPCLN,K)
       IDEAD =        LBTAB(IFPG1,IPDEAD,ICLNUM+1)
       IF(IDEAD .NE. 1) THEN

         DRIFT =        RBTAB(IFPLC,IPPDRF,K)
         ERRDRF=        RBTAB(IFPLC,IPPERD,K)
         ISGNW =        IBTAB(IFPLC,IPPERF,K)
         IF(ISGNW .LT. IFRBAD) THEN

*        IOS wire planes numbered 1-36 through 3 Modules
         KWIR   =  IPIOSW(ICLNUM)
*        increment number of hits in this wire plane...
         NDPW(KWIR)              =   NDPW(KWIR) + 1
         IF(NDPW(KWIR) .GT. MAXHTS) THEN
          CALL ERRLOG(102,'W:FPTPDT: MAX HITS exceeded ')
          NDPW(KWIR)              =   NDPW(KWIR) - 1
         ELSE
*         W-coordinate of wire...
*         W-coordinate of wire...
          DW ( NDPW(KWIR), KWIR)  =   SBTAB(IFPG1,IPPSTP,ICLNUM+1)
*         Phi of hit wire...
          WWP( NDPW(KWIR), KWIR)  =   SBTAB(IFPG1,IPPPHP,ICLNUM+1)
*         Drift in W, Error, flag...
          DRIW( NDPW(KWIR), KWIR)  =  DRIFT
          ERPDR( NDPW(KWIR), KWIR) =  ERRDRF
          IERPF( NDPW(KWIR), KWIR) =  ISGNW
*         W-cell number of this hit...
          KWCL = IPWCL(ICLNUM)
          IF(KWCL.LE.15)THEN
            NDW(NDPW(KWIR),KWIR) = KWCL
          ELSE
            NDW(NDPW(KWIR),KWIR) = KWCL-6
          ENDIF
*
          IF(KWCL.LE.15.AND.KWCL.GE.10)THEN
            IPHOLE(NDPW(KWIR),KWIR) = 1
          ELSE IF(KWCL.LE.21.AND.KWCL.GE.16)THEN
            IPHOLE(NDPW(KWIR),KWIR) = -1
          ELSE
            IPHOLE(NDPW(KWIR),KWIR) = 0
          ENDIF
*
*         relations between IOS labelling and FRRE bank...
          IPFRPE(NDPW(KWIR),KWIR)  =   K
          IF(K.LE.MAXDIG) THEN
           IPPIOS(K,1)             =   KWIR
           IPPIOS(K,2)             =   NDPW(KWIR)
          ENDIF

         ENDIF

         ENDIF
       ENDIF

 300  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.10  by  Stephen Burke
*CMZU:  4.01/01 10/12/93  15.51.51  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.47  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.23  by  Stephen Burke
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTRDT
*D: FPTRDT...... SM. New definition of dead wire flag. (Phase 2!)
**----------------------------------------------------------------------
**: FPTRDT 40000 SM. New definition of dead wire flag.
**----------------------------------------------------------------------
**: FPTRDT 30907 RP. Farm changes.
**----------------------------------------------------------------------
**: FPTRDT 30104 SM. reject bad hits flagged by FRLOCO.
**----------------------------------------------------------------------
*     Unpack Digitisations from bank FRRE.
*     Create intermediate bank FRLC containing local
*     coordinates
*
*     Store hits in IOS COMMONs for Pattern Recognition
*
*     Called once per event. Needs previous call to FTCORG
*     to create corrected geometry bank 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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEND.
      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)

*     Max allowable bad hit flag...(To be gotten from bank sometime)
      PARAMETER(IFRBAD=128)

      PARAMETER(NBN=0)
*     Locators for FRG1 bank
      PARAMETER(IPDEAD=1)
      PARAMETER(IPRPHP=2)
      PARAMETER(IPRSTP=3)
      PARAMETER(IPRPHM=5)
      PARAMETER(IPRSTM=6)
*     Locators for FRLC bank
      PARAMETER(IPRCLN=1)
      PARAMETER(IPRDRF=2)
      PARAMETER(IPRERD=3)
      PARAMETER(IPRRAD=4)
      PARAMETER(IPRERR=5)
      PARAMETER(IPRSGW=6)

      LOGICAL FIRST
      DATA FIRST/.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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEEP,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEND.
*
      IF(FIRST) THEN
         FIRST  = .FALSE.
         IQFRLC = NAMIND('FRLC')
         IQFRG1 = NAMIND('FRG1')
      ENDIF

*
      IFRLC = NLINK('FRLC',NBN)
      IFRG1= IW(IQFRG1)
      IF(IFRG1.EQ.0) THEN
        CALL ERRLOG(107,'S:FPTRDT: FRG1 bank not found')
        RETURN
      ENDIF
      IF(IFRLC.EQ.0) THEN
        RETURN
      ENDIF
      NFRLC = IW(IFRLC+2)
      IF(NFRLC.LE.0) THEN
        RETURN
      ENDIF

*     Extract Hits...
      DO 300  K= 1, NFRLC

        ICLNUM=        IBTAB(IFRLC,IPRCLN,K)
        IDEAD =        LBTAB(IFRG1,IPDEAD,ICLNUM+1)

*       Reject alleged hits from dead wires and hits marked bad
*       in FRLOCO...
        ISGNW =        IBTAB(IFRLC,IPRSGW,K)
        ISGTS =        MOD(ISGNW,2)
*       Is this end of the wire live?
        IF(IDEAD.NE.1 .AND. IDEAD.NE.(ISGTS+2))  THEN
        IF(ISGNW .LT. IFRBAD) THEN

         DRIFT =        RBTAB(IFRLC,IPRDRF,K)
         RADIUS=        RBTAB(IFRLC,IPRRAD,K)
         ERRDRF=        RBTAB(IFRLC,IPRERD,K)
         ERRRAD=        RBTAB(IFRLC,IPRERR,K)

         KWIR   =  IRIOSW(ICLNUM)
*        Increment number of hits in this wire plane...
         NDP(KWIR)              =   NDP(KWIR) + 1
*        Skip if maximum hits exceeded
         IF(NDP(KWIR) .GT. MAXHTS) THEN
          CALL ERRLOG(101,'W:FPTRDT: MAX HITS exceeded ')
          NDP(KWIR)              =   NDP(KWIR) - 1
         ELSE
          RM ( NDP(KWIR), KWIR)  =   RADIUS
          DRI( NDP(KWIR), KWIR)  =   DRIFT
          ERRRM( NDP(KWIR), KWIR)=   ERRRAD
          ERRDR( NDP(KWIR), KWIR)=   ERRDRF
          IERRF( NDP(KWIR), KWIR)=   ISGNW
*         Wedge number of this hit, Phi and stagger
*         of sense wire closest this hit.
          IF(MOD(ISGNW,2).EQ.0) THEN
            NW(NDP(KWIR),KWIR)     =   IRWPL(ICLNUM)+ 1
            WW(NDP(KWIR),KWIR)     =   SBTAB(IFRG1,IPRPHP,ICLNUM+1)
            DWS(NDP(KWIR), KWIR)   =   SBTAB(IFRG1,IPRSTP,ICLNUM+1)
          ELSE
            NW(NDP(KWIR),KWIR)     =   IRWMI(ICLNUM)+ 1
            WW(NDP(KWIR),KWIR)     =   SBTAB(IFRG1,IPRPHM,ICLNUM+1)
            DWS(NDP(KWIR), KWIR)   =   SBTAB(IFRG1,IPRSTM,ICLNUM+1)
          ENDIF
*         relations between IOS labelling and FRRE bank...
          IPFRRE(NDP(KWIR),KWIR)  =   K
          IF(K.LE.MAXDIG) THEN
           IRPIOS(K,1)            =   KWIR
           IRPIOS(K,2)            =   NDP(KWIR)
          ENDIF

         ENDIF

        ENDIF
        ENDIF
*      Next HIT...
 300  CONTINUE


      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.10  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.47  by  Stephen Burke
*CMZU:  2.05/01 21/06/91  15.03.37  by  Girish D. Patel
*-- Author : Stephen J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPWHIT(IROW,WWP,WWM,PHW,WWIR,ZZ,IBAD)
**: FPWHIT 40000 SM. New definition of dead wire flag.
**----------------------------------------------------------------------
*
*
*  PURPOSE: Compute W coordinate of a Planar Hit
*
*
*  INPUT : IROW    Row number in FRPE or FPLC bank
*
*
*  OUTPUT :  WWP       w    of hit assuming positive sign for drift
*         :  WWM       w    of hit assuming negative sign for drift
*         :  ZZ        z    of hit
*         :  IBAD      0 if digi O.K. 1 if digi 'unreliable'
*
*  NOTE  :   The routine uses 'local' coordinates (drift )
*            taken from the FPLC bank. If this temporary bank does not
*            exist, it is created. The local coordinate data is
*            combined with corrected geometrical data taken from
*            the bank FPG1. Again if FPG1 doesn't exist, it is created.
*
*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)
*     Locators for FPG1 bank
      PARAMETER(IPDEAD=1)
      PARAMETER(IPPWIR=2)
      PARAMETER(IPWWIR=3)
      PARAMETER(IPZWIR=4)
*     Locators for FPLC bank
      PARAMETER(IPCELN=1)
      PARAMETER(IPDRIF=2)

      LOGICAL FIRST
      DATA FIRST/.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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
*----------------------------------------------------------------------
*     Initialisations on first call...
      IF(FIRST) THEN
         FIRST  = .FALSE.
         IQFPLC = NAMIND('FPLC')
         IQFPG1 = NAMIND('FPG1')
      ENDIF
*-----------------------------------------------------------
      IBAD  = 1
      IFPG1 = IW(IQFPG1)
      IF(IFPG1.EQ.0) THEN
*       Create FPG1 bank...
        CALL FTCORG
        IFPG1 = IW(IQFPG1)
        IF(IFPG1.EQ.0) THEN
          WRITE(6,'('' FPWHIT : failure to create FPG1 bank'')')
          CALL H1STOP
        ENDIF
      ENDIF

      IFPLC = IW(IQFPLC)
      IF(IFPLC.EQ.0) THEN
*       Create FPLC bank...
        CALL FPLOCO
        IFPLC = IW(IQFPLC)
        IF(IFPLC.EQ.0) THEN
          WRITE(6,'('' FPWHIT : failure to create FPLC bank'')')
          CALL H1STOP
        ENDIF
      ENDIF

      NFPLC = IW(IFPLC+2)
      IF(NFPLC.LE.0) THEN
*       No data. Shouldn't happen if IROW valid.
        WRITE(6,'('' FPWHIT : No data. IROW not meaningful!!'')')
        RETURN
      ENDIF

      IF(IROW.LT.0 .OR. IROW .GT. NFPLC) THEN
        WRITE(6,'('' FPWHIT : IROW out of range!!'')')
        RETURN
      ENDIF

*     Normal processing starts here...

      ICLNUM=        IBTAB(IFPLC,IPCELN,IROW)
      IDEAD =        IBTAB(IFPG1,IPDEAD,ICLNUM+1)
      IF(IDEAD .NE. 1) THEN
        IBAD  =  0
        DRIFT =        RBTAB(IFPLC,IPDRIF,IROW)

*       Phi, W and Z of wire
        PHW         =  RBTAB(IFPG1,IPPWIR,ICLNUM+1)
        WWIR        =  RBTAB(IFPG1,IPWWIR,ICLNUM+1)
        ZZ          =  RBTAB(IFPG1,IPZWIR,ICLNUM+1)

        WWP     =  DRIFT + WWIR
        WWM     = -DRIFT + WWIR

      ELSE

        PHW     = 0.0
        WWIR    = 0.0
        WWP     = 0.0
        WWM     = 0.0
        ZZ      = 0.0

      ENDIF

*     Done
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.10  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.50  by  Stephen Burke
*CMZU:  3.03/06 01/06/92  10.37.35  by  Stephen J. Maxfield
*-- Author :    STEPHEN J. MAXFIELD   05/04/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRCART(IROW,XXP,YYP,XXM,YYM,ZZ,IBAD)
**: FRCART 40000 SM. New definition of dead wire flag.
**----------------------------------------------------------------------
*
*
*  PURPOSE: Compute X,Y,Z of a digitisation.
*
*
*  INPUT : IROW    Row number in FRRE or FRLC bank
*
*
*  OUTPUT :  XXP,YYP   x, y of hit assuming positive sign for drift
*         :  XXM,YYM   x, y of hit assuming negative sign for drift
*         :  ZZ        z    of hit
*         :  IBAD      0 if digi O.K. 1 if digi 'unreliable'
*
*  NOTE  :   The routine uses 'local' coordinates (drift and radius)
*            taken from the FRLC bank. If this temporary bank does not
*            exist, it is created. The local coordinate data is
*            combined with corrected geometrical data taken from
*            the bank FRG1. Again if FRG1 doesn't exist, it is created.
*
*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)
*     Locators for FRG1 bank
      PARAMETER(IPDEAD=1)
      PARAMETER(IPRPHP=2)
      PARAMETER(IPRSTP=3)
      PARAMETER(IPRPHM=5)
      PARAMETER(IPRSTM=6)
*     Locators for FRLC bank
      PARAMETER(IPRCLN=1)
      PARAMETER(IPRDRF=2)
      PARAMETER(IPRRAD=4)
      PARAMETER(IPRSGW=6)

      LOGICAL FIRST
      DATA FIRST/.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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
*----------------------------------------------------------------------
*     Initialisations on first call...
      IF(FIRST) THEN
         FIRST  = .FALSE.
         IQFRLC = NAMIND('FRLC')
         IQFRG1 = NAMIND('FRG1')
      ENDIF
*-----------------------------------------------------------
      IBAD  = 1
      IFRG1 = IW(IQFRG1)
      IF(IFRG1.EQ.0) THEN
*       Create FRLC bank...
        CALL FTCORG
        IFRG1 = IW(IQFRG1)
        IF(IFRG1.EQ.0) THEN
          WRITE(6,'('' FRCART : failure to create FRG1 bank'')')
          CALL H1STOP
        ENDIF
      ENDIF

      IFRLC = IW(IQFRLC)
      IF(IFRLC.EQ.0) THEN
*       Create FRLC bank...
        CALL FRLOCO
        IFRLC = IW(IQFRLC)
        IF(IFRLC.EQ.0) THEN
          WRITE(6,'('' FRCART : failure to create FRLC bank'')')
          CALL H1STOP
        ENDIF
      ENDIF

      NFRLC = IW(IFRLC+2)
      IF(NFRLC.LE.0) THEN
*       No data. Shouldn't happen if IROW valid.
        CALL ERRLOG(116,'S:FRCART : IROW not meaningful!')
        RETURN
      ENDIF

      IF(IROW.LT.0 .OR. IROW .GT. NFRLC) THEN
        CALL ERRLOG(117,'S:FRCART : IROW out of range!')
        RETURN
      ENDIF

*     Normal processing starts here...

      ICLNUM=        IBTAB(IFRLC,IPRCLN,IROW)
      IDEAD =        IBTAB(IFRG1,IPDEAD,ICLNUM+1)
      IF(IDEAD .NE. 1) THEN
        IBAD  =  0
        DRIFT =        RBTAB(IFRLC,IPRDRF,IROW)
        RADIUS=        RBTAB(IFRLC,IPRRAD,IROW)
        ISGNW =    MOD(IBTAB(IFRLC,IPRSGW,IROW),2)

*       Phi, Stagger and Z of wire
        PHI         =  RBTAB(IFRG1,2+3*ISGNW,ICLNUM+1)
        STAGGR      =  RBTAB(IFRG1,3+3*ISGNW,ICLNUM+1)
        ZZ          =  RBTAB(IFRG1,4+3*ISGNW,ICLNUM+1)

        DSIGN   =  1.
        DDD     =  DRIFT*DSIGN + STAGGR
        RR      =  RADIUS + FLOREN(RADIUS,ABS(DDD),DSIGN)
        XXP     =  RR*COS(PHI) - DDD*SIN(PHI)
        YYP     =  RR*SIN(PHI) + DDD*COS(PHI)

        DSIGN   = -1.
        DDD     =  DRIFT*DSIGN + STAGGR
        RR      =  RADIUS + FLOREN(RADIUS,ABS(DDD),DSIGN)
        XXM     =  RR*COS(PHI) - DDD*SIN(PHI)
        YYM     =  RR*SIN(PHI) + DDD*COS(PHI)

      ELSE

        XXP     = 0.0
        YYP     = 0.0
        XXM     = 0.0
        YYM     = 0.0
        ZZ      = 0.0

      ENDIF

*     Done
      RETURN
      END
*CMZ :  8.07/00 20/11/96  17.54.32  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.10  by  Stephen Burke
*CMZU:  8.03/00 17/06/96  14.45.04  by  Katharina Mueller
*CMZU:  5.03/00 20/10/94  15.40.25  by  Stephen Burke
*CMZ :  4.00/08 02/12/93  21.42.15  by  Gregorio Bernardi
*CMZ :  4.00/00 07/09/93  17.57.50  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.23  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   01/03/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRLOCO
**: FRLOCO.......SM. Introduce asymmetry and wire-plane velocity
**: FRLOCO.......SM. factors. New parameters ex FCR3 bank.
**----------------------------------------------------------------------
**: FRLOCO.......SB. Correct for trigger in wrong bunch crossings.
**----------------------------------------------------------------------
**: FRLOCO 40000 SM. Make new temporary bank FAUX.
**----------------------------------------------------------------------
**: FRLOCO 30907 RP. Farm changes.
**----------------------------------------------------------------------
**: FRLOCO 30907 SM. Improved drift and radius error determination.
**: FRLOCO 30907 SM. Explicitly drop FRLC FRHC banks.
**----------------------------------------------------------------------
**: FRLOCO 30207 GB. comment lines moved inside the routine
**: FRLOCO 30205 SM. Modifications for Filter farm.
**----------------------------------------------------------------------
*     Calculate LOCAL COORDINATES of digitisations in the Radial
*     Drift Chambers from contents of FRRE bank and database.
*     The drift distance and radius of the impact
*     point on the wire are computed and corrected as described
*     in the in-line comments below.
*     The following effects are NOT corrected for here:
*         * Geometrical displacements and distortions
*         * Lorentz angle
*         * Track angle effects
*     However, the Lorentz angle and the quantity DR (needed for
*     applying corrections to the drift for the track angle) are
*     obtained from the F0R8 bank and placed in COMMON ..... for
*     subsequent use.
*     A temporary bank is created, FRLC containing the results.
*     This bank is parallel to the FRRE bank. It is a named bank but
*     is not put on the E-list:
*
*!       BANKname BANKtype      ! Comments
* TABLE  FRLC                   ! Local coordinates and data for hits
*                               ! in Radial Drift Chambers.
*                               ! TEMPORARY. Parallel to FRRE bank.
*!   ATTributes:
*!   -----------
*!COL ATT-name FMT Min    Max   ! Comments
*!
*  1  ICLNUM   I                !  Drift cell number
*  2  DRIFTS   F                !  Abs drift distance (cms)
*  3  ERRDRF   F                !  Error in  drift distance (cms)
*  4  RADIUS   F                !  Radius of impact point (cms)
*  5  ERRRAD   F                !  Error in Radius  (cms)
*  6  ISGNW    I                !  Bit 0:   0=+wedge 1=-wedge
*                               !  Bit 1:   0=OK QT  1=dubious radius
*                               !  Bit 2:   0=OK     1=dubious drift
*                               !  Bit 3:   0=OK     1=timing pulse?
*                               !  Bit 7:   0=OK     1=on no account
*                               !                      use this hit!
*                               !  Note that MOD(ISGNW,2) always
*                               !  gives 0 for +wedge, 1 for -wedge
*                               !  ISGNW > 1 indicates poss problems
*  7  QPLUS   F                 !  Charge integral + end of wire
*  8  QMINUS  F                 !  Charge integral - end of wire
*!
* END TABLE
*     NOTES:
*  1) The drift error is parameterised as a function of drift
*     distance.
*  2) If there was a close preceding hit or long leading edge,
*     the drift resolution is degraded and Bit 2 in ISGNW set.
*  3) If the integration interval is short or close preceding
*     hit, or saturation the radial coordinate error is degraded
*     and Bit 1 in ISGNW is set.
*  4) Possible timing pulses are flagged by setting Bit 3 in ISGNW.
*  5) Bit 7 is set if the pulse had insane drift times or zero
*     measured charge. Such pulses should never be used.
*
*     Reject hit if ISGNW > 127
*
*
*
*!       BANKname BANKtype      ! Comments
* TABLE  FRHC                   ! Map showing number of hits in each
*                               ! Cell. Row number = Cell number + 1
*                               ! TEMPORARY.
*!   ATTributes:
*!   -----------
*!COL ATT-name FMT Min    Max   ! Comments
*!
*  1  NHITS    I                !  Number of hits in Drift cell
*  2  IFRRE    I                !  Pointer to 1st hit in FRRE/FRLC
*!
*======================================================================
*     bank number forvarious banks.
      PARAMETER(NBN=0)
      PARAMETER(NCFRLC=10)

      PARAMETER(NCFRHC=2)
      PARAMETER(NRFRHC=864)
      PARAMETER(NCFAUX=1)

*     Locators for stuff in F0R8 bank (overall constants)
      PARAMETER(ITZER=1)
      PARAMETER(IVDRF=4)
      PARAMETER(ID0=5)
      PARAMETER(ID1=6)
      PARAMETER(ID2=7)
      PARAMETER(IC0=8)
      PARAMETER(IC1=9)
      PARAMETER(IDR=10)
      PARAMETER(IALOR=11)
      PARAMETER(IXI=12)

*     Locators for stuff in FCR3 bank (t-to-d and error parameters)
*     (This bank replaces the old FCR1 bank)
      PARAMETER(IPKNOT=1)
      PARAMETER(IPKPAR=2)

*     Locators for stuff in FCR2 bank (resolution parameters)
      PARAMETER(IFCED0=2)
      PARAMETER(IFCED1=3)
      PARAMETER(IFCED2=4)
      PARAMETER(IFCED3=5)

      PARAMETER(IFCER0=6)
      PARAMETER(IFCER1=7)
      PARAMETER(IFCER2=8)
      PARAMETER(IFCER3=9)
      PARAMETER(IFUN=10)

*     Locators for stuff in F1RA bank (wire-by-wire constants)
      PARAMETER(IT0=1)
      PARAMETER(IDELD=2)
      PARAMETER(IDELT=3)
      PARAMETER(IRELG=4)
      PARAMETER(IGPRO=5)
      PARAMETER(ILEFOL=6)

*     Locators for stuff in F1RB bank (wire-by-wire constants)
      PARAMETER(IRPLUS=1)
      PARAMETER(IRMINU=2)
      PARAMETER(IRESPL=3)
      PARAMETER(IRESMI=4)
      PARAMETER(IRMNPL=5)
      PARAMETER(IRMNMI=6)

*     tan 1/2 wedge angle
      PARAMETER(TANWED=0.065543463)
*     microns -> cms
      PARAMETER(EMTOC=10000.)
*     Scale factor for drift time...
      PARAMETER(TSFAC=0.00079)

*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,FWINDS.
*     Work bank indices...
      COMMON/FWINDS/ INFRRE, INFRPE, ILWPG1, ILWRG1
*KEND.

*     Local arrays, variables.
      DIMENSION BAR(NCFRLC),   IAR(NCFRLC)
      EQUIVALENCE(BAR(1), IAR(1))

      PARAMETER  (NNKNOT=2)
      DIMENSION  VDR(NNKNOT), SKN(NNKNOT), BETA(NNKNOT)
      DIMENSION  SKNC0(NNKNOT), SKNC1(NNKNOT), SKNC2(NNKNOT)

      DIMENSION  V0S(36)
      DIMENSION  V1S(36)
      DIMENSION  V0F(36)
      DIMENSION  V1F(36)
      DIMENSION  V0N(36)
      DIMENSION  V1N(36)

      LOGICAL FIRST
      LOGICAL LTIMPL
*     Statement function true if Channel might have time-stamp pulse
      LTIMPL(ICELL) = MOD(ICELL,96).LT.7 .AND.
     +            MOD(MOD(ICELL,96),2).EQ.0
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
      DATA    FIRST/.TRUE./
      DATA NEGRUN /-1/

*     Initialisation of bank pointers on first call...
      IF(FIRST) THEN
         FIRST  =  .FALSE.
*
         IQFRRE = NAMIND('FRRE')
         IQFTDC = NAMIND('FTDC')
         IQF0R8 = NAMIND('F0R8')
         IQFGAR = NAMIND('FGAR')
         IQF1RA = NAMIND('F1RA')
         IQF1RB = NAMIND('F1RB')
         IQFCR3 = NAMIND('FCR3')
         IQFCR2 = NAMIND('FCR2')

         CALL BKFMT('FRLC','2I,(I,4F,I,4F)')
         CALL BKFMT('FRHC','2I,(2I)')
         CALL BKFMT('FAUX','2I,(I)')

      ENDIF
*
*
      IF(BEGRUN .OR. NCCRUN .NE.NEGRUN) THEN
          NEGRUN  = NCCRUN
*
*       New run. Hit database for run-dependent banks.
*
        CALL UGTBNK('F0R8',IND)
        CALL UGTBNK('FGAR',IND)
        CALL UGTBNK('FCR3',IND)
        CALL UGTBNK('FCR2',IND)
        CALL UGTBNK('F1RA',IND)
        CALL UGTBNK('F1RB',IND)

*       Extract needed overall constants...
        IND0R8 = IW(IQF0R8)
        TZER   =     RBTAB(IND0R8,ITZER,1)
        VDRFT  =     RBTAB(IND0R8,IVDRF,1)
        D0     =     RBTAB(IND0R8,ID0,1)
        D1     =     RBTAB(IND0R8,ID1,1)
        D2     =     RBTAB(IND0R8,ID2,1)
        C0     =     RBTAB(IND0R8,IC0,1)
        C1     =     RBTAB(IND0R8,IC1,1)
        ATLORR = TAN(RBTAB(IND0R8,IALOR,1))
        DTANGR =     RBTAB(IND0R8,IDR,1)
        XI     =     RBTAB(IND0R8,IXI,1)

*       Parameters for time-to-distance relation...
        INDGAR = IW(IQFGAR)

*       The (nominal) geometric stagger...
        SSTAG  =     RW(INDGAR+ 6)
        STAG   =     ABS(SSTAG)

*       Number of velocity parameter sets...
        INDCR3 = IW(IQFCR3)

        KNOT   =     IBTAB(INDCR3, IPKNOT, 1)
        KPAR   =     IBTAB(INDCR3, IPKPAR, 1)

*       Velocities, knot points, asymmetry corrections etc.
        Do JK = 1, KNOT
         IPT = 2 + (JK-1)*KPAR
*        drift velocity at JK'th knot...
         VDR(JK)     =     RBTAB(INDCR3, IPT + 1, 1)
         SKN(JK)     =     RBTAB(INDCR3, IPT + 2, 1)
*        Asymmetry factor at JK'th knot...
         BETA(JK)    =     RBTAB(INDCR3, IPT + 3 , 1)
*        quadratic correction to S at JK'th knot...
         SKNC0(JK)   =     RBTAB(INDCR3, IPT + 4, 1)
         SKNC1(JK)   =     RBTAB(INDCR3, IPT + 5, 1)
         SKNC2(JK)   =     RBTAB(INDCR3, IPT + 6, 1)
        Enddo

*       Wire dependent scale factors for drift velocities...
*       Apply wire dependent scale factors.
*       Apply near far asymmetries.
*       (Beta > 0  => Vfar > Vnear  (opposite to planars?))
        IPT = IPT + KPAR
        Do JWIRE = 1, 36
*       'symmetrised'
         V0S(JWIRE) = VDR(1)*RBTAB(INDCR3, IPT + JWIRE, 1)
         V1S(JWIRE) = VDR(2)*RBTAB(INDCR3, IPT + JWIRE, 1)
*       'far wires'
         V0F(JWIRE) = V0S(JWIRE)*(1.0 + BETA(1))
         V1F(JWIRE) = V1S(JWIRE)*(1.0 + BETA(2))
*       'near wires'
         V0N(JWIRE) = V0S(JWIRE)*(1.0 - BETA(1))
         V1N(JWIRE) = V1S(JWIRE)*(1.0 - BETA(2))
        Enddo

        IPT = IPT + 36
*       Min allowed drift time and Tol on max allowed drift
        TBMIN  =     RBTAB(INDCR3, IPT + 2, 1)
        DELMAX =     RBTAB(INDCR3, IPT + 3, 1)

*       Numbers for drift-error parameterisation...
        INDCR2 = IW(IQFCR2)
        ERRD0  =     RBTAB(INDCR2, IFCED0, 1)
        ERRD1  =     RBTAB(INDCR2, IFCED1, 1)
        ERRD2  =     RBTAB(INDCR2, IFCED2, 1)
        ERRD3  =     RBTAB(INDCR2, IFCED3, 1)

*       Numbers for radius-error parameterisation...
        ERRR0  =     RBTAB(INDCR2, IFCER0, 1)
        ERRR1  =     RBTAB(INDCR2, IFCER1, 1)
        ERRRM  =     RBTAB(INDCR2, IFCER2, 1)
        FQFAC  =     RBTAB(INDCR2, IFCER3, 1)
        IFUNNY =     IBTAB(INDCR2, IFUN,   1)




      ENDIF
**----------------------------------------------------------------------
*     Normal Event processing...

*     Check if old FRHC and FRLC banks exist. If so drop them...
*     (to allow proper re-processing of event in DISPLAY).
      INDDUM =  MLINK(IW,'FRHC',NBN)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FRHC')
      ENDIF
      INDDUM =  MLINK(IW,'FRLC',NBN)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FRLC')
      ENDIF
      INDDUM =  MLINK(IW,'FAUX',NBN)
      IF(INDDUM.NE.0) THEN
         CALL BDROP(IW,'FAUX')
      ENDIF

*     Create FRHC bank...
      INDRHC   = NBANK('FRHC',NBN,2+2*NRFRHC)
      CALL VZERO(IW(INDRHC+1), 2+2*NRFRHC)
      IW(INDRHC+1) = NCFRHC
      IW(INDRHC+2) = NRFRHC
      TFTDC  = 0.0
**
*     Get Event Time zero. To be done!
*     CALL CEVT0(TFTDC, LTTYP)
*+SELF,IF=FTTUNE.
*        CJC TDC time...
*        CALL SHS(615,0,TFTDC)
*+SELF.
**

* Apply correction for wrong bunch crossing
      CALL T0GET (ITRGT0)

      TZERO = TZER + TFTDC + 500.0*FLOAT(ITRGT0)
*
*     Access FRRE bank...
      IND  = IW(IQFRRE)
      IF(IND .EQ.0) THEN
*       FRRE bank not found. No data. Make 'zero-length' bank...
        INDF = NBANK('FRLC',NBN,2)
        IW(INDF+1) = NCFRLC
        IW(INDF+2) = 0
        RETURN
      ENDIF

*     Copy B16 format bank to work bank
      INFRRE=0
      CALL BKTOW(IW,'FRRE',NBN,IW,INFRRE,*999)
*                                          |- error making w/bank

*     Determine number of hits in FRRE bank
      NFRRE = IW(INFRRE+2)
      IF(NFRRE.LE.0) THEN
*       There were no digis. Should have been no bank! Make 'zero-
*       length' FRLC bank...
        INDF = NBANK('FRLC',NBN,2)
        IW(INDF+1) = NCFRLC
        IW(INDF+2) = 0
        INDA = NBANK('FAUX',NBN,2)
        IW(INDA+1) = NCFAUX
        IW(INDA+2) = 0
        CALL WDROP(IW,INFRRE)
        RETURN
      ENDIF

      IND1RA = IW(IQF1RA)
      IND1RB = IW(IQF1RB)

*     Extract Digitisations in radial chambers:-
      ICLOLD = -1

* Create banks
      IFRLC = NBANK('FRLC',NBN,2+NCFRLC*NFRRE)
      IF (IFRLC.LE.0) GOTO 997
      IW(IFRLC+1) = NCFRLC
      IW(IFRLC+2) = NFRRE
      IFAUX = NBANK('FAUX',NBN,2+NCFAUX*NFRRE)
      IF (IFAUX.LE.0) GOTO 997
      IW(IFAUX+1) = NCFAUX
      IW(IFAUX+2) = NFRRE

      DO 1  KDIG = 1, NFRRE

*        Check legal cell...
         ICLNUM=        IBTAB(INFRRE,1,KDIG)
         IF(ICLNUM .LT. 0 .OR. ICLNUM .GT. 863) THEN
           GO TO 998
         ENDIF

*        Fill FRHC bank...
         IF(ICLNUM .NE. ICLOLD) THEN
           IW(INDRHC+ICLNUM*2 + 3) = 1
           IW(INDRHC+ICLNUM*2 + 4) = KDIG
           ICLOLD = ICLNUM
         ELSE
           IW(INDRHC+ICLNUM*2 + 3) = IW(INDRHC+ICLNUM*2 + 3) + 1
         ENDIF

*        Extract wire dependent constants for Channel ICLNUM...
         T0    = RBTAB(IND1RA,IT0   ,ICLNUM+1)
         DELD  = RBTAB(IND1RA,IDELD ,ICLNUM+1)
         DELT  = RBTAB(IND1RA,IDELT ,ICLNUM+1)
         RELG  = RBTAB(IND1RA,IRELG ,ICLNUM+1)
         ELEFOL= RBTAB(IND1RA,ILEFOL,ICLNUM+1)

         RPLUS = RBTAB(IND1RB,IRPLUS,ICLNUM+1)
         RMINUS= RBTAB(IND1RB,IRMINU,ICLNUM+1)
         RESPLU= RBTAB(IND1RB,IRESPL,ICLNUM+1)
         RESMIN= RBTAB(IND1RB,IRESMI,ICLNUM+1)
         RMINPL= RBTAB(IND1RB,IRMNPL,ICLNUM+1)
         RMINMI= RBTAB(IND1RB,IRMNMI,ICLNUM+1)


*        Basic hit data...
         DTIME =  FLOAT(IBTAB(INFRRE,2,KDIG))
         QPLUS =  FLOAT(IBTAB(INFRRE,3,KDIG))
         QMINUS=  FLOAT(IBTAB(INFRRE,4,KDIG))
         IFLAG1=        IBTAB(INFRRE,5,KDIG)
         IFLAG2=        IBTAB(INFRRE,6,KDIG)

*
*======= Determine radial coordinate by charge divison ===============
*

*        Determine alpha. Needed for correction to Drift time
*        as well as for radial coordinate. Flag bad charges.
         DENOM = QPLUS + RELG*QMINUS
         IF (DENOM .GT. 0.0) THEN
            ALP   =(QPLUS - RELG*QMINUS) / DENOM
            IBADQ = 0
         ELSE
            CALL ERRLOG(103, 'W:FRLOCO: Zero charge digi found')
            ALP = 0.0
            IBADQ = 1
         ENDIF

         SIGMA = (RPLUS + RMINUS)*ELEFOL
         DELTA =  RPLUS- RMINUS

         RPL     =  +  (SIGMA*ALP+DELTA)/(2.*RESPLU)
         RPM     =  -  (SIGMA*ALP+DELTA)/(2.*RESMIN)

*        Choose valid solution, add inner radius and apply
*        chg-div distortion correction (linear part only for now)
         IF(RPL .GE. 0.0) THEN
            RADIUS = RPL*(1.0 + XI) + RMINPL
            RAD = RPL + RMINPL
            ISGNW  = 0
         ELSE
            RADIUS = RPM*(1.0 + XI) + RMINMI
            RAD = RPM + RMINMI
            ISGNW  = 1
         ENDIF

**
*        Make systematic correction to radius...
*        IINT = IAND(IFLAG1,31)
*        RADIUS =  FRDSYS(RAD,IINT)
**

*
*======= Compute drift distance =======================================
*
*        Correct drift time by wire-dependent T0 and for radius...
         TT    = DTIME - (TZERO + T0 + 0.5*ALP*(DELD - ALP*DELT))
*        Flag 'premature' hits...
         IF(TT.LT.TBMIN) THEN
           IBADT = 1
         ELSE
           IBADT = 0
         ENDIF


*        Scaled drift time (-> approx drift distance in cms)
         TS  = TT*VDRFT
         TSCAL = TT*TSFAC
*
*        Apply Time-to-distance relation
*
*        Allow for possibly different t-to-d treatment in Monte Carlo
         IF(MONTE) THEN

*         No t-to-d for M/C at moment...
          DRIFTS= TS
          DRIFTP= TS
          DRIFTM= TS

         ELSE

*         Radius-dependent location of first knot...
          S1R=  SKN(2) + SKNC0(2)
     +                 + SKNC1(2)*RADIUS + SKNC2(2)*RADIUS*RADIUS
*
          IWIR = IRIOSW(ICLNUM)
          S1  = S1R
*         Velocities and knots for symmetric stuff...
          V0  = V0S(IWIR)
          V1  = V1S(IWIR)
*          S1  = S1R
          DRIFTS = FRDT2D(TS, V0, V1, S1)

*         Velocities and knots for far wires...
          V0  = V0F(IWIR)
          V1  = V1F(IWIR)
*          S1  = S1R + STAG
          DRIFTF = FRDT2D(TS, V0, V1, S1)

*         Velocities and knots for near wires...
          V0  = V0N(IWIR)
          V1  = V1N(IWIR)
*          S1  = S1R - STAG
          DRIFTN = FRDT2D(TS, V0, V1, S1)

*         Assign near/far values to plus/minus drift...
          SS   = SSTAG*( (-1)**(IWIR-1) )
          IF(SS .GT. 0.) THEN
           DRIFTP = DRIFTN
           DRIFTM = DRIFTF
          ELSE
           DRIFTP = DRIFTF
           DRIFTM = DRIFTN
          ENDIF



         ENDIF


*
*        Make estimations of measurement errors.
*        Establish 'core' errors then react to pulse shape
*        information in flags to degrade these further.
*
*        a) 'Core' errors...
*
*     >  Drift errors. sig**2=e0**2 +d.e1**2 + e2**2.exp(-e3*d)
*        Max allowed drift at radius of hit + a tolerance.
*
         DRFMAX = RADIUS*TANWED + DELMAX

         IF(DRIFTS .LT. DRFMAX) THEN
           ERRDRF = ERRD0**2 +  DRIFTS*ERRD1*ERRD1
     +                       +  ERRD2*ERRD2*EXP(-ERRD3*DRIFTS)
           ERRDRF = SQRT(ERRDRF) / EMTOC
         ELSE
           ERRDRF = DRIFTS-DRFMAX
           ISGNW  = IOR(ISGNW, 128)
         ENDIF

*
*     >  Radial coordinate error as function of total charge integral
         QTOTSC = (QPLUS + QMINUS) / FQFAC
         IF (QTOTSC.GT.0.) THEN
            ERRRAD = MIN(ERRR0 + (ERRR1 / QTOTSC), ERRRM)
         ELSE
            ERRRAD = ERRRM
         ENDIF

*                  ELSE
*
*                  ENDIF



*        React to flags. Note that 'old' M/C has different flag
*        Structure. This is indicated by a zero value for IFUNNY.
         IF(IFUNNY.NE.0) THEN
*          we have data or 'new' M/C
*          FLAG 2 > IFUNNY indicates possible problems with Qt...

           IF(IFLAG2 .GT. IFUNNY) THEN
*             unpack rest of flags...
              IINT = IAND(IFLAG1,31)
              INDX = ISHFT(IFLAG1,-5)
              INDX = IAND(INDX,7)

              MAXR = IAND(IFLAG2,15)
              JUNK = ISHFT(IFLAG2,-4)
              ISPL = IAND(JUNK,15)
              JUNK = ISHFT(JUNK,-4)
              LHIT = IAND(JUNK,15)

*     >     If there was a close preceding hit or long leading edge,
*           degrade the DRIFT resolution...
              IF(ISPL.LT.15 .OR. LHIT .GT. 3) THEN
                ERRDRF = 2.0*ERRDRF
                ISGNW  = IOR(ISGNW, 4)
              ENDIF

*     >     If the integration interval is short or close preceding
*           hit, or saturation degrade the RADIUS coordinate error...
*             IF(IINT.LT.12 .OR. ISPL.LT.15 .OR. MAXR.GT.0) THEN
*               ERRRAD = 2.0*ERRRAD
*               ISGNW  = IOR(ISGNW, 2)
*             ENDIF

           ENDIF

         ELSE

*        Old format flag in Monte Carlo, extract number of hits...
           IHITS =0
           IHITS = ISHFT(IFLAG2,-12)
           IHITS = IAND(IHITS,15)
           IF(IHITS .GT. 1) THEN
              ERRDRF = 2.0*ERRDRF
*             ERRRAD = 2.0*ERRRAD
              ISGNW  = IOR(ISGNW, 6)
           ENDIF

         ENDIF


*
*        Flag the Really awful hits...(no charge or too early)
         IF(IBADQ .EQ. 1) THEN
            ERRDRF = 2.0*ERRDRF
*           ERRRAD = 2.0*ERRRAD
            ISGNW  = IOR(ISGNW,128)
         ENDIF
         IF(IBADT .EQ. 1) THEN
            ERRDRF = 2.0*ERRDRF
*           ERRRAD = 2.0*ERRRAD
            ISGNW  = IOR(ISGNW,128)
         ENDIF

*        Set flag to indicate potentential time-stamp pulse:
*        Celnum must be one that could have T-p injected:-
         IF(LTIMPL(ICLNUM)) THEN
*          ...and have large '-ve' radius...
           IF(MOD(ISGNW,2) .EQ. 1  .AND. RADIUS .GT. 75.0) THEN
              ERRDRF = 2.0*ERRDRF
*             ERRRAD = 2.0*ERRRAD
              ISGNW = IOR(ISGNW, 8)
           ENDIF
         ENDIF

*        Fill row in output bank
         IAR(1)  = ICLNUM
         BAR(2)  = DRIFTS
         BAR(3)  = ERRDRF
         BAR(4)  = RADIUS
         BAR(5)  = ERRRAD
         IAR(6)  = ISGNW
         BAR(7)  = QPLUS
         BAR(8)  = QMINUS
         BAR(9)  = DRIFTP
         BAR(10) = DRIFTM

C         IFRLC  = IADROW('FRLC',NBN,NCFRLC,BAR)
         CALL UCOPY(BAR,IW(INDCR(IFRLC,1,KDIG)),NCFRLC)

*        Quantities for auxilliary bank FAUX
         BAR(1)= TSCAL
C         IFAUX  = IADROW('FAUX',NBN,NCFAUX,BAR)
         CALL UCOPY(BAR,IW(INDCR(IFAUX,1,KDIG)),NCFAUX)

*        Histograms for monitoring... (factor 10 downscale)
         IF (MOD(NEVENT,10).EQ.0) THEN
            CALL SHS(108,0,DRIFTS)
            CALL SHS(610,0,TT)
         ENDIF
         IF(IDOHIS .GE. 2) THEN
           FSIG = FLOAT(ISGNW)
           CALL SHS(114,0,FSIG)
           CALL SHS(115,0,RADIUS)

           CALL SHS(257,0,QSUM)
         ENDIF

 1    CONTINUE

C      IFRLC  = IADFIN('FRLC',NBN)
C      IFAUX  = IADFIN('FAUX',NBN)
      CALL WDROP(IW,INFRRE)

      RETURN

 998  CONTINUE
      CALL ERRLOG(114,'S:FRLOCO: Illegal Channel number!!')
      GOTO 996

 997  CONTINUE
      CALL ERRLOG(114,'S:FRLOCO: Cant create bank')

 996  CONTINUE
*     FRLC may be partially made. Finish it drop it and recreate
*     empty version...
C      IFRLC  = IADFIN('FRLC',NBN)
      CALL BDROP(IW,'FRLC')
      INDF = NBANK('FRLC',NBN,2)
      IW(INDF+1) = NCFRLC
      IW(INDF+2) = 0

C      IFAUX  = IADFIN('FAUX',NBN)
      CALL BDROP(IW,'FAUX')
      INDA = NBANK('FAUX',NBN,2)
      IW(INDA+1) = NCFAUX
      IW(INDA+2) = 0

      CALL WDROP(IW,INFRRE)
      RETURN

 999  CONTINUE
      CALL ERRLOG(104,'S:FRLOCO: Error in FRRE work bank creation')
      CALL WDROP(IW,INFRRE)
      RETURN

      END
*CMZ :  8.07/00 02/12/96  17.57.14  by  Stephen Burke
*CMZ :  8.06/00 16/11/96  22.34.35  by  Stephen Burke
*CMZ :  8.05/03 09/10/96  20.39.55  by  Stephen Burke
*CMZ :  8.05/00 02/10/96  16.58.34  by  Stephen Burke
*CMZ :  8.04/00 05/08/96  16.27.12  by  Stephen Burke
*CMZ :  8.03/00 27/06/96  13.10.12  by  Stephen Burke
*CMZ :  7.11/00 08/04/96  14.59.01  by  Stephen Burke
*CMZ :  7.09/08 05/03/96  21.41.06  by  Stephen Burke
*CMZ :  7.09/03 26/02/96  14.32.07  by  Stephen Burke
*CMZ :  7.09/01 14/02/96  17.32.02  by  Stephen Burke
*CMZ :  7.04/00 18/01/96  21.39.26  by  Stephen Burke
*CMZU:  7.03/08 13/12/95  22.56.43  by  Stephen Burke
*CMZ :  7.03/03 01/12/95  15.34.33  by  Gaby Raedel
*CMZU:  7.02/11 31/10/95  14.03.29  by  Stephen Burke
*CMZ :  7.02/03 15/09/95  14.54.38  by  Gaby Raedel
*CMZU:  7.02/00 21/08/95  14.00.18  by  Stephen Burke
*CMZ :  7.01/01 22/07/95  12.53.59  by  Gaby Raedel
*CMZU:  7.01/00 18/07/95  21.48.11  by  Stephen Burke
*CMZ :  7.00/06 16/05/95  08.57.04  by  G. Raedel
*CMZ :  6.00/14 07/03/95  19.01.09  by  G. Raedel
*CMZU:  6.00/04 19/12/94  15.48.33  by  Stephen Burke
*CMZ :  6.00/00 05/12/94  17.05.13  by  G. Raedel
*CMZU:  5.03/00 03/11/94  22.28.58  by  Stephen Burke
*CMZ :  5.02/00 05/09/94  18.12.12  by  Gaby Raedel
*CMZ :  5.01/06 22/08/94  12.11.32  by  Gaby Raedel
*CMZU:  5.00/10 21/06/94  12.10.04  by  Gaby Raedel
*CMZ :  5.00/04 27/05/94  16.58.50  by  Gaby Raedel
*CMZU:  5.00/03 18/05/94  14.25.31  by  Gaby Raedel
*CMZ :  4.03/13 14/04/94  09.33.04  by  Gaby Raedel
*CMZ :  4.03/12 08/04/94  12.21.50  by  Gaby Raedel
*CMZ :  4.03/10 22/02/94  17.03.29  by  Gaby Raedel
*CMZ :  4.03/03 22/01/94  19.27.11  by  Gaby Raedel
*CMZ :  4.03/02 21/01/94  14.22.30  by  Gaby Raedel
*CMZ :  4.01/01 14/12/93  18.32.43  by  Gregorio Bernardi
*CMZ :  4.01/00 08/12/93  11.03.20  by  Gregorio Bernardi
*CMZ :  4.00/11 07/12/93  09.22.19  by  Gregorio Bernardi
*CMZU:  4.00/02 04/10/93  17.00.00  by  Gregorio Bernardi
*CMZU:  4.00/01 28/09/93  00.49.29  by  Gregorio Bernardi
*CMZ :  4.00/00 10/09/93  17.55.16  by  Gregorio Bernardi
*CMZU:  3.09/07 26/07/93  10.00.24  by  Stephen Burke
*-- Author : S.J. Maxfield
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Top level routine (module) called from the main H1 reconstruction
*  PROGRAM H1REC. Contains full modification history as fortran comments.
*
*  Performs :  initialisation                    ( FPTINT & FPTHIS )
*           :  Unpack radial & planar hits       ( FRLOCO & FPLOCO )
*           :  Find Planar segments              ( FPLSG )
*           :  Find Radial segments              ( FRSEG )
*           :  Link the segments                 ( FTDPAT )
*           :  Diagnostics                       ( FPTDIA )
*           :  KALMAN filter fitting             ( FFKAL )
*           :  Find z-vertex from forward tracks ( FVFIT )
*           :  Print summary...                  ( FPTEND )
*
*HTMLI     : Describe the Input variables to the routine
*
*  Radial hit bank :- <A HREF="FRRE.DDL.html">FRRE</A>
*  Planar hit bank :- <A HREF="FRPE.DDL.html">FRPE</A>
*  CJC vertex bank :- CJKV
*
*HTMLO     : Describe the Output of the routine
*
*  Forward Tracker track bank <A HREF="FTKR.DDL.html">FTKR</A>
*  Hit pointer banks : <A HREF="FTPR.DDL.html">FTPR</A>
*                      <A HREF="FTRX.DDL.html">FTRX</A>
*                      <A HREF="FTPX.DDL.html">FTPX</A>
*
*  Optionally additional information can be output:
*
*  Radial Segment bank : <A HREF="FRSG.DDL.html">FRSG</A>
*  Planar Segment bank : <A HREF="FPSG.DDL.html">FPSG</A>
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTREC
**----------------------------------------------------------------------
*D: FPMAC  80700 SB. Sequence FPPRAM changed:
*S: FPPRAM 80700 SB. MSEGLM reduced to 150 (from 250) to reduce cpu time
*D: FPSOUT 80700 SB. Make FPSG bank without IADROW, downscale histograms
*D: FRSOUT 80700 SB. Downscale histograms
*D: FPLOCO 80700 SB. Downscale histograms
*D: FRLOCO 80700 SB. Downscale histograms
*D: FVZFIT 80700 SB. Hit database only at the beginning of a run
*D: FTRNDB 80700 SB. Reset LOOK area to FTREC 1 at end
*D: FPDG4  80700 SB. Break out of loop when array limit is reached
*D: FPCXTD 80700 SB. Histograms only if FTTUNE is selected
*D: FTJN3  80700 SB. Histograms only if FTTUNE is selected
*D: FTLSEG 80700 SB. Histograms only if FTTUNE is selected
*D: FPLPKS 80700 SB. Histograms only if IDOHIS is 2
*D: FPTHIS 80700 SB. Book some histograms only if FTTUNE is selected
*D: FPTHIS 80700 SB. Reduce number of channels for some 2-D histograms
*D: FFFIT  80700 SB. Reject single radial tracks early
*D: FFKLMN 80700 SB. Call FFTRF for faster calculation of fine corrections
*D: FFTRF  80700 SB. New routine: fast version of FKTRAN
*D: FFCORR 80700 SB. Pass B field to avoid call to GUFLD
*D: FKHUNT 80700 SB. Pass B field value to FFCORR
*D: FFOUT  80700 SB. Downscale some per-hit histograms
*D: FFHTHS 80700 SB. Downscale some per-hit histograms
*D: FFHTHS 80700 SB. Restore residuals vs. Q histograms
*D: FFRJCT 80700 SB. Ask for at least 9 hits on radial-only tracks
*D: FTRMON 80700 SB. Get histograms from the correct area
**----------------------------------------------------------------------
*D: Various80600 GP. HTML comments added
*D: FTREC  80600 GP. Add call to FTRNDB on BEGRUN
*D: FTRNDB 80600 GP. New monitoring routine (puts v and t0 in an ntuple)
*D: FDBGET 80600 GP. New monitoring routine (get v and t0 from db)
*D: FDBGTL 80600 GP. New monitoring routine (get Lorenz angle)
*D: FFBKLK 80600 SB. Residuals vs. Q plots added to standard set
*D: FFHTHS 80600 SB. Residuals vs. Q plots added to standard set
*D: FFKLMN 80600 SB. Change use of FKTRAN to increase speed
*D: FFEVT0 80600 SB. Hit database only on new run (saves time)
*D: FTDSGI 80600 SB. Vertex/T0 selection only for real data
**----------------------------------------------------------------------
*D: FPPJ12 80503 SB. Comment out redundant line
*D: FPPJ23 80503 SB. Comment out redundant line
**----------------------------------------------------------------------
*D: FPMAC  80500 SB. Change to FPPRAM:
*S: FPPRAM 80500 SB. MAXSEG decreased to 200 to reduce cpu time
*D: FPKPKR 80500 IS. New segment linking code
*D: FPLKPR 80500 IS. New segment linking code
*D: FRPKPL 80500 IS. New segment linking code
*D: FPLPKP 80500 IS. New segment linking code
*D: FPLPKS 80500 IS. New segment linking code
*D: FREFIT 80500 IS. New segment linking code
*D: FPTHIS 80500 SB. Book timing histograms unconditionally
*D: FTMSGI 80500 SB. Downscale FT monitoring by a factor of ten
**----------------------------------------------------------------------
*D: FEORMAC80400 GP. New sequence FHLUN:
*S: FHLUN  80400 GP. Common block with unit numbers
*D: FQBOOK 80400 GP. Change histogram booking
*D: FQMONP 80400 GP. Small change
*D: FQMONR 80400 GP. Small change
*D: FTDEOR 80400 GP. Allow for running offline with PRIVOFFL flag
*D: FLK2HB 80400 GP. Allow for running offline with PRIVOFFL flag
*D: GETEAR 80400 GP. Allow for running offline with PRIVOFFL flag
*D: FTQINT 80400 GP. Allow for running offline with PRIVOFFL flag
*D: FBOOKQ 80400 GP. Allow for running offline with PRIVOFFL flag
*D: FPEAKF 80400 GP. Allow for running offline with PRIVOFFL flag
*D: FSUMP  80400 GP. Allow for running offline with PRIVOFFL flag
*D: FSUMR  80400 GP. Allow for running offline with PRIVOFFL flag
*D: FTRMON 80400 GP. Allow for running offline with PRIVOFFL flag
*D: FOFFLM 80400 GP. New deck for running offline with PRIVOFFL flag
*D: FLASTR 80400 GP. New deck for running offline with PRIVOFFL flag
*D: FLASTP 80400 GP. New deck for running offline with PRIVOFFL flag
*D: FMOUTP 80400 GP. New deck for running offline with PRIVOFFL flag
*D: FMOUTR 80400 GP. New deck for running offline with PRIVOFFL flag
*D: FMEANT 80400 GP. New deck for running offline with PRIVOFFL flag
*D: FMSLCT 80400 KM. Farm change
*D: FPLOCO 80400 SB. Make fine correction to T0 for data
*D: FTREC  80400 SB. Don't re-initialise on BEGRUNs after the first
*D: FPTHIS 80400 SB. Book timing histograms by default
*D: FPPJN3 80400 IS. FPPHIT called to check link in phi
*D: FPPJ12 80400 IS. FPPHIT called to check link in phi
*D: FPPJ23 80400 IS. FPPHIT called to check link in phi
*D: FPPJ13 80400 IS. FPPHIT called to check link in phi
*D: FPPHIT 80400 IS. New deck to check linking in phi
**----------------------------------------------------------------------
*D: FMOMAC 80300 SB. Allow for more monitoring histograms
*S: FMOHIS 80300 SB. Allow for more monitoring histograms
*D: FPTINT 80300 KM. Farm changes
*D: FPLOCO 80300 SB. Fine T0 correction (inner/outer wires); farm changes
*D: FRLOCO 80300 SB. Farm changes
*D: FTREC  80300 SB. Farm changes
*D: FTQUIC 80300 SB. Farm changes
*D: FFKLCH 80300 SB. Farm changes
*D: FQBOOK 80300 GP. Changes to monitoring histograms
*D: FQMONP 80300 GP. Changes to monitoring histograms
*D: FQMONR 80300 GP. Changes to monitoring histograms
*D: FILLQR 80300 GP. Changes to monitoring histograms
*D: FBOOKQ 80300 GP. Changes to monitoring histograms
**----------------------------------------------------------------------
*D: FFHTHS 71100 SB. Change to C2 histograms
**----------------------------------------------------------------------
*D: FPLOCO 70908 SB. Fix swapped channels for '94 data
*D: FPFIX  70908 SB. Fix swapped channels for '94 data
**----------------------------------------------------------------------
*D: FMSLCT 70903 SB. Change cut on event T0 to use DB value
**----------------------------------------------------------------------
*D: FTDEOR 70901 GP. Bug fix for nonexistent FTDSGI area
**----------------------------------------------------------------------
*D: FTDEOR 70400 GP. More histograms monitored.
*D: FLK2HB 70400 GP. More histograms monitored.
*D: FTRMON 70400 GP. More histograms monitored.
*D: FPFSTS 70400 SB. Initialisation of NEVENT removed (!)
**----------------------------------------------------------------------
*D: FTDSGI 70303 SB. Call FMSLCT to reject events with bad timing.
*D: FTMSGI 70303 SB. New routine to call FTDSGI without calling FTREC.
*D: FMSLCT 70303 SB. Select events with good timing and vertex.
*D: FFRCEL 70303 SB. Fix bug in drift calculation.
*D: FFHTHS 70303 SB. Put R cut on radial drift distribution.
**----------------------------------------------------------------------
*D: FPLOCO 70211 SB. New monitoring histograms for event T0.
*D: FPTHIS 70211 SB. New monitoring histograms for event T0.
*D: FFBKLK 70211 SB. New checksum histograms; units added to axes.
*D: FFHTHS 70211 SB. New checksum histograms.
**----------------------------------------------------------------------
*D: FKHIST 70211 SB. Bug fix for point rejection printout.
*D: FTREC. 70211 SB.  Initialise IGTTRK array; do peakparm for new histos.
*D: FRPKPL 70211 SM. Zero IGTTRK.
**----------------------------------------------------------------------
*D: FPKPKR 70211 IS. New linking code; remove cosmic version.
*D: FPLKPR 70211 IS. New linking code; remove cosmic version.
*D: FTFIT. 70211 IS.  New linking code.
*D: FPCXTD 70211 IS. New linking code.
*D: FPLPKS 70211 IS. New linking code.
*D: FPATUT 70211 SM. Allow for invalid radial segments.
*D: FSINGR 70211 SM. Allow for invalid radial segments.
*D: FRSOUT 70211 SB. Exclude invalid segments from FRSG.
**----------------------------------------------------------------------
*S: FPMAC  70211 SB.  New variables DWG, DRIWP and DRIWM in /H1WORK/.
*D: FPUDAT 70211 SB. Use asymmetric drifts in planar patrec.
*D: FPDG4  70211 SB.  Use asymmetric drifts in planar patrec.
*D: FPFSSG 70211 SB. Use asymmetric drifts in planar patrec.
**----------------------------------------------------------------------
*B: FTT0   70200 SB. New bank with event T0.
*D: FPLOCO 70200 SB. Add FTT0 bank and monitoring histograms.
*D: FPTHIS 70200 SB. New monitoring histograms for event T0.
*D: FFBKLK 70200 SB. Used hit histograms altered.
*D: FFOUT  70200 SB. Used hit histograms altered.
*D: FFHTHS 70200 SB. Only make C1, C2 if all 4 hits are in the same cell.
**----------------------------------------------------------------------
*D: FTJN3  70100 SB.  Linking bug fix.
*D: FFOUT  70100 SB.  Radial segment quality written to FTKR word 20.
*D: FFCORR 70100 SB. New correction for B-field variation.
*D: FFCORR 70100 SB. Small updates to drift vel. and Lorenz angle.
*D: FFCORR 70100 SB. DEVT0 is now passed as an argument (and histogrammed).
*D: FFKLMN 70100 SB. Changed argument list to FFCORR (DEVT0 added).
*D: FKHUNT 70100 SB. Changed argument list to FFCORR (DEVT0 added).
*D: FFEVT0 70100 SB. DEVT0 is now the change in T0, not drift distance.
*D: FTREC  70100 SB.  Print peakparm values with LOOK histograms.
*D: FFHBK  70100 SB.  New diagnostic histograms (small corrections).
*D: FPT0   70100 SB.   Always compile, add trigger element names.
*D: FFEND  70100 SB.  FPT0 diagnostic histograms written out.
*D: FPT02  70100 SB.  Obsolete.
**----------------------------------------------------------------------
*B: FTGX 70006 SB.   New bank to connect FTGR to FTKR.
*D: FVZFIT 70006 SB. Create the new FTGX bank.
*D: FVFIT 70006 SB.  Define the format of the new FTGX bank.
*D: FVZWM 70006 SB.  Fill the new FTGX bank.
*D: FVXTRP 70006 SB. Small fix for use of nominal vertex.
*D: FVZFIT 70006 SB. Bug fixes for debug printout.
*D: FVZWM 70006 SB.  Bug fixes for debug printout.
**----------------------------------------------------------------------
*D: FPIINT 70004 SB. Initialise STP, CTP.
*D: FPINIT 70004 SB. Initialise STP, CTP.
*D: FTDGEO 70004 SB. Initialise STP, CTP.
*S: FPMAC 70004 SB.  DRMASK now LOGICAL, new variables STP, CTP.
*D: FPDG31 70004 SB. Various speedups.
*D: FPDG32 70004 SB. Various speedups.
*D: FPDG33 70004 SB. Various speedups.
*D: FPDG4 70004 SB.  Various speedups.
*D: FPFSSG 70004 SB. Various speedups.
*D: FPFTSG 70004 SB. Various speedups.
*D: FPSSGF 70004 SB. Various speedups.
*D: FPDCA 70004 SB.  Various speedups.
*D: FPNDCA 70004 SB. New, faster version of FPDCA.
*D: FPPBIN 70004 RH. Generate lookup table for FPPROB.
*D: FPPROB 70004 RH. PROB replacement using lookup table.
**----------------------------------------------------------------------
*D: FTDPAT 70004 IS. Pick up connected planar segments.
*D: FPCXTD 70004 IS. New routine to pick up connected planars.
*D: FPSPC 70004 IS.  New routine to pick up connected planars.
**----------------------------------------------------------------------
*D: FTCORG 70004 SM. Remove fix for effective stagger.
*D: FPPJN3 70004 IS. New monitoring histograms.
*D: FPTHIS 70004 IS. New monitoring histograms.
*D: FKPRNT 70004 SB. Bug fix for large track numbers.
*D: FFOUT 70004 SB.  Make histograms for 2 and 3 radial tracks.
**----------------------------------------------------------------------
*S: FTMMAC 70004 SB. Obsolete.
*D: FCSWIM 70004 SB. Obsolete.
*D: FPDDIS 70004 SB. Obsolete.
*D: FPTFPT 70004 SB. Obsolete.
*D: FPTOUT 70004 SB. Obsolete.
*D: FRDDIS 70004 SB. Obsolete.
*D: FZDCA 70004 SB.  Obsolete.
*D: FTNTRK 70004 SB. Obsolete.
*D: FTDHTC 70004 SB. Obsolete.
*D: FCFOXY 70004 SB. Obsolete.
*D: FLINE 70004 SB.  Obsolete.
*D: FLNKRS 70004 SB. Obsolete.
*D: FSEGRS 70004 SB. Obsolete.
*D: FTMAB 70004 SB.  Obsolete.
*D: FTMABP 70004 SB. Obsolete.
*D: FTMABS 70004 SB. Obsolete.
*D: FTMABT 70004 SB. Obsolete.
*D: FTMAT2 70004 SB. Obsolete.
*D: FTMATB 70004 SB. Obsolete.
*D: FTMINV 70004 SB. Obsolete.
*D: FTSQ 70004 SB.   Obsolete.
*D: FTTRAC 70004 SB. Obsolete.
*D: FTUTOH 70004 SB. Obsolete.
*D: FTVTOH 70004 SB. Obsolete.
*D: FPLPK1 70004 SB. Obsolete.
*D: FRFAIL 70004 SB. Obsolete.
**----------------------------------------------------------------------
*D: FTREC  60014 SB.   CTKV dependence removed to aid reprocessing
*D: FTREC  60004 SB.   Abort reconstruction for very large events
**----------------------------------------------------------------------
*D: FPPJN3 60000 IS.  Array bounds increased to 100 in /FTPLNK/
*D: FPPJ12 60000 IS.  Array bounds increased to 100 in /FTPLNK/
*D: FPPJ23 60000 IS.  Array bounds increased to 100 in /FTPLNK/
*D: FPPJ13 60000 IS.  Array bounds increased to 100 in /FTPLNK/
*D: FFCHEK 60000 SB.  Small bug fix in efficiency calculation
*D: FFKLMN 60000 SB.  Veto bad tracks before diagnostics
*D: FFOUT  60000 SB.   Don't flag empty segments as tertiary!
**----------------------------------------------------------------------
*S: FPMAC  60000 SB.  MAXCLU increased to 100
*S: FPMAC  60000 SB.  New common FPSTSG
*D: FPSOUT 60000 SB.  MASKSG in FPSG extended.
*D: FFOUT  60000 SB.   Flag 2ry/3ry segments in NHIT word
*D: FPTINT 60000 SB.  Parameter printout by default
**----------------------------------------------------------------------
*D: FFHBK  60000 SB.   New diagnostic histograms
*D: FFCHEK 60000 SB.  New diagnostic histograms
*D: FFBKLK 60000 SB.  New monitoring histograms
*D: FFOUT  60000 SB.   Restore some monitoring histograms
*D: FKHUNT 60000 SB.  Add timing corrections, correct track angle correction
*D: FFFILL 60000 SB.  New routine to fill KF common blocks
*D: FFEVT0 60000 SB.  New routine to perform the event T0 correction
*D: FFCORR 60000 SB.  New routine to perform timing/track angle correction
*D: FFSTART 60000 SB. New routine to set up KF starting vector
*D: FFKLMN 60000 SB.  Move some code into subroutines
**----------------------------------------------------------------------
*D: FVZWM  60000 SB.   New z-vertex algorithm
*D: FVTRUE 60000 SB.  Use FVXPRM to defined primary tracks
*D: FVZFIT 60000 SB.  New z-vertex algorithm
*D: FVZFIT 60000 SB.  Multiple vertices in FTGR
*D: FVBKLK 60000 SB.  New monitoring histograms
*D: FVXTRP 60000 SB.  Pass the nominal z-vertex as an argument
**----------------------------------------------------------------------
*D: FFFIT  60000 SB.   Trap bank problems
*D: FTDHTC 60000 SB.  Avoid overflows
*D: FRLOCO 60000 SB.  Protect against zero charge
*D: FILHTS 60000 SM.  Protect against corrupt pointers
*D: FTVDET 60000 SB.  Protect against division by zero
*D: FPPJ13 60000 SB.  Eliminate compiler warning
*D: FPFSEG 60000 SB.  Comment out use of IUCLU (unused)
*D: FPFYUV 60000 SB.  Suppress printout
**----------------------------------------------------------------------
*D: FPTINT 60000 SM.  Modifications to FPPP bank for new linking.
*D: FPLPKP 60000 IS.  Different cuts for 2ry/3ry planar segments
*D: FPPJN3 60000 IS.  Different cuts for 2ry/3ry planar segments
*D: FPPJ12 60000 IS.  Different cuts for 2ry/3ry planar segments
*D: FPPJ23 60000 IS.  Different cuts for 2ry/3ry planar segments
*D: FPPJ13 60000 IS.  Different cuts for 2ry/3ry planar segments
**----------------------------------------------------------------------
*D: FPLINT 60000 RH.  Add calls for 2ry/3ry segments
*D: FPFSSG 60000 RH.  Find 2ry planar segments
*D: FPFTSG 60000 RH.  Find 3ry planar segments
*D: FPDCA  60000 RH.   New utility routine (find dca between vectors)
*D: FPFSTS 60000 RH.  Fit 2ry/3ry planar segments
*D: FPSSGF 60000 RH.  Check connectivity of 2ry/3ry planar segments
**----------------------------------------------------------------------
*S: FRMAC  60000 SM.  Sequence FJNPAR changed.
*D: FPTINT 60000 SM.  Modifications to FPRP bank for new linking.
*D: FTJN3  60000 .SM.  New radial radial linking.
*D: FTJN12 60000 SM.  New radial radial linking.
*D: FTJN23 60000 SM.  New radial radial linking.
*D: FTJN13 60000 SM.  New radial radial linking.
*D: FTCHKH 60000 SM.  New radial radial linking.
**----------------------------------------------------------------------
*D: FPTVER 60000 SM.  Fix vertex.
*D: FPATUT 60000 SM.  Add FAUX bank to R list.
*D: FTLSEG 60000 SM.  De-SELECT some unbooked histograms.
*D: FTDPAT 60000 SM.  Correct SAREA call.
*D: FPTHIS 60000 SM.  Book some unbooked histograms.
*D: FPTREZ 60000 SM.  Remove a bug with x-y vertex shift.
**----------------------------------------------------------------------
*D: FRDT2D 60000 SM.  New radial t-to-d function for asymmetry.
*D: FTCORG 60000 SM.  Extension of FRG1 bank to include asymmetry.
*D: FTCORG 60000 SM.  Get effective stagger from new FCR3 bank.
*D: FTCORG 60000 SM.  Extension of FPG1 bank to include asymmetry.
*D: FTCORG 60000 SM.  Get effective stagger from FCP1 bank.
*D: FPLOCO 60000 SM.  Allow for near/far asymmetry. Extend FPLC bank,
*D: FPLOCO 60000 SM.  get stagger from FGAP.
*D: FPLOCO 60000 SB.  Correct for trigger in wrong bunch crossings.
*D: FRLOCO 60000 SM.  Introduce asymmetry and wire-plane velocity
*D: FRLOCO 60000 SM.  factors. New parameters ex FCR3 bank.
*D: FTREC  60000 SM. Tidy LOOK output.
**----------------------------------------------------------------------
*D: FFEND  50108 SB.  New routine for end-of-run printout
*D: FFOUT  50108 SB.  New parameters in call.
*D: FFBKLK 50108 SB.  Changes to monitoring histograms.
**----------------------------------------------------------------------
*D: FFFIT  50106 SB.  New parameters in FFOUT call.
*D: FFKLMN 50106 SB   Bug fix for low momentum.
*D: FKLXYZ 50106 SB   Protect against divide by 0.
**----------------------------------------------------------------------
*D: FVZFIT 50004 GR   replace  CJGR by CJKV bank
**----------------------------------------------------------------------
*D: FFKLMN 50003 SB   bug fix
**----------------------------------------------------------------------
*D: FPTINT 40313 GR   replace UGTBNK call for rundependent MC banks
**----------------------------------------------------------------------
*D: FTDPAT 40312 RP.  printout removed for L4
*D: FMOMAC 40312 SB.  (common) save statement included for L4
**----------------------------------------------------------------------
*D: FVXTRP 40310 GR.  replace OSVX by SIPA for default MC vertex
**----------------------------------------------------------------------
*D: FVFIT  40309 SB.  bug corrected in initialisation
**----------------------------------------------------------------------
*D: FTCORG 40303 GR.  replace UGTBNK calls for rundependent MC banks
**----------------------------------------------------------------------
*D: FVXTRP 40302 GR.  bug fixed (missing BOS common)
**----------------------------------------------------------------------
*D: FVXTRP 40301 SB.  get default vertex from DB
*D: FSETMC 40301 SB.  update version handling
**----------------------------------------------------------------------
*D: FTREC  40100 SM.  CALL new module FTDMON which was running at L4.
**----------------------------------------------------------------------
*D: FTREC  40011 SM.  Make FPKANL call SELECTable. Default- no call.
*D: FTREC  40011 SM.  Move FPOKER call into FTDPAT.
*D: FFBKLK 40011 SB.  Changes to monitoring histograms.
*D: FFFIT  40011 SB.   New parameters in FFOUT call.
*D: FFKLMN 40011 SB.  Farm changes.
*D: FFKLMN 40011 SB.  New params in FFOUT call.
*D: FFKLMN 40011 SB.  Debug histos only for .GE.2 planar segs.
*D: FFOUT  40011 SB.   New parameters in call.
*D: FFOUT  40011 SB.   New monitoring histograms.
*D: FFOUT  40011 SB.   Fix FTPR bug.
*D: FPLOCO 40011 SB.  Correct for trigger in wrong bunch crossings.
*D: FRLOCO 40011 SB.  Correct for trigger in wrong bunch crossings.
*D: FPATUT 40011 SM.  Put supermodule mask in FTUR bank.
*D: FTDPAT 40011 SM.  Add call to FPOKER. Add call to FPRFIT
*D: FPRFIT 40011 SM.  New routine to improve track parameters.
*D: FPKPKR 40011 SM.  Improved segment linking.
*D: FTLSEG 40011 SM.  Improved segment finding.
*D: FTLISA 40011 SM.  Improved segment finding.
*D: FCFOXY 40011 SM.  Bug fix
*D: FPPJN3 40011 SM.  Bug fix and add Chisq cut.
*D: FPPJ12 40011 SM.  Add Chisq cut.
*D: FPPJ23 40011 SM.  Add Chisq cut.
*D: FPPJ13 40011 SM.  Add Chisq cut.
*D: FPTREZ 40011 SM.  Add Chisq cut.
*D: FPOKER 40011 SM.  Add Lorentz angle histograms.
*D: FPKANL 40011 SM.  Add Lorentz angle histograms.
*D: FPTHIS 40011 SM.  Bug fix.
**----------------------------------------------------------------------
*D: FTREC  40011 SB.  Reinstate call to FPKANL.
*D: FPK1LO 40011 SB. Compile only when FDOCAL is selected.
*D: FPOKER 40011 SM. Bugs in histogram booking corrected.
*D: FPKANL 40011 SM. Now more friendly to machines other than DESY IBM.
**----------------------------------------------------------------------
*D: FPLPKP 40002 RG.  SGI..
*D: FTLSEG 40002 RG.  SGI..
**----------------------------------------------------------------------
*D: FVTEXT 40001 SB. Turn off momentum cuts for zero field.
*D: FVZFIT 40001 SB. Ignore CT z-vertex if z=0.0.
*D: FPKANL 40001 SB. Compile only on DESY IBM.
*D: FPK1LO 40001 SB. Compile only on DESY IBM.
*D: FPPJ12 40001 IS. Small bug fixed.
*D: FKTRAN 40001 SB. Cope better (?) with zero field.
*D: FKETOI 40001 SB. Cope better (?) with zero field.
*D: FKITOE 40001 SB. Cope better (?) with zero field.
*D: FFTEXT 40001 SB. Turn off momentum cuts for zero field.
*D: FTCAL 40001 SB.  Remove illegal character.
*D: FTCALP 40001 SB. Remove illegal character.
**----------------------------------------------------------------------
*D: FTREC 40000 SM.  New call to FPOKE/FPKANL.
*D: FTREC 40000 SB.  No more garbage collection.
*D: FPTPDT 40000 SM. New definition of dead wire flag.
*D: FPTRDT 40000 SM. New definition of dead wire flag.
*D: FPWHIT 40000 SM. New definition of dead wire flag.
*D: FRCART 40000 SM. New definition of dead wire flag.
*D: FRLOCO 40000 SM. Make new temporary bank FAUX.
*D: FVFIT 40000 SB.  No more garbage collection.
*D: FVZFIT 40000 SB. Don't make a z-vertex if error is too big.
*D: FVXTRP 40000 SB. Fix bug in xy vertex histos.
*D: FVBKLK 40000 SB. Change scale on xy vertex histos.
*D: FCFOXY 40000 SM. New definition of dead wire flag.
*D: FTQUIC 40000 SB. New deck to give a guess at no. of tracks.
*D: FPOKER 40000 SM. New routine for calibration checking.
*D: FPKANL 40000 SM. New routine for calibration checking.
*D: FPK1LO 40000 SM. New routine for calibration checking.
*D: FPLPKP 40000 SM. New debug histos.
*D: FPPJN3 40000 IS. New linking code.
*D: FPPJ12 40000 IS. New linking code.
*D: FPPJ23 40000 IS. New linking code.
*D: FPPJ13 40000 IS. New linking code.
*D: FPSP 40000 SM.   Undo +SEQ expansion.
*D: FPCHI 40000 IS.  New routine to calculate chi-squared.
*D: FTFHQQ 40000 IS. New linking code.
*D: FTJN12 40000 IS. New linking code.
*D: FTJN13 40000 IS. New linking code.
*D: FTJN23 40000 IS. New linking code.
*D: FTJN3 40000 IS.  New linking code.
*D: FTLSEG 40000 SM. New monitoring histos.
*D: FTLISA 40000 SM. Initialise RR (else DDMIN*RR test might fail?).
*D: FTLISA 40000 SM. Add SEQ BOSMDL so farm change might work.
*D: FTCHKH 40000 IS. New linking routine.
*D: FPDG31 40000 RH. New steering parameter.
*D: FPDG32 40000 RH. New steering parameter.
*D: FPDG33 40000 RH. New steering parameter.
*D: FPUDAT 40000 SM. New definition of dead wire flag.
*D: FPDG4 40000 RH.  New steering parameters; use true resolution.
*D: FPT0 40000 SB.   New routine to plot DT vs. trigger element.
*D: FPTHIS 40000 SM. New monitoring/debug histos.
*D: FKITOE 40000 SB. Only print field warning in production run.
*D: FFKAL 40000 SB.  No more garbage collection.
*D: FFPHNT 40000 SB. New definition of dead wire flag.
*D: FFRHNT 40000 SB. New definition of dead wire flag.
*D: FFRJCT 40000 SB. Min. no. of hits for radial-only tracks.
*D: FFCHEK 40000 SB. New definition of dead wire flag.
*D: FFTRCH 40000 SB. New definition of dead wire flag.
*D: FTMMON 40000 SB. No more garbage collection.
*D: FCALIB 40000 SB. No more garbage collection.
**----------------------------------------------------------------------
*D: FTREC  30907 RP. Farm changes.
*D: FPLOCO 30907 RP. Farm changes.
*D: FPTPDT 30907 RP. Farm changes.
*D: FPTRDT 30907 RP. Farm changes.
*D: FRLOCO 30907 RP. Farm changes.
*D: FTCORG 30907 RP.  Farm changes.
*D: FPSOUT 30907 RP. Farm changes.
*D: FRSOUT 30907 RP. Farm changes.
*D: FRSGST 30907 SM. Allow for 12-wire readout.
*D: FVFIT  30907 RP. Farm changes.
*D: FVFIT  30907 SB. Initialise LUN at BEGJOB.
*D: FVZFIT 30907 SB. Change monitoring histograms.
*D: FVZFIT 30907 RP. Farm changes.
*D: FVZWM  30907 RP. Farm changes.
*D: FVXTRP 30907 SB. Change monitoring histograms.
*D: FVXTRP 30907 RP. Farm changes.
*D: FVBKLK 30907 SB. Change monitoring histograms.
*D: FVBKLK 30907 SB. Vertex monitoring histograms added.
*D: FPKPKR 30907 RP. Farm changes.
*D: FPLKPR 30907 RP. Farm changes.
*D: FPLPKP 30907 RP. Farm changes.
*D: FPPJN3 30907 RP. Farm changes.
*D: FPPJ12 30907 RP. Farm changes.
*D: FPPJ23 30907 RP. Farm changes.
*D: FPPJ13 30907 RP. Farm changes.
*D: FTDPAT 30907 RP. Farm changes.
*D: FRPKPL 30907 RP. Farm changes.
*D: FTMERG 30907 RP. Farm changes.
*D: FTPRTR 30907 RP. Farm changes.
*D: FPATUT 30907 RP. Farm changes.
*D: FPSP   30907 RP. Farm changes.
*D: FSINGR 30907 RP. Farm changes.
*D: FTLSEG 30907 RP. Farm changes.
*D: FTLISA 30907 RP. Farm changes.
*D: FPDG31 30907 RH. Bug fix in cluster finding.
*D: FPDG32 30907 RH. Bug fix in cluster finding.
*D: FPDG33 30907 RH. Bug fix in cluster finding.
*D: FPUDAT 30907 RP. Farm changes.
*D: FPDG4  30907 RH. Bug fix in cluster finding.
*D: FPFPLC 30907 RP. Farm changes.
*D: FPFRLC 30907 RP. Farm changes.
*D: FPTHIS 30907 RP. Farm changes.
*D: FKCHXY 30907 SB. Function now (correctly) double precision.
*D: FKEM   30907 SB. Change 'error 17' message.
*D: FKNORM 30907 SB. Error 17 now tan(theta)>5.
*D: FFBKLK 30907 SB. Changes to monitoring histograms.
*D: FFBKLK 30907 RP. Farm changes.
*D: FFBKLK 30907 SB. Correct bad update.
*D: FFFIT  30907 SB. Changes to monitoring histograms.
*D: FFFIT  30907 RP. Farm changes.
*D: FFKAL  30907 RP. Farm changes.
*D: FFKLMN 30907 RP. Farm changes.
*D: FFOUT  30907 SB. Changes to monitoring histograms.
*D: FFOUT  30907 RP. Farm changes.
*D: FFPHNT 30907 RP. Farm changes.
*D: FFPLAN 30907 RP. Farm changes.
*D: FFRAD  30907 RP. Farm changes.
*D: FFRHNT 30907 RP. Farm changes.
*D: FFHUNT 30907 RP. Farm changes.
*D: FFKILL 30907 SB. Changes to monitoring histograms.
*D: FFKILL 30907 RP. Farm changes.
*D: FTMPCH 30907 RP. Farm changes.
*D: FTMPTO 30907 RP. Farm changes.
**----------------------------------------------------------------------
*D: FTREC  30901 SM. Its all new.
*S: FRMAC  30901 SM. sequence FSGPAR changed.
*T: FPRP   30901 SM. New calibration banks for radial chambers.
*T: FPPP   30901 SM. New calibration banks for planar chambers.
*T: FCR1   30901 SM. New calibration banks for radial chambers.
*T: FCR2   30901 SM. New calibration banks for radial chambers.
*T: FCP1   30901 SM. New calibration banks for planar chambers.
*T: FCP2   30901 SM. New calibration banks for planar chambers.
*T: FRCP   30901 SM. New version of steering bank.
*D: FSETMC 30901 SM. New routine for setting correct MC bank versions
*D: FRSTMC 30901 SM. New routine for setting correct MC bank versions
*D: FPSGRF 30901 SM. Bug fix. Trap array bound error.
*D: FPLOCO 30901 SM. New t-to-d. Extensively rewritten.
*D: FRLOCO 30901 SM. New t-to-d. Extensively rewritten.
*D: FPTINT 30901 SM. Changes to steering control.
*D: FPSGST 30901 SM. Changes for MC handling.
*D: FVFIT  30901 SB. Print summary on ENDJOB.
*D: FEFFIC 30901 SM. Change to include p->R
*D: FPTEND 30901 SM. Bug fix.
*D: FPLT2D 30901 SM. New routine.
*D: FCFOXY 30901 SM. New routine.
*D: FPPJN3 30901 SM. Flag event saturation
*D: FPPJ12 30901 SM. Flag event saturation
*D: FPPJ23 30901 SM. Flag event saturation
*D: FPPJ13 30901 SM. Flag event saturation
*D: FTDPAT 30901 SM. ERRLOG event saturation.
*D: FTPRTR 30901 SM. Flag event saturation
*D: FPSP   30901 SM. Flag event saturation
*D: FTLSEG 30901 SM. Steering changes
*D: FPLPKS 30901 SM. Remove duplicate histogram.
*D: FPLKPR 30901 SM. SELectable code for field off cosmics added.
*D: FPKPKR 30901 SM. SELectable code for field off cosmics added.
*D: FTLISA 30901 SM. Steering changes
*D: FPTHIS 30901 SM. Remove unused histograms
*D: FILHIS 30901 SM. Remove unused histograms.
*D: FFBKLK 30901 SB. Change range of MC histos.
*D: FFBKLK 30901 SB. New monitoring histograms.
*D: FFKAL  30901 SB. Print summary on ENDJOB.
*D: FFKAL  30901 SB. Output LOOK histograms.
*D: FFKLMN 30901 SB. Radius ignored if there are planar hits.
*D: FFRAD  30901 SB. Radius ignored if there are planar hits.
*D: FKHUNT 30901 SB. Extra argument to FFRAD.
*D: FFCHEK 30901 SB. Allow for hits with no digi.
*D: FFCHEK 30901 SB. Fix bug in efficiency histograms
*D: FFHBK  30901 SB. Reinstate missing track histograms.
*D: FFTRCH 30901 SB. Check for dead wires and hits with no digi.
*D: FFTRCH 30901 SB. Reinstate missing track histograms.
**----------------------------------------------------------------------
*D: FVFIT  30704 GB. run summary printed only with SUMM steering param.
*D: FFKAL  30704 GB. run summary printed only with SUMM steering param.
**----------------------------------------------------------------------
*T: FVRS   30606 SB. New steering bank for forward Z-vertex fit.
*T: FVRP   30606 SB. Split NHIT cut into planars and radials.
*T: FVRP   30606 SB. New steering bank for forward z-vertex fit.
*S: FFMAC  30606 SB. FFSTEE sequence modified:
*S: FFSTEE 30606 SB. Extra cuts added.
*S: FFMAC  30606 SB. FFSCAL sequence modified:
*S: FFSCAL 30606 SB. New counters added.
*S: FVMAC  30606 SB. FVPAR sequence modified:
*S: FVMAC  30606 SB. FVSCAL sequence modified:
*D: FVFIT  30606 SB. A bit of extra printout.
*D: FVZFIT 30606 SB. Compare FT with CT z-vertex.
*D: FVZWM  30606 SB. New debug histogram numbers.
*D: FVXTRP 30606 SB. Separate cut on # of radial and planar hits.
*D: FVXTRP 30606 SB. New debug histograms and numbers.
*D: FVTEXT 30606 SB. Separate cuts on # of planar/radial hits.
*D: FVTEXT 30606 SB. FVRP steering bank format changed.
*D: FVHBK  30606 SB. New debug histograms/numbers.
*D: FFBKLK 30606 SB. New monitoring histograms.
*D: FFKAL  30606 SB. Print new counters.
*D: FFKAL  30606 SB. Call new diagnostic routine FFTRAN.
*D: FFKLMN 30606 SB. Small change in debug steering.
*D: FFOUT  30606 SB. Call new track rejection routine FFKILL.
*D: FFOUT  30606 SB. New monitoring histograms.
*D: FFTEXT 30606 SB. New steering cuts; FFRS bank format changed.
*D: FFKILL 30606 SB. New deck to remove bad tracks.
*D: FFHBK  30606 SB. Debug steering changed slightly.
*D: FFTRAN 30606 SB. New deck for diagnostics.
*D: FTREC  30606 SM. Add diagnostics.
*D: FRLOCO 30606 SM. FRLC bank extended. Histos added.
*D: FPLOCO 30606 SM. FPLC bank extended. Histos added.
*D: FPSOUT 30606 SM. Histogram bug fixed.
*D: FRSGST 30606 SM. Diagnostic changes.
*D: FPSGST 30606 SM. Diagnostic changes.
*D: FPREZI 30606 SM. Histograms added.
*D: FEFFIC 30606 SM. Write statements removed.
*D: FTJN3  30606 SM. Algorithm changed. Histos added.
*D: FTJN12 30606 SM. Algorithm changed. Histos added
*D: FTJN23 30606 SM. Algorithm changed. Histos added.
*D: FTJN13 30606 SM. Algorithm changed. Histos added.
*D: FTTRAC 30606 SM. Extra diagnostics.
*D: FPTREZ 30606 SM. Extra diagnostics.
*D: FPUDAT 30606 SM. Extra diagnostics. Measurement errors improved.
*D: FPDG4  30606 SM. Extra diagnostics. Measurement errors improved.
*D: FPTHIS 30606 SM. Usual.
*D: FCALIB 30606 SM. Subroutine name conflict removed!
*D: FCLHIS 30606 SM. Small cosmetic changes.
*D: FSEGMN 30606 SM. New Deck.
*D: FCLSEG 30606 SM. Obsoleted from patch FT_CALIB
**----------------------------------------------------------------------
*D: FTREC  30602 SM. Add diagnostics.
*D: FRLOCO 30602 SM. Add diagnostics.
*D: FPSGST 30602 SM. Remove HBOOK.
*D: FTKRAN 30602 SM. New monitor routine.
*D: FEFFIC 30602 SM. New monitor routine.
*D: FOXY   30602 SM. New monitor routine.
*D: FTFHQQ 30602 SM. Change error calculation.
*D: FTJN3  30602 SM. Remove HBOOK. Modify link.
*D: FPLPKS 30602 SM. Fix histograms.
*D: FPFYUV 30602 SM. Bug fix.
*D: FPUDAT 30602 SM. New error estimation.
*D: FPDG4  30602 SM. New error estimation.
*D: FPPPTZ 30602 SM. New routine for cov propagation.
*D: FPTHIS 30602 SM. Usual.
**----------------------------------------------------------------------
*D: FTREC  30600 SM. Fix nasty bug in planar segment calls.
**----------------------------------------------------------------------
*D: FFKLMN 30600 SB. Trap SGI overwrites.
**----------------------------------------------------------------------
*S: FRMAC  30600 SM. SEQ FRDIMS changed!!
*D: FPLOCO 30600 SM. error bad hit flag restored.
*D: FPTINT 30600 SM. cosmetic fix.
*D: FTFHPL 30600 SM. Phi=0 patch.
*D: FTFHQQ 30600 SM. change radius error calculation.
*D: FTJN3  30600 SM. expand diagnostic plots.
*D: FTTRAC 30600 SM. Fix bug. Remove poorly parametrised tracks.
*D: FPLPKS 30600 SM. Yet another Phi=0 problem fixed.
**----------------------------------------------------------------------
*D: FPLOCO 30404 SM. FRLC bank mod. Improved drift errors, diagnostics.
*D: FRLOCO 30404 SM. Improved drift errors. Extend diagnostics.
*D: FPTINT 30404 SM. Select flag simplification.
*D: FPTRDT 30404 SM. Improved drift errors. Exclude bad hits.
*D: FPTPDT 30404 SM. Improved drift errors.Exclude bad hits.
*D: FPTOUT 30404 SM. Intermediate banks to R-list. Remove swim to end
*D: FPTOUT 30404 SM.  -wall. Clean SELECT's.
*D: FTREC  30404 SM. Put intermediate banks to R-list. Clean SELECT's.
*D: FPSOUT 30404 SM. Put intermediate banks to R-list. Clean SELECT's.
*D: FPSGST 30404 SM. Clean SELECT's.
*D: FRSOUT 30404 SM. Put intermediate banks to R-list. Clean SELECT's.
*D: FRSOUT 30404 SM. Segment z-limits defined hits not cell edges.
*D: FRSGST 30404 SM. Clean SELECT's.
*D: FRPCHK 30404 SM. Rewrite for ep data.
*D: FPTFPT 30404 SM. Clean SELECT's.
*D: FTNTRK 30404 SM. New deck. Get num 'good' FTD tracks.
*D: FPREZI 30404 SM. New deck. planar segment residual plots.
*D: FVXTRP 30404 SB. Redundant calls to FKNORM removed.                        *
*D: FVZFIT 30404 SB. New monitoring histograms.                                *

*D: FTFHQQ 30404 SM. Improved drift errors.Fix Phi continuity.
*D: FTJN3  30404 SM. Add new histos for tuning.
*D: FTTRAC 30404 SM. Add new histos for tuning.
*D: FTTRAC 30404 SM. Evaluate track parameters at 1st measured point.
*D: FPTREZ 30404 SM. Add new histos for tuning.
*D: FPLPKS 30404 SM. Internal parameter adjustments. Clean SELECT's.

*D: FPFYUV 30404 SM. Internal parameter adjustments.
*D: FPUDAT 30404 SM. Exclude bad hits.
*D: FPDG4  30404 SM. Internal parameter adjustments.

*D: FPTHIS 30404 SM. Changes to special histograms.

*D: FKANAL 30404 SB. Minor bug fixed.
*D: FKDPL  30404 SB. Small bug fixed.
*D: FKRDRW 30404 SB. Leave out projected residuals.
*D: FKTDRW 30404 SB. Leave out projected tracks.
*D: FKCLIK 30404 SB. Cosmetic.

*D: FFFIT  30404 SB. Cosmetic changes.
*D: FFFIT  30404 SB. 1-column FTKR banks no longer made.
*D: FFFIT  30404 SB. Creation of empty files moved to FFOUT.
*D: FFFIT  30404 SB. Small fix to error counting.
*D: FFFIT  30404 SB. Make empty FTKX bank if necessary.
*D: FFKAL  30404 SB.  Cosmetic changes.
*D: FFKLMN 30404 SB. Cosmetic changes; new histograms.
*D: FFKLMN 30404 SB. Severity added to ERRLOG messages.
*D: FFOUT  30404 SB. New monitoring histograms.
*D: FFOUT  30404 SB. Empty banks made here instead of in FFFIT.
*D: FFOUT  30404 SB. Protect against large chi-squared.
*D: FFOUT  30404 SB. Vertex fit stuff removed.
*D: FFOUT  30404 SB. Protect against divide by 0.
*D: FFOUT  30404 SB. FTKX now added to E-list in FTREC for debug.
*D: FFPHNT 30404 SB. Add check on bad hit flag.
*D: FFRAD  30404 SB.  Fix bad radius bug.
*D: FFRHNT 30404 SB. Check for bad hits (again).
*D: FFTEXT 30404 SB. Cosmetics.
*D: FFBKLK 30404 SB. Remove vertex histos, add xy, change scales.              *
*D: FFRCEL 30404 SB. Cosmetics.
*D: FFPLAN 30404 SB. Fix IDSIGN.
*D: FFHBK  30404 SB. New histograms.                                           *
*T: FRCS   30404 SM. Steering adjustments.
*T: FRCP   30404 SM. Steering adjustments.
**----------------------------------------------------------------------
*D: FRPCHK 30308 SM. New deck for rad-pla alignment plots
*D: FRSOUT 30308 SM. Add call to FRPCHK (not for standard job).
*D: FRLOCO 30308 SM. Add event T0 correction from CEVT0.
*D: FPLOCO 30308 SM. Add event T0 correction from CEVT0.
*D: FTREC 30308 .SM. Turn on planar segment with event size check.
*D: FPTINT 30308 SM. Add max planar event size for FPSEG.
*D: FPTREZ 30308 SM. Add additional monitoring plots.
*D: FTTRAC 30308 SM. extend residual plots to < 3mod tracks.
*D: FPSOUT 30308 SM. Add control for MC only.
*D: FPTHIS 30308 SM. Adjust histogram binning.
*S: FRMAC  30404 SM. Add max planar event size for FPSEG to SEQ FPTFLG.
*T: FPCP   30404 SM. Extend for max planar event size.
**----------------------------------------------------------------------
*D: FTREC  30307 SM. Switch off planar segnment finding (time).
**----------------------------------------------------------------------
*D: FTLINK 30306 SW. bug. Undefined variable (NIG) removed.
*D: FRCART 30306 SM. temp.fix to a  bug which causes problems in h1look
**----------------------------------------------------------------------
*D: FPLOCO 30304 SM. Add illegal channel handling.
*D: FRLOCO 30304 SM. Add illegal channel handling.
*D: FPTINT 30304 SM. Add FTlink steering.
*D: FTJN12 30304 SM. Add FTlink steering.
*D: FTJN13 30304 SM. Add FTlink steering.
*D: FTJN23 30304 SM. Add FTlink steering.
*D: FTJN3  30304 SM. Add FTlink steering.
*D: FPTHIS 30304 SM. Fix histogram steering bug.
*D: FRSGST 30304 SM. Fix histogram steering bug.
*S: FRMAC  30304 SM. Add sequence FJNPAR for link steering.
*T: FRCP   30304 SM. Extend for link steering.
**----------------------------------------------------------------------
*D: FTREC  30303 .SM. Add call to z-vertex finding routine.
*S: FVSTEE 30303 SB. New sequence + common block for steering.
*S: FVPAR  30303 SB. New sequence + common block with parameters.
*S: FVSCAL 30303 SB. New sequence + common block with counters.
*S: FVWBI  30303 SB. New sequence + common block with indices.
*T: FVRS   30303 SB. New steering bank for forward Z-vertex fit.
*T: FVRP   30303 SB. New steering bank for forward z-vertex fit.
*D: FVMAC  30303 SB. New deck, with sequences for FT vertex fit:
*D: FVFIT  30303 SB. New deck to steer forward z-vertex fit.
*D: FVZFIT 30303 SB. Bank FVZR added to the E-list:
*D: FVZFIT 30303 SB. New deck to perform forward z-vertex fit.
*D: FVCHEK 30303 SB. New deck to check FVFIT output.
*D: FVZWM  30303 SB. New deck to take a weighted mean of z values.
*D: FVXTRP 30303 SB. New deck to extrapolate tracks to vertex.
*D: FVTEXT 30303 SB. New steering banks FVRS and FVRP from db:
*D: FVTEXT 30303 SB. New deck to read z-vertex fit steering banks.
*D: FVBKLK 30303 SB. New deck to book z-vertex monitoring histograms.
*D: FVHBK  30303 SB. New deck to book z-vertex diagnostic histograms.
*D: FVTRUE 30303 SB. New deck to mark tracks as primary/secondary.
**----------------------------------------------------------------------
*D: FTJN13 30301 SM. Fix selection of best link.
*D: FTJN12 30301 SM. Fix selection of best link.
*D: FPMAC  30301 GB: macro FPRINT and FPGEOM renamed to FPPRNT,FPLGEO.
*S: FPLGEO 30301 GB: sequence replacing FPGEOM (avoid clash)
*S: FPPRNT 30301 GB: sequence replacing FPRINT (avoid clash)
*D: FPTINT 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FTDGEO 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPCFIT 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPCPLN 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPDG31 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPDG32 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPDG33 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPFSEG 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPFYUV 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPIINT 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPINIT 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPLINT 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPPDEF 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FPDG4 30301 .GB: macro FPRINT renamed to FPPRNT to avoid clash
*D: FPIPRT 30301 GB: macro FPRINT renamed to FPPRNT to avoid clash
*D: FCTRAC 30301 GB: macro FPGEOM renamed to FPLGEO to avoid clash
*D: FTREC 30301 .SM. Correct handling of FTKX bank. (see FFFIT FFOUT)
*D: FPLOCO 30301 SM. Bug fix. Drop banks at begin for display.
*D: FPTFPT 30301 SM. Output radial segments if FPSGOUT selected.
*D: FPTINT 30301 SM. Pick up pattern recognition parameters from bank.
*D: FPTOUT 30301 SM. radial segment handling if FPSGOUT selected.
*D: FRLOCO 30301 SM. Explicitly drop FRLC FRHC banks.
*D: FPSGST 30301 SM. More diagnostic histograms.
*D: FRSOUT 30301 SM. New routine for monitoring.
*D: FRSGST 30301 SM. New routine for monitoring.
*D: FZDCA 30301 .SM. New routine for monitoring.
*D: FTJN12 30301 SM. Fix selection of best link.
*D: FTJN13 30301 SM. Fix selection of best link.
*D: FTJN23 30301 SM. Fix selection of best link.
*D: FTJN3 30301 .SM. Fix selection of best link.
*D: FTLSEG 30301 SM. Mod to allow parameters from bank.
*D: FTTRAC 30301 SM. Add selectable code for monitoring.
*D: FPCFIT 30301 SM. Bug fix. Protect against small Chisq for PROB.
*D: FPFYUV 30301 SM. Bug fix. Protect against small Chisq for PROB.
*D: FPRCHI 30301 SM. Bug fix. Protect against small Chisq for PROB.
*D: FPSGRF 30301 SM. Bug fix. Protect against small Chisq for PROB.
*D: FPTHIS 30301 SM. Yet mor changes to histograms.
*D: FTZFIT 30301 SM. New routine for monitoring.
*D: FLLFIT 30301 SM. New routine for monitoring.
*D: FFUNCS 30301 SM. New routine for monitoring.
*D: FLFIT 30301 .SM. New routine for monitoring.
*D: FAUSSJ 30301 SM. New routine for monitoring.
*D: FKEM   30301 SB. New error messages for FKLPAS and FKLPAF.
*D: FKLPAF 30301 SB. Error message description updated.
*D: FFFIT  30301 SB. Make empty FTKX bank if necessary.
*D: FFOUT  30301 SB. FTKX now added to E-list in FTREC for debug.
*T: FRCP   30301 SM. Another extension.Version number added.
*T: FPCP   30301 SM. Version number added.
*T: FRCS   30301 SM. Version number added.
*S: FSGPAR 30301 SM. New sequence.
**----------------------------------------------------------------------
*D: FPLOCO 30207 GB. comment lines moved inside the routine
*D: FPTFPT 30207 GB. comment lines moved inside the routine
*D: FPTRDT 30207 GB. comment lines moved inside the routine
*D: FRLOCO 30207 GB. comment lines moved inside the routine
*D: FPSGST 30207 GB. comment lines moved inside the routine
*D: FPLPKS 30207 GB. comment lines moved inside the routine
*D: FPFSEG 30207 GB. comment lines moved inside the routine
*D: FPFYUV 30207 GB. comment lines moved inside the routine
*D: FPDG4  30207 GB. comment lines moved inside the routine
*D: FPTHIS 30207 GB. comment lines moved inside the routine
*D: F_____ 30207 GB. comment lines moved inside the routine FOR MOST ROU
**----------------------------------------------------------------------
*D: FRLOCO 30205 SM. Modifications for Filter farm.
*D: FPLOCO 30205 SM. Modifications fror Filter Farm. Add histogram.
*D: FPTFPT 30205 SM. Make deck anti-selected for FILTER.
*D: FPSGST 30205 SM. Add extra diagnostics for segments.
*D: FPLPKS 30205 SM. Crush small bug.
*D: FPLPK1 30205 SM. Add histogram.
*D: FPTREZ 30205 SM. Add histogram.
*D: FPDG4  30205 SM. Tune slope cuts. Add diagnostic histograms.
*D: FPFSEG 30205 SM. Add diagnostic histograms
*D: FPFYUV 30205 SM. Add diagnostic histogram
*D: FPTHIS 30205 SM. Numerous changes to histograms
*D: FTREC  30205 SM. Improve(?) histogram handling.
**----------------------------------------------------------------------
*D: FPTRDT 30202 GB. Cosmetics
*D: FFRHNT 30202 GB. Cosmetics
*D: FTREC  30202 GB. call to setrec to set MONTE flag.
**----------------------------------------------------------------------
*D: FTREC  30201 SM. Cosmic special code removed. SEL FCOSSPC to get it.
*D: FTLFT  30201 SM. changed to  double precision internally.
*D: FPTOUT 30201 SM. planar segment bank (internal) changed.
*D: FPSOUT 30201 SM. planar segment bank (internal) changed.
*D: FPSGST 30201 SM. planar segment bank (internal) changed.
*D: FPTHIS 30201 SM. Histograms rearranged slightly.
*D: FTREC  30110 SM. Planar segment output with FPSGOUT selected.
*D: FTLFTW 30110 SM. changed to  double precision internally.
*D: FTCORG 30110 SM. Modifications for filter.
*D: FCSWIM 30110 SM. Modifications for filter.
*D: FRLOCO 30110 SM. Time-distance relation corrected.
*D: FRLOCO 30110 SM. Modifications for filter. MVBITS replaced.
*D: FPLOCO 30110 SM. Modifications for filter. MVBITS replaced.
*D: FRMAC  30110 SM. Sequences FPTFLG FPTPAR FWINDS added.
*S: FWINDS 30110 SM. New sequence.
*S: FPTFLG 30110 SM. New sequence.
*S: FPTPAR 30110 SM. New sequence.
*D: FPTINT 30110 SM. Read more parameters from FRCP bank.
*D: FPTINT 30110 SM. Modifications for filter.
*D: FPTRDT 30110 SM. Modifications for filter.
*D: FPTPDT 30110 SM. Modifications for filter.
*D: FPTOUT 30110 SM. Planar segment output with FPSGOUT selected
*D: FPSOUT 30110 SM. Planar segment output with FPSGOUT selected
*D: FPSGST 30110 SM. Planar segment output with FPSGOUT selected
*D: FTFHPL 30110 SM. New version. New argument list.
*D: FTTRAC 30110 SM. New version. Uses planar segments and/or hits.
*D: FPTREZ 30110 SM. New deck.
*D: FPLPK1 30110 SM. New deck for planar hit pick-up.
*D: FPLPKS 30110 SM. New deck for planar hit pick-up.
*D: FTLSEG 30110 SM. Improved version for data and MC.
*D: FPTHIS 30110 SM. More diagnostic histograms added.
*T: FRCP   30110 SM. Bank contents extended.
**----------------------------------------------------------------------
*D: FTDGEO 30108 RG. INDR replaced with INFGAR (INDR is a fct of bos)
*D: FKCOVR 30108 SB. Overflow error trapped.
*D: FKEM   30108 SB. New error code (IOVCV). Message format changed.
*D: FKEND  30108 SB. Cosmetic change to printout.
*D: FKLOOK 30108 SB. Initialise IFAIL1 to please UNDEF.
*D: FKLPAF 30108 SB. Initialise IFAIL to please UNDEF.
*D: FKLRSD 30108 SB. Trap overflows.
*D: FKLSSM 30108 SB. Remove unused FKECODE sequence.
*D: FKPRHS 30108 SB. Change FKISUM to subroutine to please UNDEF.
*D: FKSTAT 30108 SB. Change FKISUM to subroutine to please UNDEF.
*D: FKISUM 30108 SB. Change from function to subroutine to please UNDEF.
*D: FKPROB 30108 SB. Change to avoid UNDEF warning.
*D: FKANAL 30108 SB. Digi with wrong drift sign counts as a bad hit.
*D: FKANAL 30108 SB. Phi histograms added.
*D: FKCLIK 30108 SB. Change to avoid UNDEF warnings.
*D: FKDHIT 30108 SB. Remove unused GKSENUM sequence.Change to avoid UND.
*D: FKDPL  30108 SB. Plane with wrong drift sign drawn in yellow. "" "
*D: FKHBK  30108 SB. Phi histograms added.
*D: FKHPR  30108 SB. Remove unused FKMEAS sequence.
*D: FKHPR  30108 SB. Print histograms only if they exist.
*D: FKIHGZ 30108 SB. Reference H array to please UNDEF.
*D: FKRDRW 30108 SB. Remove unused GKSENUM sequence.Change to avoidUND
*D: FKTDRW 30108 SB. Remove unused GKSENUM sequence.
*D: FFBKLK 30108 SB. Add some new histograms, with new numbering.
*D: FFBKLK 30108 SB. Change range of histograms for data.
*D: FFFIT  30108 SB. ERRLOG changed. BKFMT calls moved to FFKAL.
*D: FFFIT  30108 SB. Add #tracks histogram call for empty events
*D: FFKAL  30108 SB. Small cosmetic change (IFIRST -> LINIT).
*D: FFKAL  30108 SB. ERRLOG error numbers changed.
*D: FFKAL  30108 SB. Change printout format slightly.
*D: FFKAL  30108 SB. BKFMT calls moved here.
*D: FFKAL  30108 SB. New counters added.
*D: FFKAL  30108 SB. Call H1STOP if initialisation fails.ERRLOG. PAW
*D: FFKLMN 30108 SB. Make efficiency histograms conditional on PMCUT
*D: FFKLMN 30108 SB. BKFMT calls moved to FFKAL.ERRLOG.
*D: FFKLMN 30108 SB. Check the drift sign in debug mode.Count failed
*D: FFKLMN 30108 SB. tracks.Starting errors must be .LE. errors in FTUR
*D: FFOUT  30108 SB. Bug fix (NDF now correct if LRISV is .TRUE.)
*D: FFOUT  30108 SB. ERRLOG.Remove unused FKMEAS seq. Count failures.
*D: FFOUT  30108 SB. Better handling of errors with missing banks.
*D: FFOUT  30108 SB. ERRLOG.Add some new histograms, with new numbering.
*D: FFPCEL 30108 SB. ERRLOG. FKMEAS.
*D: FFPLAN 30108 SB. ERRLOG. FKMEAS.
*D: FFRCEL 30108 SB. ERRLOG. FKMEAS.
*D: FFRAD  30108 SB. ERRLOG. FKMEAS.
*D: FFTEXT 30108 SB. Steering banks/parameters modified. Now protected
*D: FFTEXT 30108 SB. against getting wrong version of steering banks.
*D: FFTEXT 30108 SB. ERRLOG.Printout format improved.small bug corr.
*D: FKHUNT 30108 SB. Remove unused HCHI variable.Initialise IFAIL1 to
*D: FKHUNT 30108 SB. please UNDEF. Check for wrong drift sign in debug .
*D: FFCHEK 30108 SB. Fix bug in efficiency histograms.Check drift sign.
*D: FFCHEK 30108 SB. Add a check for dead wires
*D: FFCHTR 30108 SB. Check to see if the drift sign is correct.ERRLog
*D: FFKLCH 30108 SB. Remove unused FKCNTL sequence.UNDEF.ERRLOG
*D: FFXTRP 30108 SB. Initialise IPF and IRF to please UNDEF.
*D: FPFPHC 30108 SE: non-standard fortran
*D: FPHITZ 30108 SE: non-standard fortran
*D: FFMAC  30108 SB. FFSTEE sequence modified:
*S: FFSTEE 30108 SB. Obsolete parameters removed.
*S: FFSCAL 30108 SB. New counters added.
*D: FKMAC1 30108 SB. FKNPL, FKLERR sequences modified:
*S: FKNPL  30108 SB. Array LTRPLD added to flag wrong drift sign.
*S: FKLERR 30108 SB. New error code (IOVCV) added.
*D: FKMAC2 30108 SB. FKDBG, FKLERR sequences modified:
*S: FKDBG  30108 SB. Array LTRPLD added to flag wrong drift sign.
*S: FKLERR 30108 SB. New error code (IOVCV) added.
*D: KTMAC  30108 SB. Sequences modified:
*S: KTSTEE 30108 SB. Debug steering flags added.
*S: KTPAR  30108 SB. Extra steering parameters added.
*S: KTSCAL 30108 SB. New sequence + common block with counters.
**----------------------------------------------------------------------
*D: FRLOCO 30104 SM. Add distortion correction to radius.
*D: FRLOCO 30104 SM. Flag potentential timing pulses by setting
*D: FRLOCO 30104 SM. Bit 2 in ISGNW. See routine for details.
*D: FPTRDT 30104 SM. reject bad hits flagged by FRLOCO.
*D: FFBKLK 30104 SM. Change range of Histos for data.
*D: FFRHNT 30104 SM. Check for bad hits.
*D: FFRAD  30104 SM. Check for bad hits.
*T: FGAP   30104 SM. Data version of bank added.
*T: FGAR   30104 SM. Data version of bank added
**----------------------------------------------------------------------
***************************************************************
*     Module to Pattern recognise Forward tracker
*
***************************************************************
*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,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEND.

*     bank number forvarious banks.
      PARAMETER(NBN=0)
      PARAMETER(NCFPLC=7)
      PARAMETER(NCFRLC=10)
      PARAMETER(NCFAUX=1)
      PARAMETER(NCFPHC=2)
      PARAMETER(NRFPHC=1152)
      PARAMETER(NCFRHC=2)
      PARAMETER(NRFRHC=864)

      CHARACTER*17 SANAME
      CHARACTER*8 VERSQQ
      LOGICAL LFIRST
      DATA JEVENT / 0 /
      DATA LFIRST/.TRUE./
*KEEP,VERSQQ.
      VERSQQ = ' 8.07/02'
      IVERSQ =  80702
*KEND.
*
*     module steering by MODULS
*      CALL MODULS('FTREC',IVERSQ,'FRREFRPECJKVCTKV')
* CTKV dependence removed to aid reprocessing
      CALL MODULS('FTREC',IVERSQ,'FRREFRPECJKV')
*     get right bank versions for MC events...
      CALL FSETMC
*
      IF (LFIRST) THEN
* Initialise IGTTRK flag array
         CALL VZERO(IGTTRK,MAXTRK)
         LFIRST = .FALSE.
      ENDIF
      IF(BEGJOB) THEN
        CALL H1ENVI(JSTAT,JPROC,NPROC)
      ENDIF
      IF(ENDRUN) THEN
      END IF

*-----PATTERN RECOGNITION SECTION-------------------------------------
*
*     Set area for Pattern Recognition histograms.
      CALL SAREA('FTREC',1)

      IF (BEGRUN.AND.JEVENT.LT.1) THEN
        WRITE(6,'('' '')')
        WRITE(6,'(10X,''F T R E C  Initialising...'')')
        WRITE(6,'(10X,''        ...Production Version'')')
        WRITE(6,'('' '')')
* rebook b16 input bank formats for the farm
         CALL BKFMT('FRRE','B16')
         CALL BKFMT('FRPE','B16')
C         CALL SETREC
         CALL FPTINT
         CALL FPTHIS
      ENDIF
*
* Monitor V/T0 used
      IF (BEGRUN) CALL FTRNDB(NCCRUN)
*
      IF(REVENT) THEN
C+SELF,IF=FTTIME.
         CALL TIMEX(T1)
C+SELF.
         JEVENT = JEVENT + 1

*        Unpack radial and planar digis into temporary banks
*        FRLC FPLC etc.
         CALL FRLOCO
         CALL FPLOCO
         INFPLC = NLINK('FPLC',0)
         IF (INFPLC.GT.0) THEN
            NPHIT = IW(INFPLC+2)
            IF (NPHIT.GT.NPLMAX) THEN
* Abandon very large events
               CALL ERRLOG(1,'S:FTREC:  Too many planar hits')
               INFRLC = NLINK('FRLC',0)
               IF (INFRLC.GT.0) THEN
                  NRHIT = IW(INFRLC+2)
               ELSE
                  NRHIT = 0
               ENDIF
               CALL H1WARN(10001,'Too big',FLOAT(NPHIT),FLOAT(NRHIT),0.)
               CALL BDROP(IW,'FPLC')
               CALL BDROP(IW,'FRLC')
               CALL BDROP(IW,'FAUX')
               INFPLC = NBANK('FPLC',NBN,2)
               IF (INFPLC.GT.0) THEN
                  IW(INFPLC+1) = NCFPLC
                  IW(INFPLC+2) = 0
               ENDIF
               INFRLC = NBANK('FRLC',NBN,2)
               IF (INFRLC.GT.0) THEN
                  IW(INFRLC+1) = NCFRLC
                  IW(INFRLC+2) = 0
               ENDIF
               INFAUX = NBANK('FAUX',NBN,2)
               IF (INFAUX.GT.0) THEN
                  IW(INFAUX+1) = NCFAUX
                  IW(INFAUX+2) = 0
               ENDIF
               INFPHC = NLINK('FPHC',0)
               IF (INFPHC.GT.0) CALL VZERO(IW(INFPHC+1),NCFPHC*NRFPHC)
               INFRHC = NLINK('FRHC',0)
               IF (INFRHC.GT.0) CALL VZERO(IW(INFRHC+1),NCFRHC*NRFRHC)
            ENDIF
         ENDIF
C+SELF,IF=FTTIME.
         CALL TIMEX(T2)
C+SELF.
*------------------------------------------------------
*        Find planar segments and make FPSG etc. banls.
*
         CALL FPLSG
*
C+SELF,IF=FTTIME.
         CALL TIMEX(T3)
C+SELF.
*------------------------------------------------------
*        Find Radial segments and make FRSG etc. banks.
*
         CALL FRSEG
*
*------------------------------------------------------
*        Link the segments and make output banks.
*
         CALL FTDPAT
*
*------------------------------------------------------
*        Diagnostics...
*
         IF((IDIAG.GE.1 .OR. IDIAG2.GE.1)
     +              .AND. JEVENT .LE. MAXPRT) CALL FPTDIA
         IF(IDOHIS.GT.0)CALL FILHIS
*        Clean up
C         CALL BGARB(IW)
C         CALL WGARB(IW)
      ENDIF

*     Make monitoring histograms
C      IF(JSTAT.GT.0)THEN
C        CALL SAREA('FTDSGI', 0)
C        CALL FTDSGI
C        CALL SAREA('FTREC',0)
C      ENDIF

      IF(ENDJOB) THEN
*        Print summary...
         CALL FPTEND(JEVENT)

         CALL SAREA('FTREC', 0)
         CALL LPEAKS(4,6)
         CALL LPEAKS(22,22)
         CALL LPEAKS(28,29)
         CALL LPEAKS(75,76)
         CALL LPEAKS(79,84)
         CALL LPEAKS(87,90)
         CALL PRNTF(0,0)

         IF(IDOHIS.GT.0) THEN
           CALL SAREA('FTREC', 1)
           CALL PRNTF(0,0)
           CALL SAREA('FTREC', 2)
           CALL PRNTF(0,0)
         ENDIF

*        Output LOOK Histograms...


      END IF
*
*-----KALMAN FILTER AND FINAL OUTPUT---------------------------------
*
*     Set area for overall histograms...
      CALL SAREA('FTREC',0)
*     Now do the KALMAN filter fitting
      CALL FFKAL
*     Find z-vertex from forward tracks.
      CALL FVFIT
*
C+SELF,IF=FTTIME.
      IF(REVENT) THEN
         CALL SAREA('FTREC',1)
         CALL TIMEX(T4)
         IND1 = NLINK('FRLC',0)
         IND2 = NLINK('FPLC',0)
         FUMR = FLOAT(IW(IND1+2))
         FUMP = FLOAT(IW(IND2+2))
         FUMRP=FUMR+FUMP
         TTOT = T4-T1
         TPLA = T3-T2
         CALL SHS(224,0,TTOT)
         CALL SHS(225,0,TPLA)
         CALL SHD(226,0,FUMRP,TTOT)
         CALL SHD(227,0,FUMP,TPLA)
         CALL SHD(228,0,FUMP,TPLA)
         CALL SHD(229,0,TTOT,TPLA)
         CALL SHS(230,0,FUMP)
         CALL SHS(231,0,FUMR)
         CALL SHS(232,0,FUMRP)
      ENDIF
C+SELF.
*      Now clean up. Switch some banks from R to E list if requested.

      CALL BLIST(IW,'R+','FTKX')
*
*     MODULe Finish
*
      CALL FRSTMC
      CALL MODULF
*
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  7.00/06 15/05/95  12.17.11  by  Stephen Burke
*CMZU:  5.01/08 30/06/94  13.29.36  by  Stephen Burke
*CMZU:  4.03/09 14/02/94  16.14.26  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.51  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.25  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVFIT
*-----------------------------------------Updates 07/09/93-------
**: FVFIT 40000 SB.  No more garbage collection.
*-----------------------------------------Updates 26/07/93-------
**: FVFIT  30907 RP. Farm changes.
*-----------------------------------------Updates 02/06/93-------
**: FVFIT  30907 SB. Initialise LUN at BEGJOB.
*-----------------------------------------Updates 03/05/93-------
**: FVFIT  30907 SB. Print summary on ENDJOB.
*-----------------------------------------Updates 15/10/92-------
**: FVFIT  30907 SB. A bit of extra printout.
*-----------------------------------------Updates 17/08/92-------
**: FVFIT  30907 SB. Fix HBOOK error message.
*-----------------------------------------Updates 06/05/92-------
**: FVFIT  30907 SB. New deck to steer forward z-vertex fit.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Preliminary z-vertex determination from forward tracks.            *
*                                                                    *
**********************************************************************

*KEEP,FVSTEE.
      LOGICAL LTRUTH,LCUT,LRESID
      COMMON /FVSTEE/ IDIAG,LUN,LUNHB,LTRUTH,LCUT,LRESID
*KEEP,FVSCAL.
* Various counters
      PARAMETER (NSCAL=16)
      COMMON /FVSCAL/ NNEVNT,NNVTX,NNFTKR,NNXTR,NNFIT,NNOUT,NNSIN
     &,               NNFTKP,NNXTRP,NNFITP,NNOUTP,NNSINP
     &,               NNVTXC,NNSINC,NNFVNC,NNFSNC
*KEEP,FVWBI.
* Work bank indices
      PARAMETER (NFVWBI=2)
      COMMON /FVWBI/ INFTPR,INFVWK
*KEND.

      LOGICAL LFIRST
      SAVE LFIRST

      COMMON /SUMARY/ LSUMA
*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.

      DATA LFIRST/.TRUE./

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

* Make sure LUN is defined
      IF (BEGJOB) LUN = 6

      IF (BEGRUN .AND. LFIRST) THEN
         LFIRST = .FALSE.
* Zero work bank indices (just in case ...)
         CALL VZERO(INFTPR,NFVWBI)
* Initialise scalars
         CALL VZERO(NNEVNT,NSCAL)
* Read parameters from text banks
         CALL FVTEXT
* Format output banks
         CALL BKFMT('FTGR','2I,(3F,I)')
         CALL BKFMT('FTGX','2I,(I)')
* Book monitoring histograms
         CALL FVBKLK
* Book debug histograms
         CALL FVHBK('FVFIT')
      ENDIF

      IF (REVENT .AND. LFIRST) THEN
* This shouldn't happen!
         WRITE(6,*)
         WRITE(6,*) '**FVFIT**  Not initialised - code error'
         WRITE(6,*)
         CALL H1STOP
      ENDIF

      IF ((IW(6).GT.0 .AND. ENDRUN .AND. LSUMA.EQ.1) .OR.
     &    (IW(6).GT.0 .AND. ENDJOB)) THEN
         WRITE(LUN,*)
         WRITE(LUN,*)
         WRITE(LUN,*) '     *** Forward track z-vertex fit summary ***'
         WRITE(LUN,*)
         WRITE(LUN,*) 'Number of events:                 ',NNEVNT
         WRITE(LUN,*) 'Number of events with a z-vertex: ',NNVTX
         WRITE(LUN,*)
         WRITE(LUN,*) 'Forward tracks:                   ',NNFTKR
         WRITE(LUN,*) 'Tracks extrapolated to vertex:    ',NNXTR
         WRITE(LUN,*) 'Tracks passing DCAMAX/Z0MAX cuts: ',NNFIT
         WRITE(LUN,*) 'Tracks contributing to z-vertex:  ',NNOUT
         WRITE(LUN,*) 'Single tracks giving a vertex:    ',NNSIN
         WRITE(LUN,*)
         IF (LTRUTH) THEN
            WRITE(LUN,*) 'Primary forward tracks:           ',NNFTKP
            WRITE(LUN,*) 'Primary tracks extrapolated:      ',NNXTRP
            WRITE(LUN,*) 'Primary tracks passing cuts:      ',NNFITP
            WRITE(LUN,*) 'Primary single tracks:            ',NNSINP
            WRITE(LUN,*)
         ENDIF
         WRITE(LUN,*) 'CT z-vertices:                    ',NNVTXC
         WRITE(LUN,*) 'CT z-vertices from 1 track:       ',NNSINC
         WRITE(LUN,*)
         WRITE(LUN,*) 'FT z-vertices, no CT:             ',NNFVNC
         WRITE(LUN,*) 'FT z-vertices from 1 track, no CT:',NNFSNC
         WRITE(LUN,*)
         WRITE(LUN,*)
      ENDIF

      IF (REVENT) THEN
         CALL FVZFIT
* Make sure PAW directory is reset
         CALL HCDIR('//PAWC',' ')
* Clean up
C         CALL WGARB(IW)
      ENDIF

      IF (ENDJOB .AND. IDIAG.GE.10) THEN
         IF (IW(6).GT.0) CALL HPDIR('//PAWC/FVFIT',' ')
         IF (LUNHB.GT.0) THEN
            OPEN(UNIT=LUNHB,ACCESS='DIRECT',FORM='UNFORMATTED',
     &           RECL=1024,STATUS='NEW',IOSTAT=IOS)
            IF (IOS.EQ.0) THEN
               CALL HCDIR('//PAWC/FVFIT',' ')
               CALL HRFILE(LUNHB,'FVFIT','N')
               CALL HROUT(0,ICYC,' ')
               CALL HREND('FVFIT')
               CLOSE(LUNHB)
               CALL HCDIR('//PAWC',' ')
            ELSE
               CALL ERRLOG(501,'W:FVFIT:  HBOOK file open failed')
            ENDIF
         ENDIF
      ENDIF

      RETURN
      END
*CMZ :  8.07/00 20/11/96  17.43.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  7.02/00 24/08/95  12.01.36  by  Stephen Burke
*CMZU:  7.00/06 15/05/95  14.53.31  by  Anonymous
*CMZU:  5.03/00 29/10/94  17.23.11  by  Stephen Burke
*CMZU:  5.00/10 21/06/94  11.54.46  by  Gaby Raedel
*CMZ :  5.00/04 27/05/94  16.57.37  by  Gaby Raedel
*CMZU:  4.00/01 21/09/93  16.21.31  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.52  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.25  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVZFIT
*-----------------------------------------Updates 21/09/93-------
**: FVZFIT.......SB. Ignore CT z-vertex if z=0.0.
*-----------------------------------------Updates 07/09/93-------
**: FVZFIT 40000 SB. Don't make a z-vertex if error is too big.
*-----------------------------------------Updates 26/07/93-------
**: FVZFIT 30907 SB. Change monitoring histograms.
**: FVZFIT 30907 RP. Farm changes.
*-----------------------------------------Updates 13/10/92-------
**: FVZFIT 30907 SB. Compare FT with CT z-vertex.
*-----------------------------------------Updates 29/07/92-------
**: FVZFIT 30907 SB. New monitoring histograms.
*-----------------------------------------Updates 06/05/92-------
**: FVZFIT 30907 SB. Bank FTGR added to the E-list:
*!: FTGR   30907 SB. New bank with forward z-vertex.
**: FVZFIT 30907 SB. New deck to perform forward z-vertex fit.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Fit a z-vertex from forward tracks                                 *
*                                                                    *
* Makes FTGR/FTGX banks:                                             *
*                                                                    *
* !                                                                  *
*  TABLE  FTGR                   ! z-vertex from forward tracks      *
* !                                                                  *
* !   ATTributes:                                                    *
* !   -----------                                                    *
* !COL ATT-name FMT Min    Max   ! Comments                          *
* !                                                                  *
*   1  Z        F  -200.   200.  ! z                                 *
*   2  dZ       F     0.   200.  ! sigma(z)                          *
*   3  CHISQ    F     0.   INF   ! Chi-squared                       *
*   4  NDF      I     0    INF   ! (Number of tracks used) - 1       *
* !                                                                  *
* !    RELations:                                                    *
* !    ----------                                                    *
* !COL REL.bank  TYPE  INT.bank  !Comments                           *
* !                    (COL)                                         *
* !                                                                  *
* !                                                                  *
*  END TABLE                                                         *
*                                                                    *
* !                                                                  *
*  TABLE  FTGX                   ! pointers from FTGR to FTKR        *
* !                                                                  *
* !   ATTributes:                                                    *
* !   -----------                                                    *
* !COL ATT-name FMT Min    Max   ! Comments                          *
* !                                                                  *
* !                                                                  *
* !    RELations:                                                    *
* !    ----------                                                    *
* !COL REL.bank  TYPE  INT.bank  !Comments                           *
* !                    (COL)                                         *
* !                                                                  *
*   62  FTKR     D1T1            ! FTKR tracks giving vertex         *
* !                                                                  *
* ! FTGX is a list of all FTKR tracks used to create the FTGR        *
* ! vertices. Note that there is no pointer from FTGR to FTGX,       *
* ! so it is necessary to use the NDF values to calculate the        *
* ! pointers.                                                        *
* !                                                                  *
*  END TABLE                                                         *
*                                                                    *
**********************************************************************

      DIMENSION FVVEC(4)
      LOGICAL LPRIM
      SAVE LPRIM,IRUN,ZBEAZ

*KEEP,FVSTEE.
      LOGICAL LTRUTH,LCUT,LRESID
      COMMON /FVSTEE/ IDIAG,LUN,LUNHB,LTRUTH,LCUT,LRESID
*KEEP,FVPAR.
      DOUBLE PRECISION ZWALL1,ZWALL2,RADLEN
      COMMON /FVPAR/ ZWALL1,ZWALL2,RADLEN,MINHTP,MINHTR,ZSQMAX
     &,              PMIN,DCAMAX,Z0MAX,CHIMAX
*KEEP,FVSCAL.
* Various counters
      PARAMETER (NSCAL=16)
      COMMON /FVSCAL/ NNEVNT,NNVTX,NNFTKR,NNXTR,NNFIT,NNOUT,NNSIN
     &,               NNFTKP,NNXTRP,NNFITP,NNOUTP,NNSINP
     &,               NNVTXC,NNSINC,NNFVNC,NNFSNC
*KEEP,FVWBI.
* Work bank indices
      PARAMETER (NFVWBI=2)
      COMMON /FVWBI/ INFTPR,INFVWK
*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,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.

      DATA LPRIM/.TRUE./,IRUN/-999999/,ZBEAZ/0./

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

      INFTKR = NLINK('FTKR',0)

      IF (INFTKR.LE.0) THEN
         CALL ERRLOG(511,'S:FVZFIT: FTKR bank not found')
         RETURN
      ENDIF

* Count events
      NNEVNT = NNEVNT + 1

* Zero work bank index
      INFVWK = 0

* Quick check to see if there are any forward tracks
      NFTKR = IW(INFTKR+2)
      IF (NFTKR.LE.0) GOTO 8000

* Create a work bank to store z values and weights
      CALL WBANK(IW,INFVWK,NFTKR,*9000)

      CALL HCDIR('//PAWC/FVFIT',' ')

* Write primary/secondary flag into word 7 (IPTYPE)
      IF (LTRUTH) CALL FVTRUE(INFTKR)

* Get the nominal z-vertex
      IMC = JRDATA('RUNTYPE',STATUS)
      INOSVX = 0
      INBEAZ = 0
      IF (IMC.GT.0) THEN
         INOSVX = NLINK('SIPA',0)
      ELSEIF (IRUN.NE.NCCRUN) THEN
         IRUN   = NCCRUN
         INBEAZ = IABS(MDB('BEAZ'))
         IF (INBEAZ.GT.0) ZBEAZ = RW(INBEAZ +2 +2)
      ENDIF
      ZNOM = 0.
      IF (INOSVX.GT.0) THEN
        IF(IW(INOSVX).GE.22) ZNOM = RW(INOSVX+21)+RW(INOSVX+22)
      ELSE
        ZNOM = ZBEAZ
      ENDIF

*
* Loop over forward tracks, and calculate z0
*

      DO 100 JFT=1,NFTKR-1,2
         IF (LTRUTH) LPRIM = IBTAB(INFTKR,7,JFT).EQ.0
         NNFTKR = NNFTKR + 1
         IF (LPRIM) NNFTKP = NNFTKP + 1
* Extrapolate to vertex region and calculate z0 and weight
         CALL FVXTRP(RW(INDCR(INFTKR,1,JFT)),ZNOM,LPRIM,Z0,WZ0,IFAIL)
         IF (IFAIL.EQ.0) THEN
* Store in work bank
            RW(INFVWK+JFT)   = Z0
            RW(INFVWK+JFT+1) = WZ0
            NNFIT = NNFIT + 1
            IF (LPRIM) NNFITP = NNFITP + 1
         ELSE
* If the weight is zero, the track will be ignored
            RW(INFVWK+JFT+1) = 0.
         ENDIF
 100  CONTINUE

* Take the weighted mean of the z values
      CALL FVZWM(INFTKR,NFTKR,ZNOM,.TRUE.,FVVEC,IFAIL)
      IF (IFAIL.NE.0) THEN
         CALL SHS(21,0,0.)
         GOTO 8000
      ENDIF

* Create the FTGR bank ...
      INFTGR = NBANK('FTGR',0,6)
      IF (INFTGR.LE.0) THEN
         CALL ERRLOG(512,'S:FVZFIT: Unable to create FTGR')
         GOTO 9500
      ENDIF

* ... and fill it
      NVERT = 1
      IW(INFTGR+1) = 4
      IW(INFTGR+2) = NVERT
      CALL UCOPY(FVVEC,IW(INFTGR+3),4)
      CALL BLIST(IW,'E+','FTGR')
      CALL BLIST(IW,'E+','FTGX')

* Monitoring histograms
      CHISQ = RBTAB(INFTGR,3,1)
      NDF   = IBTAB(INFTGR,4,1)
      CALL SHS(21,0,FLOAT(NDF+1))
      CALL SHS(22,0,FVVEC(1))
      CALL SHS(23,0,FVVEC(2))
      IF (CHISQ.GT.0. .AND. NDF.GT.0) THEN
         CHPROB = PROB(CHISQ,NDF)
         CALL SHS(24,0,CHISQ/FLOAT(NDF))
         CALL SHS(25,0,CHPROB)
      ELSE
         CALL SHS(24,0,-1.)
         CALL SHS(25,0,-1.)
      ENDIF

* Compare with the CxKV z-vertex
      INCXKV = NLINK('CTKV',0)
      IF (INCXKV.LE.0) INCXKV = NLINK('CJKV',0)
      JPRIM = 0
      IF (INCXKV.GT.0) THEN
         NCXKV = IW(INCXKV+2)
         DO 200 JCXKV=1,NCXKV
            IF (IBTAB(INCXKV,9,JCXKV).EQ.1 .AND. JPRIM.LE.0)
     &         JPRIM = JCXKV
 200     CONTINUE
         IF (JPRIM.GT.0) THEN
            CTZ = RBTAB(INCXKV,3,JPRIM)
            IF (CTZ.NE.0.0) THEN
               CALL SHS(28,0,FVVEC(1)-CTZ)
               IF (FVVEC(2).GT.0.)
     &            CALL SHS(29,0,(FVVEC(1)-CTZ)/FVVEC(2))
            ENDIF
         ENDIF
      ENDIF
      IF (JPRIM.LE.0) THEN
         NNFVNC = NNFVNC + 1
         IF (NDF.EQ.0) NNFSNC = NNFSNC + 1
      ENDIF

      NNVTX = NNVTX + 1
      NNOUT = NNOUT + NDF + 1

      IF (LRESID) CALL FVCHEK(FVVEC)

* Now do "secondary" vertices
 300  CONTINUE
      CALL FVZWM(INFTKR,NFTKR,ZNOM,.FALSE.,FVVEC,IFAIL)
      IF (IFAIL.EQ.0) THEN
         NVERT  = NVERT + 1
         INFTGR = NBANK('FTGR',0,2+4*NVERT)
         IF (INFTGR.LE.0) THEN
            CALL ERRLOG(513,'S:FVZFIT: Unable to extend FTGR bank')
            GOTO 9500
         ENDIF
         IW(INFTGR+2) = NVERT
         CALL UCOPY(FVVEC,IW(INDCR(INFTGR,1,NVERT)),4)
* Monitoring histograms
         CHISQ = RBTAB(INFTGR,3,NVERT)
         NDF   = IBTAB(INFTGR,4,NVERT)
         CALL SHS(41,0,FLOAT(NDF+1))
         CALL SHS(42,0,FVVEC(1))
         CALL SHS(43,0,FVVEC(2))
         IF (CHISQ.GT.0. .AND. NDF.GT.0) THEN
            CHPROB = PROB(CHISQ,NDF)
            CALL SHS(44,0,CHISQ/FLOAT(NDF))
            CALL SHS(45,0,CHPROB)
         ELSE
            CALL SHS(44,0,-1.)
            CALL SHS(45,0,-1.)
         ENDIF
         GOTO 300
      ENDIF

 9500 CONTINUE

* Truncate FTGX
      INFTGX = NLINK('FTGX',0)
      IF (INFTGX.GT.0) INFTGX = NBANK('FTGX',0,2+IW(INFTGX+2))

* Make sure work banks are dropped!
      CALL WDROP(IW,INFVWK)

      IF (LTRUTH) THEN
* Reset IPTYPE to 2
         DO 400 JFT=1,NFTKR-1,2
            IW(INDCR(INFTKR,7,JFT)) = 2
 400     CONTINUE
      ENDIF

*
* Some CT diagnostics
*

      INCJKT = NLINK('CJKT',0)
      INCXKV = NLINK('CTKV',0)
      IF (INCXKV.LE.0) INCXKV = NLINK('CJKV',0)
      IF (INCXKV.LE.0 .OR. INCJKT.LE.0) RETURN

      JPRIM = 0
      NCXKV = IW(INCXKV+2)
      DO 500 JCXKV=1,NCXKV
         IF (IBTAB(INCXKV,9,JCXKV).EQ.1 .AND. JPRIM.LE.0) JPRIM = JCXKV
 500  CONTINUE

      IF (JPRIM.LE.0) RETURN

      NZTRK = 0
      NCJKT = IW(INCJKT+2)
      DO 600 JCJKT=1,NCJKT
         IF (IBTAB(INCJKT,13,JCJKT).EQ.JPRIM) NZTRK = NZTRK + 1
 600  CONTINUE

      IF (NZTRK.EQ.1) NNSINC = NNSINC + 1
      IF (NZTRK.GT.0) NNVTXC = NNVTXC + 1

      IF (.NOT.LRESID) RETURN

      INSVX = NLINK('SVX ',0)
      IF (INSVX.LE.0) THEN
         CALL ERRLOG(514,'W:FVZFIT: No SVX bank')
         RETURN
      ENDIF

      JPSVX = 0
      NSVX = IW(INSVX+2)
      DO 700 JVX=NSVX,1,-1
         IF (IBTAB(INSVX,4,JVX).EQ.1) JPSVX = JVX
 700  CONTINUE

      IF (JPSVX.LE.0) THEN
         CALL ERRLOG(515,'W:FVZFIT: No primary vertex!')
         RETURN
      ENDIF

      DZ = RBTAB(INCXKV,3,JPRIM) - RBTAB(INSVX,3,JPSVX)
      CALL HFILL(100,DZ,0.,1.)

      RETURN

 8000 CONTINUE

* The FTGR bank must exist if possible
      INFTGR = NLINK('FTGR',0)
      IF (INFTGR.LE.0) THEN
         INFTGR = NBANK('FTGR',0,2)
         IF (INFTGR.GT.0) THEN
            IW(INFTGR+1) = 4
            IW(INFTGR+2) = 0
            CALL BLIST(IW,'E+','FTGR')
         ELSE
            CALL ERRLOG(516,'S:FVZFIT: Unable to create FTGR bank')
         ENDIF
      ENDIF
      INFTGX = NLINK('FTGX',0)
      IF (INFTGR.GT.0 .AND. INFTGX.LE.0) THEN
         INFTGX = NBANK('FTGX',0,2)
         IF (INFTGX.GT.0) THEN
            IW(INFTGX+1) = 1
            IW(INFTGX+2) = 0
            CALL BLIST(IW,'E+','FTGX')
         ELSE
            CALL ERRLOG(517,'S:FVZFIT: Unable to create FTGX bank')
         ENDIF
      ENDIF

      GOTO 9500

 9000 CONTINUE
      CALL ERRLOG(518,'S:FVZFIT: Work bank creation failed')

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  7.00/06 15/05/95  16.53.53  by  Stephen Burke
*CMZU:  5.03/00 29/10/94  17.23.11  by  Stephen Burke
*CMZU:  4.03/10 22/02/94  09.51.03  by  Gaby Raedel
*CMZ :  4.03/02 21/01/94  14.20.26  by  Gaby Raedel
*CMZU:  4.03/01 18/01/94  13.24.27  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.52  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.25  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVXTRP(FTVEC,ZNOM,LPRIM,Z0,WZ0,IERR)
*-----------------------------------------Updates 07/09/93-------
**: FVXTRP 40000 SB. Fix bug in xy vertex histos.
*-----------------------------------------Updates 26/07/93-------
**: FVXTRP 30907 SB. Change monitoring histograms.
**: FVXTRP 30907 RP. Farm changes.
*-----------------------------------------Updates 30/10/92-------
**: FVXTRP 30907 SB. Separate cut on # of radial and planar hits.
**: FVXTRP 30907 SB. New debug histograms and numbers.
*-----------------------------------------Updates 03/08/92-------
**: FVXTRP 30907 SB. Redundant calls to FKNORM removed.
*-----------------------------------------Updates 29/07/92-------
**: FVXTRP 30907 SB. Serious bugs fixed; xy histogram added.
*-----------------------------------------Updates 02/06/92-------
**: FVXTRP 30907 SB. Protect against divide by 0.
*-----------------------------------------Updates 06/05/92-------
**: FVXTRP 30907 SB. New deck to extrapolate tracks to vertex.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Extrapolate a forward track to the vertex region, and return z0    *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =        0 ; normal termination                         *
*   ->  IERR =      101 ; parameters not at track start (code error) *
*       IERR =        2 ; too few hits                               *
*       IERR =        3 ; initial z0 too large                       *
*       IERR =        4 ; momentum too small                         *
*       IERR =        5 ; too far from xy vertex (dca)               *
*       IERR =        6 ; too far from xy vertex (z0)                *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* The output parameters are undefined after an error.                *
*                                                                    *
* INPUT;                                                             *
*       FTVEC - FT-type (parameterisation 2) track vector            *
*       ZNOM  - the nominal z-vertex position                        *
*       LPRIM - .TRUE. if track is a primary (used for diagnostics)  *
*                                                                    *
* OUTPUT;                                                            *
*       Z0    - z0 of extrapolated track                             *
*       WZ0   - 1/(error on z0)**2                                   *
*                                                                    *
**********************************************************************

      DIMENSION FTVEC(21)
      LOGICAL LPRIM

      DIMENSION FTROT(16),CTV(5),CTC(5,5)
      DOUBLE PRECISION S1(5),C1(5,5),S2(5),C2(5,5),DTRAN(5,5),QMS(5,5)
      DOUBLE PRECISION Z,DZ

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEEP,FVSTEE.
      LOGICAL LTRUTH,LCUT,LRESID
      COMMON /FVSTEE/ IDIAG,LUN,LUNHB,LTRUTH,LCUT,LRESID
*KEEP,FVPAR.
      DOUBLE PRECISION ZWALL1,ZWALL2,RADLEN
      COMMON /FVPAR/ ZWALL1,ZWALL2,RADLEN,MINHTP,MINHTR,ZSQMAX
     &,              PMIN,DCAMAX,Z0MAX,CHIMAX
*KEEP,FVSCAL.
* Various counters
      PARAMETER (NSCAL=16)
      COMMON /FVSCAL/ NNEVNT,NNVTX,NNFTKR,NNXTR,NNFIT,NNOUT,NNSIN
     &,               NNFTKP,NNXTRP,NNFITP,NNOUTP,NNSINP
     &,               NNVTXC,NNSINC,NNFVNC,NNFSNC
*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.

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

      IERR = 0

      CALL UCOPY(FTVEC(19),NX,1)
      IF (NX.LE.0) THEN
         CALL ERRLOG(541,'F:FVXTRP: Not a starting parameterisation')
         IERR = 101
         RETURN
      ENDIF

*
* Initial selection criteria
*

      CALL UCOPY(FTVEC(20),NHIT,1)
      NRAD  = NHIT/(256*256*256)
      NPLAN = NHIT/(256*256) - NRAD*256
      IF (NPLAN.LT.MINHTP .OR. NRAD.LT.MINHTR) IERR = 2
*
* This is supposed to be a rough (straight line) estimate of the
* z0, for a quick initial cut (was bugged, hope it's right now)
*
      IF (FTVEC(3).GT.1.0E-10) THEN
         XCP = FTVEC(4)*COS(FTVEC(2))
         YSP = FTVEC(5)*SIN(FTVEC(2))
         Z0EST = FTVEC(6) - (XCP + YSP)/TAN(FTVEC(3))
         ZSQ = Z0EST*Z0EST
      ELSE
         ZSQ = 1.0E20
      ENDIF
      IF (ZSQ.GT.ZSQMAX) IERR = 3

      IF (LCUT) THEN
         IF (LPRIM) THEN
            CALL HFILL(201,FLOAT(NPLAN),0.,1.)
            CALL HFILL(203,FLOAT(NRAD),0.,1.)
            CALL HFILL(205,ZSQ,0.,1.)
         ELSE
            CALL HFILL(202,FLOAT(NPLAN),0.,1.)
            CALL HFILL(204,FLOAT(NRAD),0.,1.)
            CALL HFILL(206,ZSQ,0.,1.)
         ENDIF
      ENDIF

      IF (IERR.GT.0) RETURN

* Allow for a relative rotation/shift between CT and FT
      CALL KTROT(FTVEC,FTROT)

* Convert into KF internal format
      CALL FKETOI(FTROT,S1,C1)

      IF (ABS(S1(3)).GT.1.0D-15) THEN
         PMOM = ABS(1.0D0/S1(3))
      ELSE
         PMOM = SIGN(1.0D15,S1(3))
      ENDIF

      IF (LCUT .AND. LPRIM) CALL HFILL(207,PMOM,0.,1.)
      IF (LCUT .AND. .NOT.LPRIM) CALL HFILL(208,PMOM,0.,1.)

      IF (PMOM.LT.PMIN) THEN
         IERR = 4
         RETURN
      ENDIF

      NNXTR = NNXTR + 1
      IF (LPRIM) NNXTRP = NNXTRP + 1

* Swim to end wall
      Z  = FTROT(6)
      DZ = ZWALL2 - Z
      CALL FKTRAN(DZ,Z,S1,S2,DTRAN)
      CALL FKMUL(C1,DTRAN,C2)

* Allow for multiple scattering in the end wall
      DZ = ZWALL1 - ZWALL2
      CALL FKTRAN(DZ,ZWALL2,S2,S1,DTRAN)
      CALL FKMUL(C2,DTRAN,C1)
      CALL FKSCAT(DZ,S2,RADLEN,DTRAN,QMS)
      CALL FKQADD(C1,QMS)

* Swim to (notional) vertex
      DZ = ZNOM - ZWALL1
      CALL FKTRAN(DZ,ZWALL1,S1,S2,DTRAN)
      CALL FKMUL(C1,DTRAN,C2)
* Convert to external (IPTYPE 2) format
      CALL KTITOE(DBLE(ZNOM),S2,C2,S1,C1)
* Convert to IPTYPE 1 format
      CALL KTFTCT(S1,C1,DBLE(ZNOM),CTV,CTC)

      DCA = ABS(CTV(4))
      Z0 = CTV(5)
      IF (CTC(5,5).GT.0.) THEN
         WZ0 = 1./CTC(5,5)
      ELSE
         WZ0 = 0.
      ENDIF

      IF (LCUT) THEN
         IF (LPRIM) THEN
            CALL HFILL(209,DCA,0.,1.)
            CALL HFILL(211,Z0,0.,1.)
         ELSE
            CALL HFILL(210,DCA,0.,1.)
            CALL HFILL(212,Z0,0.,1.)
         ENDIF
      ENDIF

      IF (DCA.GT.DCAMAX) IERR = 5
      IF (ABS(Z0-ZNOM).GT.Z0MAX) IERR = 6

* Fill monitoring histograms
      CALL SHS(26,0,DCA)
      CALL SHS(27,0,Z0)

      IF (IERR.NE.0) RETURN

*
* Monitor the xy-vertex
*
      PHIBYT = 0.5
      ZBYT   = 15.
      IF (ABS(Z0-ZNOM).GT.2.0*ZBYT) RETURN
      DZ = Z0 - ZNOM
      CALL FKTRAN(DZ,DBLE(ZNOM),S2,S1,DTRAN)
      PHI = S1(5)
      IF (PHI.GT.PI) PHI = PHI - PI
      IF (PHI.GT.PIBY2-PHIBYT .AND. PHI.LT.PIBY2+PHIBYT) THEN
         IF (Z0-ZNOM.LT.-ZBYT) THEN
            CALL SHS(30,0,SNGL(S1(1)))
         ELSEIF (Z0-ZNOM.LT.ZBYT) THEN
            CALL SHS(31,0,SNGL(S1(1)))
         ELSE
            CALL SHS(32,0,SNGL(S1(1)))
         ENDIF
      ENDIF
      IF (PHI.LT.PHIBYT .OR. PHI.GT.PI-PHIBYT) THEN
         IF (Z0-ZNOM.LT.-ZBYT) THEN
            CALL SHS(33,0,SNGL(S1(2)))
         ELSEIF (Z0-ZNOM.LT.ZBYT) THEN
            CALL SHS(34,0,SNGL(S1(2)))
         ELSE
            CALL SHS(35,0,SNGL(S1(2)))
         ENDIF
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  18.00.35  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.52  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.25  by  Stephen Burke
*-- Author :    Stephen Burke   07/05/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVBKLK
*-----------------------------------------Updates 07/09/93-------
**: FVBKLK 40000 SB. Change scale on xy vertex histos.
*-----------------------------------------Updates 26/07/93-------
**: FVBKLK 30907 SB. Change monitoring histograms.
*-----------------------------------------Updates 02/06/93-------
**: FVBKLK 30907 SB. Vertex monitoring histograms added.
*-----------------------------------------Updates 29/07/92-------
**: FVBKLK 30907 SB. Binning changed, two new histograms.
*-----------------------------------------Updates 06/05/92-------
**: FVBKLK 30907 SB. New deck to book z-vertex monitoring histograms.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Book monitoring histograms for the forward z-vertex fit            *
*                                                                    *
**********************************************************************

      CALL BHS(21,0,50,0.,50.)
      CALL STEXT(21,4,'Vertex fitted forward tracks/event')

      CALL BHS(22,0,60,-120.,120.)
      CALL STEXT(22,4,'Fitted z-vertex')

      CALL BHS(23,0,60,0.,30.)
      CALL STEXT(23,4,'Error on z-vertex')

      CALL BHS(24,0,60,0.,12.)
      CALL STEXT(24,4,'Chi-squared/DOF of z-vertex fit')

      CALL BHS(25,0,50,0.,1.)
      CALL STEXT(25,4,'Chi-squared probability of z-vertex fit')

      CALL BHS(26,0,60,0.,6.)
      CALL STEXT(26,4,'Raw dca')

      CALL BHS(27,0,60,-120.,120.)
      CALL STEXT(27,4,'Raw z0')

      CALL BHS(28,0,60,-30.,30.)
      CALL STEXT(28,4,'z(FT) - z(CT)')

      CALL BHS(29,0,60,-12.,12.)
      CALL STEXT(29,4,'Delta-z/error')

      CALL BHS(30,0,60,-1.2,1.2)
      CALL STEXT(30,4,'x vertex (-z)')

      CALL BHS(31,0,60,-1.2,1.2)
      CALL STEXT(31,4,'x vertex (0)')

      CALL BHS(32,0,60,-1.2,1.2)
      CALL STEXT(32,4,'x vertex (+z)')

      CALL BHS(33,0,60,-1.2,1.2)
      CALL STEXT(33,4,'y vertex (-z)')

      CALL BHS(34,0,60,-1.2,1.2)
      CALL STEXT(34,4,'y vertex (0)')

      CALL BHS(35,0,60,-1.2,1.2)
      CALL STEXT(35,4,'y vertex (+z)')

      CALL BHS(41,0,50,0.,50.)
      CALL STEXT(41,4,'Tracks/event for secondary vertices')

      CALL BHS(42,0,60,-120.,120.)
      CALL STEXT(42,4,'Secondary z-vertex')

      CALL BHS(43,0,60,0.,30.)
      CALL STEXT(43,4,'Error on secondary z-vertex')

      CALL BHS(44,0,60,0.,12.)
      CALL STEXT(44,4,'Chi-squared/DOF for secondary z-vertex')

      CALL BHS(45,0,50,0.,1.)
      CALL STEXT(45,4,'Chi-squared probability for secondary z-vertex')

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  8.03/00 03/06/96  15.02.23  by  Katharina Mueller
*CMZ :  4.00/00 07/09/93  17.57.52  by  Stephen Burke
*-- Author : Stephen Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTQUIC(NPCT,NRCT)
*-----------------------------------------Updates 07/09/93-------
**: FTQUIC 40000 SB. New deck to give a guess at no. of tracks.
*-----------------------------------------Updates----------------
***************************************************************
*                                                             *
* Quick pattern recognition in the forward tracker            *
*                                                             *
* Input:                                                      *
*   MINR - minimum number of hits to form a radial segment    *
*                                                             *
* Output:                                                     *
*   NPCT - number of candidate tracks in planar supermodules  *
*   NRCT - number of candidate tracks in radial supermodules  *
*                                                             *
*   NPCT and NRCT are arrays (0:2) indexed by supermodule no. *
*                                                             *
***************************************************************

*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.

      CHARACTER*8 VERSQQ
      DIMENSION NPPOSS(0:8),NPCT(0:2),NRCT(0:2)

*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

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

* Module steering by MODULS
*KEEP,VERSQQ.
      VERSQQ = ' 8.07/02'
      IVERSQ =  80702
*KEND.
      CALL MODULS('FTQUIC',IVERSQ,'FRREFRPE')

* Get right bank versions for MC events...
      CALL FSETMC

      IF(BEGRUN) THEN
* Rebook B16 input bank formats for the farm
       CALL BKFMT('FRRE','B16')
       CALL BKFMT('FRPE','B16')
       CALL SETREC
       CALL FPTINT
      END IF

      IF (REVENT) THEN
         CALL FPLOCO
         INFPHC = NLINK('FPHC',0)
         IF (INFPHC.GT.0) THEN
            NFPHC  = IW(INFPHC+2)
            CALL VZERO(NPPOSS(0),9)
            DO 200 JCELL=0,NFPHC-1,4
               NMIN1 = 999
               NMIN2 = 999
               DO 100 JWIRE=1,4
                  NHIT = IBTAB(INFPHC,1,JCELL+JWIRE)
                  IF (NHIT.LT.NMIN2) THEN
                     NMIN1 = NMIN2
                     NMIN2 = NHIT
                  ELSEIF (NHIT.LT.NMIN1) THEN
                     NMIN1 = NHIT
                  ENDIF
 100           CONTINUE
               IF (NMIN1.EQ.999) NMIN1 = NMIN2
               IMOD = IPSMD(JCELL)
               NPPOSS(IMOD) = NPPOSS(IMOD) + NMIN1
 200        CONTINUE
            NPCT(0) = MIN(NPPOSS(0),NPPOSS(1),NPPOSS(2))
            NPCT(1) = MIN(NPPOSS(3),NPPOSS(4),NPPOSS(5))
            NPCT(2) = MIN(NPPOSS(6),NPPOSS(7),NPPOSS(8))
         ENDIF
         CALL FRLOCO
         INFRHC = NLINK('FRHC',0)
         IF (INFRHC.GT.0) THEN
            NFRHC  = IW(INFRHC+2)
            CALL VZERO(NRCT(0),3)
            DO 400 JCELL=0,NFRHC-1,12
               NMAX1 = 0
               NMAX2 = 0
               DO 300 JWIRE=1,12
                  NHIT = IBTAB(INFRHC,1,JCELL+JWIRE)
                  IF (NHIT.GT.NMAX2) THEN
                     NMAX1 = NMAX2
                     NMAX2 = NHIT
                  ELSEIF (NHIT.GT.NMAX1) THEN
                     NMAX1 = NHIT
                  ENDIF
 300           CONTINUE
               IF (NMAX1.EQ.0) NMAX1 = NMAX2
               IMOD = IRMOD(JCELL)
               NRCT(IMOD) = NRCT(IMOD) + NMAX1
 400        CONTINUE
         ENDIF
* Clean up
C         CALL BGARB(IW)
C         CALL WGARB(IW)
      ENDIF

      CALL FRSTMC
      CALL MODULF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  5.00/07 01/06/94  09.56.49  by  R. Gerhards
*CMZU:  4.00/08 11/11/93  11.15.52  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.52  by  Stephen Burke
*-- Author : Stephen J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPOKER
**: FPOKER 40000 SM. New routine for calibration checking.
**----------------------------------------------------------------------
*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

      COMMON/FPKSTA/ITOTAN,IRUNLA

*     COMMONs for planar found tracks
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)

*     Pointers to  radials associated with planar tracks
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)


*     Tan of 1/2 wedge angle...
      PARAMETER (TANWED=0.065543)

*     Binning parameters for histograms...
      PARAMETER (DPMAX=5.0)
      PARAMETER (NBIN=200)
      PARAMETER (NBLOR=40)
      PARAMETER (BINTOD=2.0*DPMAX/NBIN)
      PARAMETER (BINLOR=2.0*DPMAX/NBLOR)

      PARAMETER (MXSIDE=1)

      LOGICAL FIRST/.TRUE./
      DATA RMIN/25.0/
      DATA RMAX/99.0/
      DATA RMAXL/55.0/

*     Statement functions for TABLE access...
*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(FIRST)THEN
*       Book LOOK histograms
        FIRST = .FALSE.
        ITOTAN = 0
        ITOTHT = 0

*       Histograms for t-to-d...
        DO KBIN = 1, NBIN
         DLO       = -DPMAX + (KBIN-1) * BINTOD
         DHI       = DLO + BINTOD
         DO KSIDE = 1, MXSIDE
          KHIS1 = KBIN + KSIDE*2000
          KHIS2 = KBIN + KSIDE*2000 + 1000
          CALL BHS(KHIS1, 0, 200, -DPMAX, DPMAX)
          CALL BHS(KHIS2, 0,  20, DLO, DHI)
         ENDDO
        ENDDO

*       Histograms for Lorentz angle...
        DO KBIN = 1, NBLOR
         DLO       = -DPMAX + (KBIN-1) * BINLOR
         DHI       = DLO + BINLOR
         KHIS3     = KBIN + 10000
         KHIS4     = KBIN + 11000
         CALL BHS(KHIS3, 0, 100, -50., 50.)
         CALL BHS(KHIS4, 0,  20, DLO, DHI)
        ENDDO

      ENDIF

      ITOTAN = ITOTAN + 1
      IRUNLA = NCCRUN

*     NPP is number of planar-based tracks...
      IF (NPP.EQ.0)RETURN

*     Hit data...
      INFRLC = MLINK(IW,'FRLC',0)
      IF(INFRLC .EQ. 0) RETURN
*     Auxiliary hit data...
      INFAUX = MLINK(IW,'FAUX',0)
      IF(INFAUX .EQ. 0) RETURN

*     Loop over planar-based tracks...
      DO 700 I=1,NPP


*     Which PLANAR supermodules have the hits on the track. Actually
*     always have a full segments worth (9-12 hits) or none at all
*     so this is overkill!
      IP1=0
      IP2=0
      IP3=0
      DO 720 IP=1,36
       J=IPP(IP,I)
       IF(J.EQ.0)GOTO720
       IF(IP.GE.01.AND.IP.LE.12)IP1=1
       IF(IP.GE.13.AND.IP.LE.24)IP2=1
       IF(IP.GE.25.AND.IP.LE.36)IP3=1
 720  CONTINUE


*     Loop over the radial hits on this track. Only mods 0 and 1
      DO 710 IP=1,24
*     Radial hit on this track?
      J=IRR(IP,I)
      IF(J.EQ.0)GOTO710

*     Accept 'sandwich' configurations only...
      IF( ( (IP.LE.12).AND.(IP1*IP2.NE.0) ) .OR.
     +    ( (IP.GT.12).AND.(IP2*IP3.NE.0) ) ) THEN

*       Get Phi and R at this wire plane from Phi-z R-z fit parameters.
        PHI = PSSS(I)*ZP(IP)+PISS(I)
        RAD = RSSS(I)*ZP(IP)+RISS(I)

*       Limit radius range.
        IF(RAD.GE.RMIN .AND. RAD .LT. RMAX) THEN

*         Predicted drift...corrected for stagger.
          DRP = RAD * SIN(PHI-WW(J,IP)) - DWS(J,IP)

*         Predicted radius along wire direction (if no Lorenz angle)
          RRP = RAD * COS(PHI-WW(J,IP))

*         Get max allowed drift (Position of cathode plane less a
*         3mm tolerance)...
          DRMAX  = SQRT(RAD**2 - DRP**2) * TANWED   - 0.3
*         ...and cut out region near cathode.
          IF(ABS(DRP) .LE. DRMAX)  THEN

*           Drift time, corrected for T0 and radius and pre-scaled
*           by approx <v> from F0R8.
            KDIG    = IPFRRE( J,IP)
            DTSCA   = RBTAB(INFAUX, 1, KDIG) * SRR(IP,I)

*           ...and radius of hit at wire from Charge division
            RRM     = RBTAB(INFRLC, 4, KDIG)

*           (Predicted radius at wire if no Lorentz angle) - (measured
*           radius)
            DRR     = RRP - RRM
*           ...slope of DRR vs. predicted drift is tan(alpha).


*           Fill histograms of slices in predicted drift.
            KBIN   = 1 + IFIX( (DRP + DPMAX) / BINTOD)
            KBINL  = 1 + IFIX( (DRP + DPMAX) / BINLOR)

            IF (KBIN.GE.1 .AND.KBIN.LE.NBIN) THEN
              ITOTHT = ITOTHT + 1
              CALL SHS(2000+KBIN, 0, DTSCA)
              CALL SHS(3000+KBIN, 0, DRP)
            ENDIF

            IF (KBINL.GE.1 .AND. KBINL.LE.NBLOR) THEN
              CALL SHS(10000+KBINL, 0, DRR)
              CALL SHS(11000+KBINL, 0, DRP)
            ENDIF

          ENDIF

        ENDIF

      ENDIF
*---------------

 710  CONTINUE
*     ...end loop over radial hits

 700  CONTINUE
*     ...end loop over planar based tracks.

*     Write(6,*) ' Fpoker hits', ITOTHT

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  4.01/01 10/12/93  15.54.31  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.53  by  Stephen Burke
*-- Author : Stephen J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPKANL
*D: FPKANL.......SM. Add options for left/right separation
**: FPKANL 40000 SM. New routine for calibration checking.
**----------------------------------------------------------------------
*     Does not work in multi-processor environment.
*
*
      PARAMETER (NBIN=200)
      PARAMETER (NBLOR=40)
      PARAMETER (MXSIDE=1)
*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/FPKSTA/ITOTAN,IRUNLA

      DIMENSION CVEC(6)
      DIMENSION IOUT(4)
      DIMENSION FOUT(5)
      DIMENSION PDAT(5,5)
      DIMENSION PAR(2), PMIN(2), PMAX(2), EPAR(2), COV(3)
      DIMENSION XST(4), YST(4)
      DIMENSION AVEC(8)
      DIMENSION NPEAK(3)
      DIMENSION NEMAX(3)
      LOGICAL EX

      CHARACTER*8  UID
      CHARACTER*23 DSNINQ  /'/H1TFWD.H01.FPOKER.SUML'/
      CHARACTER*22 STOREL  /'H1TFWD.H01.FPOKER.SUML'/
      CHARACTER*72 PARMFO
     &                 /'OPEN FILE2 UNIT=2 FILE="H1TFWD.H01.FPOKER.SUML"
     & ACTION=MODIFY RECL=23400'/
      CHARACTER*72 PARMFN
     &                 /'OPEN FILE2 UNIT=2 FILE="H1TFWD.H01.FPOKER.SUML"
     & ACTION=WRITE  RECL=23400'/

      CHARACTER*8  NAMES1(8),NAMES2(8),NAMES3(8)
      DATA NEMAX/20, 10, 10/
      DATA LOMAX/20/

      DATA NAMES1/
     +    'Run_numb','Events  ',
     +    'Vmean   ','dVmean  ',
     +    'Vf0r8   ','dVf0r8  ',
     +    'intercep','dinterc '/
      DATA NAMES2/
     +    'Vplus   ','dVplus  ',
     +    'Splus   ','dSplus  ',
     +    'Intplus ','dIplus  ',
     +    'Nopplus ','Chiplus '/
      DATA NAMES3/
     +    'Vminus  ','dVminus ',
     +    'Sminus  ','dSminus ',
     +    'Intminus','dIminus',
     +    'Nopminus','Chiminus'/
*

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

      CALL SAREA('FPOKE', 0)
*     Book histograms...
      Do KSIDE = 1, MXSIDE
       CALL BVEC(KSIDE*100, 0, 6)
       CALL STEXT(KSIDE*100, 4,'D-time (scaled) vs. Dist(predicted)')
      Enddo

      CALL BVEC( 12000, 0, 6)
      CALL STEXT(12000, 4,'DeltaR vs. Drift predicted)')

*     Analyse the data.
*     ------- --- ----
*     Analysis of histogram results.
      Write(6,*) ' Fpkanl >> Total Events:', ITOTAN

*     Do peakparm analysis of the pred drift histograms...

      DO KSIDE = 1, MXSIDE
      NPEAK(KSIDE) = 0
      DO KBIN = 1, NBIN

       DLO       = -5. + (KBIN-1) * 0.05
       DHI       = DLO + 0.05

       JHIS1 = 2000 + KBIN + (KSIDE-1)*2000
       JHIS2 = 3000 + KBIN + (KSIDE-1)*2000

*      Get average predicted drift distance in the slice...
       CALL GHSTAT('HS', JHIS2, 0, NENT, SUMW, RNEFF, XST, YST)
       DMAV = XST(3)
       IF(NENT .GT. NEMAX(KSIDE)) THEN
       CALL HPEAK('HS',JHIS1, 0, NPK, PDAT)

         IF (NPK .GE. 1) THEN
           NPEAK(KSIDE) = NPEAK(KSIDE) + 1
*          peak position and error on...
           PPOS  = PDAT(1,1)
           PERR  = ABS(PDAT(2,1))
           PINT  = ABS(PDAT(3,1))
*          comment out next line for 'full width errors'
           PERR  = 2.0*(PERR  / SQRT(PINT))

*          Hence Drift time vs. predicted  drift distance:-

           CVEC(1) = DMAV
           CVEC(2) = PPOS
           CVEC(3) = DMAV - DLO
           CVEC(4) = DHI  - DMAV
           CVEC(5) = PERR
           CVEC(6) = PERR
           CALL SVEC(KSIDE*100, 0, CVEC)
         ENDIF

       ENDIF

*      Now purge figures - no longer needed.
       CALL PURGEF(JHIS1)
       CALL PURGEF(JHIS2)

      ENDDO

      ENDDO



*     Do peakparm analysis of the Lorentz Angle Histograms...

      DO KBIN = 1, NBLOR

       DLO       = -5. + (KBIN-1) * 0.25
       DHI       = DLO + 0.25

       JHIS1 = 10000 + KBIN
       JHIS2 = 11000 + KBIN

*      Get average predicted drift distance in the slice...
       CALL GHSTAT('HS', JHIS2, 0, NENT, SUMW, RNEFF, XST, YST)
       DMAV = XST(3)
       IF(NENT .GT. LOMAX) THEN
       CALL HPEAK('HS',JHIS1, 0, NPK, PDAT)

         IF (NPK .GE. 1) THEN
*          peak position and error on...
           PPOS  = PDAT(1,1)
           PERR  = ABS(PDAT(2,1))
           PINT  = ABS(PDAT(3,1))
*          comment out next line for 'full width errors'
           PERR  = 2.0*(PERR  / SQRT(PINT))

*          Hence Delta R vs. predicted drift distance:-

           CVEC(1) = DMAV
           CVEC(2) = PPOS
           CVEC(3) = DMAV - DLO
           CVEC(4) = DHI  - DMAV
           CVEC(5) = PERR
           CVEC(6) = PERR
           CALL SVEC(12000, 0, CVEC)
         ENDIF

       ENDIF

*      Now purge figures - no longer needed.
       CALL PURGEF(JHIS1)
       CALL PURGEF(JHIS2)

      ENDDO

*     Extraction of calibration data. Not for online at moment...

999   RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZU:  5.03/00 22/04/94  16.07.46  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   22/04/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      FUNCTION FRDT2D(TS, V0, V1, S1)
*
*     The time-to-distance function.
*     TS is time in ticks scaled by average drift velocity in cm/tick
*     V0, V1 (corrected) velocities at wire and 1st knot point
*     S1 distance in cm (corrected) to 1st knot point
*
*     Return drift distance in cm.
*
      IF( TS .LT. 0. ) THEN

       DRIFT = V0*TS

      ELSE

*      Time taken to arrive at first knot point...
       TAU    =   S1 / (V1-V0)
       T1     =   TAU * ALOG( V1 / V0 )

       TS = ABS(TS)
       IF(TS .LE. T1) THEN
        DRIFT = V0*TAU*(EXP(TS/TAU) - 1.0)
       ELSE
        DRIFT = S1 + V1*(TS - T1)
       ENDIF

      ENDIF

      FRDT2D = DRIFT
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.11  by  Stephen Burke
*CMZ :  7.09/08 05/03/96  21.32.19  by  Stephen Burke
*CMZU:  7.03/08 12/12/95  14.32.37  by  Stephen Burke
*-- Author :    Stephen Burke   12/12/95
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFIX(JSTART,JSTOP)
**********************************************************************
*                                                                    *
* Deal with two pairs of cells which were swapped over for the '95   *
* run by re-writing the FPLC and FPHC banks.                         *
*                                                                    *
* In orientation 5 cell 20 is read out as cell 22, and cell 22 is    *
* read out as 20. Cell 21 is read out as 23; the real 23 is lost.    *
*                                                                    *
**********************************************************************

      COMMON /FPFIXX/ INWORK

*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*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.

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

* Channels were swapped in '95, probably '94, probably '96, ...
      IF (MONTE .OR. NCCRUN.LT.70000) RETURN

      INFPLC = NLINK('FPLC',0)
      IF (INFPLC.LE.0) RETURN

      NFPLC  = IW(INFPLC+2)
      J1     = MIN(MAX(1,JSTART),NFPLC)
      J2     = MAX(MIN(NFPLC,JSTOP),1)

      JFIRST = 0
      JF20   = 0
      JF21   = 0
      JF22   = 0
      JF23   = 0
      JLAST  = 0
      JL20   = -1
      JL21   = -1
      JL22   = -1
      JL23   = -1
      DO 100 JFPLC=J1,J2
* Cell number = 4*32*3*ISM + 4*32*IORI + 4*IWCELL + IWIRE
         ICELL = IBTAB(INFPLC,1,JFPLC)
         IORI  = ICELL/128
         IF (IORI.NE.5) GOTO 100
         IWCELL = MOD(ICELL,128)/4
         IF (IWCELL.LT.20 .OR. IWCELL.GT.23) GOTO 100
         IF (JFIRST.LE.0) JFIRST = JFPLC
         IF (IWCELL.EQ.20 .AND. JF20.LE.0) JF20 = JFPLC
         IF (IWCELL.EQ.21 .AND. JF21.LE.0) JF21 = JFPLC
         IF (IWCELL.EQ.22 .AND. JF22.LE.0) JF22 = JFPLC
         IF (IWCELL.EQ.23 .AND. JF23.LE.0) JF23 = JFPLC
         JLAST = JFPLC
         IF (IWCELL.EQ.20) JL20 = JFPLC
         IF (IWCELL.EQ.21) JL21 = JFPLC
         IF (IWCELL.EQ.22) JL22 = JFPLC
         IF (IWCELL.EQ.23) JL23 = JFPLC
 100  CONTINUE

      IF (JLAST.LE.0) RETURN

      NCFPLC = IW(INFPLC+1)
      NCOPY  = NCFPLC*(JLAST-JFIRST+1)
      JPTR   = INDCR(INFPLC,1,JFIRST)
      INWORK = 0
      CALL WBANK(IW,INWORK,NCOPY,*9000)
      CALL UCOPY(IW(JPTR),IW(INWORK+1),NCOPY)

      DO JFPLC=JF22,JL22
         JOFF = NCFPLC*(JFPLC - JFIRST) + 1
         CALL UCOPY(IW(INWORK+JOFF),IW(JPTR),NCFPLC)
         IW(JPTR) = IW(JPTR) - 8
         JPTR     = JPTR + NCFPLC
      END DO

      DO JFPLC=JF23,JL23
         JOFF = NCFPLC*(JFPLC - JFIRST) + 1
         CALL UCOPY(IW(INWORK+JOFF),IW(JPTR),NCFPLC)
         IW(JPTR) = IW(JPTR) - 8
         JPTR     = JPTR + NCFPLC
      END DO

      DO JFPLC=JF20,JL20
         JOFF = NCFPLC*(JFPLC - JFIRST) + 1
         CALL UCOPY(IW(INWORK+JOFF),IW(JPTR),NCFPLC)
         IW(JPTR) = IW(JPTR) + 8
         JPTR     = JPTR + NCFPLC
      END DO

      DO JFPLC=JF21,JL21
         JOFF = NCFPLC*(JFPLC - JFIRST) + 1
         CALL UCOPY(IW(INWORK+JOFF),IW(JPTR),NCFPLC)
         IW(JPTR) = IW(JPTR) + 8
         JPTR     = JPTR + NCFPLC
      END DO

      CALL WDROP(IW,INWORK)

      INFPHC = NLINK('FPHC',0)
      IF (INFPHC.LE.0) RETURN

      CALL VZERO(IW(INDCR(INFPHC,1,721)),32)

      ICLOLD = -1
      DO JFPLC=JFIRST,JLAST
         ICELL = IBTAB(INFPLC,1,JFPLC)
         IF (ICELL.NE.ICLOLD) THEN
           IW(INDCR(INFPHC,1,ICELL+1)) = 1
           IW(INDCR(INFPHC,2,ICELL+1)) = JFPLC
           ICLOLD = ICELL
         ELSE
           IW(INDCR(INFPHC,1,ICELL+1)) = IBTAB(INFPHC,1,ICELL+1) + 1
         ENDIF
      END DO

 9000 CONTINUE

      RETURN
      END
*CMZ :  8.07/00 21/11/96  21.10.00  by  Stephen Burke
*CMZ :  8.06/00 13/11/96  18.17.44  by  Stephen Burke
*-- Author :    Girish Patel   11/11/96
      SUBROUTINE FTRNDB(NRUN)
*
      DIMENSION BVEC(8)
      CHARACTER*8  NAMED(8)
      DATA NAMED/'Run_numb',
     +           'Pv      ','Pt0     ','Rv      ','Rt0     ',
     +           'Alor    ','TanAlor ','Alordeg '/
      LOGICAL FIRST /.FALSE./

      CALL SAREA('FTDSGI',0)

      IF(FIRST) THEN
        FIRST=.FALSE.
        CALL BNT( 5, 0,     8, NAMED)
      ENDIF
*
      BVEC(1) = NRUN

      CALL FDBGET(NRUN,PV,PT0,RV,RT0,IRET)
      IF(IRET.EQ.0) THEN
        BVEC(2) = PV
        BVEC(3) = PT0
        BVEC(4) = RV
        BVEC(5) = RT0
      ELSE
        WRITE(6,*) ' FTRNDB>> FDBGET failed for run ',NRUN
        BVEC(2) = 0.0
        BVEC(3) = 0.0
        BVEC(4) = 0.0
        BVEC(5) = 0.0
      ENDIF

      CALL FDBGTL(NRUN,ALOR,IRET)
      IF(IRET.EQ.0) THEN
        BVEC(6) = ALOR
        BVEC(7) = TAN(ALOR)
        BVEC(8) = ALOR*57.29577951
      ELSE
        WRITE(6,*) ' FTRNDB>> FDBGTL failed for run ',NRUN
        BVEC(6) = 0.0
        BVEC(7) = 0.0
        BVEC(8) = 0.0
      ENDIF

      CALL SVEC(5,0,BVEC)

      CALL SAREA('FTREC',1)

      RETURN
      END
*CMZ :  8.06/00 11/11/96  16.45.19  by  Stephen Burke
*-- Author :    Girish Patel   11/11/96
      SUBROUTINE FDBGET(IRUN,PV,PT0,RV,RT0,IRET)
*======================================================================
*     Input:  IRUN   ep-run number
*             F0P8,F0R8,FCP1 banks from the database
*     Output: PV     Planar Drift velocity
*             PT0    Planar T0
*             RV     Radial Drift Velocity
*             RT0    Radial T0
*
*======================================================================
*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,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.
      IROLD  = NCCRUN
      NCCRUN = IRUN
      IRET=1
      INF0R8=IABS(MDB('F0R8'))
      INF0P8=IABS(MDB('F0P8'))
      INFCP1=IABS(MDB('FCP1'))
      NCCRUN = IROLD
      IF(INF0R8.GT.0.and.INF0P8.GT.0.and.INFCP1.GT.0) THEN
         PT0 = RW(INF0P8+3)*0.1923077
         PV  = RW(INFCP1+4)
         RT0 = RW(INF0R8+3)*0.1923077
         IF(IRUN.LT.92800) THEN
           RV  = RW(INF0R8+6)/0.0000211475
         ELSE
           RV  = RW(INF0R8+6)/0.0000210633
         ENDIF
         IRET = 0
      ENDIF
      RETURN
      END
*CMZ :  8.06/00 11/11/96  16.45.19  by  Stephen Burke
*-- Author :    Girish Patel   11/11/96
      SUBROUTINE FDBGTL(IRUN,ALOR,IRET)
*======================================================================
*     Input:  IRUN   ep-run number
*             F0P8
*     Output: ALOR   Lorentz angle in radians
*
*======================================================================
*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,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.
      IROLD  = NCCRUN
      NCCRUN = IRUN
      IRET=1
      INF0R8=IABS(MDB('F0R8'))
      NCCRUN = IROLD
      IF(INF0R8.GT.0) THEN
         ALOR= RW(INF0R8+13)
         IRET = 0
      ENDIF
      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.05/00 26/09/96  22.46.35  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.02/11 12/10/95  12.53.15  by  Stephen Burke
*CMZU:  4.01/01 10/12/93  15.51.52  by  Stephen J. Maxfield
*CMZU:  4.00/08 19/11/93  15.26.46  by  Stephen J. Maxfield
*CMZU:  3.09/07 26/07/93  10.00.26  by  Stephen Burke
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Finds radial line segments on planar-based tracks
*
*HTMLI     : Describe the Input variables to the routine
*
* Planar-based  tracks:
*          NPP tracks
*          Hits                    :- IRR/SRR IPP/SPP
*          Segments radials/planars:- LRR LPP
*          Parameters(phi',phi0)   :- PSSS,PISS
*          Parameters(R',R0)       :- RSSS,RISS
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*
*
*HTMLO     : Describe the Output of the routine
*
*          Hits /drift sign        :- IRR/SRR
*          Segments radials        :- LRR
*          Used flag               :- IRUSED
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPKPKR
*D: FPLPKR.......SM. Fix small bug.
**: FPKPKR 30907 RP. Farm changes.
**----------------------------------------------------------------------
*
*
*     Searches for closest segment to track K in the R-Phi
*     direction which is sufficiently close in the radial direction.
*     Separation is Rmean*delta-phi, where Rmean is
*     mean of planar segment and radial predicted R's and delta-phi
*     is separation in Phi.
*
*

*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


*     Common for segment numbers...

*     COMMON FOR PLANAR PATREC  ...
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
C     POINTER TO RADIAL ASSOCIATED WITH NPP'TH PLANAR
      COMMON/FPPTR/LR(3,100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
C     COMMON FOR RADIALS ASSOCIATED WITH PLANAR TRACKS
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
      COMMON/FTRSUS/IRUSED(3,100)
*     Local arrays...
      DIMENSION RSEG(4),PSEG(4),XX(40),YY(40),YYY(40)
      PARAMETER(PI2=6.2831853)
      data istart /0/

*     ESTABLISH CUT VALUES
C     ALLOW A 1/2  CM ROAD IN DRIFT
      DRPCUT=0.5
C     VERY GENEROUS RADIUS CUT   10.0 cm
      DRCUT=10.0
c     rad/cm
      phicut=0.002
c     slope cut in drift
      atcut=0.05
c
      if(istart.eq.0)then
      istart=1
      write(*,*)' fpkpkr cuts: hardwired '
      write(*,*)' drpcut =  0.5 cm '
      write(*,*)' drcut  = 10.0 cm '
      write(*,*)' phicut =  0.002 rad/cm '
      write(*,*)' atcut  =  0.050  '
      endif
C
C
C---   Loop over supermodules
C

      DO 10 ISM = 1,3
C
C---  CALCULATE PLANAR PREDICTION FOR SEGMENT IN THIS SUPERMODULE
C
      Z = ZP( 4 + (ISM -1)*12 )
      ZMM=Z
 200  nadd=0
      kmin=0
      ISMIN = 0
      DRMIN = 1000000.0
      DRM   = 1000000.0

      do 100 k=1,npp
      if(lrr(ism,k).ne.0)goto100

C
C---  RR AND PHI CALCULATED FOR THIS Z AS PREDICTED BY PLANARS
C
      RR  = RSSS(K)*Z + RISS(K)
      RRAD= RR
      PHI = PSSS(K)*Z + PISS(K)
      IF(PHI.LT.0.0) PHI = PHI + PI2
C     WRITE(*,*)' PRED PHI,R ',PHI,RR

*
*---- Loop over the Radial Segments..
*
      DO 20 IP = 1,NTRAKS(ISM)
*     check FTFIT has not killed segment
      if(chsq(ip,ism).gt.1000.)goto20
*
*     Check that this segment hasn't been used already...
*
      IF(IRUSED(ISM, IP) .NE. 0)GO TO 20

*     R AND PHI FOR RADIAL SEGMENT
*     PRINT 3000,ISM,IP,PHI,PHIPLA
      PHIPLA   = PHZL(IP,ISM)+ZMM * PCOSL(IP,ISM)
      RPL      = RZI(IP,ISM)  +  ZMM * PSINL(IP,ISM)

CIOS  PHIPLA = AMOD(PHIPLA,PI2)
      IF(PHIPLA.LT.0.0) PHIPLA = PHIPLA + PI2

*     Believe the radial segment prediction in the 'drift' direction
*     only. More-or-less ignore rad radius...
      RMEAN = RPL
      DELP  = PHIPLA - PHI
      IF(DELP .GT. 6.0     ) THEN
           DELP = DELP -PI2
      ELSEIF(DELP .LT. -6.0     ) THEN
           DELP = DELP +PI2
      ENDIF

      DRPHI = RMEAN*(DELP)
      DR    = RPL - RRAD
      DRPHI = ABS(DRPHI)
      DR    = ABS(DR)

C     CHECK IN CORRECT PHI-REGION ***  9/12/93   ****
      IF(DRPHI.GT.2.*DRPCUT)GOTO20

*   DIAGNOSTIC Plots...
C      PLOT DISTANCE OF RADIAL POINTS FROM PREDICTION
      DDIST=0.
      FNN=0.
      ll=0
      DO 21 IPL=1,12
      JPL=IPL+(ISM-1)*12
      NP=IRPT(IPL,IP,ISM)
      IF(NP.NE.0)THEN
      RRt=RSSS(K)*ZP(JPL)+RISS(K)
      PHIt=PSSS(K)*ZP(JPL)+PISS(K)
      IF(PHIt.LT.0.0)PHIt=PHIt+PI2
      DRE=RRt*SIN(PHIt-WW(NP,JPL))
      DRMM=SDRFT(IPL,IP,ISM)*DRI(NP,JPL)+DWS(NP,JPL)
      CALL SHS(701+ISM,0.,DRE-DRMM)
      DDIST=DDIST+(DRE-DRMM)
      FNN=FNN+1.
      ll=ll+1
      xx(ll)=zp(jpl)
      yy(ll)=dre-drmm
      ENDIF
 21   CONTINUE
C     REPLACE DRPHI
      IF(FNN.NE.0.)DRPHI=ABS(DDIST/FNN)
      CALL FTLFT(XX,YY,LL,0,AT,BT,EE)

c     relative slope cut
      if(abs(at).gt.atcut)goto20

      if(drphi.lt.drpcut)then
c     d(phi)/dz diff plot
      call shs(740,0,pcosl(ip,ism)-psss(k))
      endif
c     cut on d(phi)/dz  - hard wired
      if(abs(pcosl(ip,ism)-psss(k)).gt.phicut)goto20

      IF(DRPHI .LT. DRMIN) THEN
        CALL SHS(701   , 0, DR )
      IF(DR    .LT. DRCUT) THEN
C   END ADDITION

        DRMIN = DRPHI
        ISMIN = IP
        kmin  = k
        DRM   = DR
C     WRITE(*,*)' DRMIN,ISMIN,DRM ',DRMIN,ISMIN,DRM
      ENDIF
      ENDIF


C     PRINT 3000,ISM,IP,PHI,PHIPLA,RPL,DELP,DRPHI
 3000 FORMAT(' MOD,SEG,PHIP,PHIR,R ',2I3,2F10.4,F6.1,F10.4,F6.1)
C
C---  End of loop over radial segments for supermodule
C
   20 CONTINUE
c     loop over tracks
 100  continue
      k=kmin


*  Diagnostics
      IF(NTRAKS(ISM).NE.0)CALL SHS(730+ISM,0,FLOAT(NTRAKS(ISM))+0.01)

C      PLOT DISTANCE OF RADIAL POINTS FROM PREDICTION
      IF(ISMIN.NE.0)THEN
        CALL SHS(700, 0, DRMIN)
      ENDIF
*  Diagnostics End.

C
C---  Build list of radial hits and mark segment and hits used
C


      IF(ISMIN .NE. 0) THEN
      IF(DRMIN .LT. DRPCUT) THEN


      IP=ISMIN

      IP1=0
      IP2=0
      IP3=0
      DO  Ii=1,36
      IF(Ii.Ge.01.AND.Ii.LE.12.AND.IPP(Ii,K).NE.0)IP1=1
      IF(Ii.Gt.12.AND.Ii.LE.24.AND.IPP(Ii,K).NE.0)IP2=1
      IF(Ii.GT.24.AND.Ii.LE.36.AND.IPP(Ii,K).NE.0)IP3=1
      end do

      SME=0.
      SEE=0.
      SSS=0.
      LL=0
      DO 22 IPL=1,12
      JPL=IPL+(ISM-1)*12
      NP=IRPT(IPL,IP,ISM)
      IF(NP.NE.0)THEN
      LL=LL+1
      RR=RSSS(K)*ZP(JPL)+RISS(K)
      PHI=PSSS(K)*ZP(JPL)+PISS(K)

      IF(LL.EQ.3)THEN
C     EXPECTED D(DRIFT)/DZ
      DDDZ=RSSS(K)*SIN(PHI-WW(NP,JPL))
     1 +RR*COS(PHI-WW(NP,JPL))*PSSS(K)
      ENDIF


      IF(PHI.LT.0.0)PHI=PHI+PI2
      DRE=RR*SIN(PHI-WW(NP,JPL))
      DRMM=SDRFT(IPL,IP,ISM)*DRI(NP,JPL)+DWS(NP,JPL)
      DIFF=DRE-DRMM
      XX(LL)=ZP(JPL)
      YY(LL)=DIFF
      YYY(LL)=DRMM
      IF(ABS(DRE-DRMM).LT.1.0)THEN
        IF(IP1.EQ.1.AND.IP2.EQ.1.AND.ISM.EQ.1)THEN
        CALL SHS(704+ISM,0.,DRE-DRMM)
        SEE=SEE+DRE*DRE
        SME=SME+DRMM*DRE
        SSS=SSS+1.0
        ENDIF
        IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.2)THEN
        CALL SHS(704+ISM,0.,DRE-DRMM)
        SEE=SEE+DRE*DRE
        SME=SME+DRMM*DRE
        SSS=SSS+1.0
        ENDIF
        IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.3)THEN
        CALL SHS(704+ISM,0.,DRE-DRMM)
        SEE=SEE+DRE*DRE
        SME=SME+DRMM*DRE
        SSS=SSS+1.0
        ENDIF
      ENDIF
      ENDIF
 22   CONTINUE
      CALL FTLFT(XX,YY,LL,0,AT,BT,EE)
      CALL FTLFT(XX,YYY,LL,0,AD,BD,EE)
      CALL SHS(708,0,AT)
      CALL SHS(699,0,AD-DDDZ)

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


*   Diagnostics...
      IF(ISMIN .NE. 0) THEN
      IF(DRMIN .LT. DRPCUT) THEN
      IF(SSS.GT.4.AND.ISMIN.NE.0)THEN
C     CALCULATE VELOCITY CORRECTION
      VFAC=SME/SEE
      CALL SHS(750+ISM,0,VFAC)
      ENDIF
      endif
      endif
*   Diagnostics end.




      IF(ISMIN.NE.0)THEN
      IF(DRMIN .LT. DRPCUT) THEN

*       Mark radial segment used...
        IRUSED(ISM,ISMIN) = 1

        II=0
C       PRINT2000,(IRPT(LK,ISMIN,ISM),LK=1,12)
 2000   FORMAT(' RSEG ',12I2)
        ifr=1+(ism-1)*12
        ils=11+ifr
        DO 50 IWIR= IFR, ILS
         II   = II+1
         IOSP =   IRPT(II,ISMIN,ISM)
         IF (IOSP.EQ.0) GOTO 50
         IRR(IWIR, K) = IABS(IOSP)
         SRR(IWIR, K) = SDRFT(II,ISMIN,ISM)
 50     CONTINUE
C       POINTER TO RADIAL SEGMENT # ASSOCIATED WITH
C       NPP'TH PLANAR TRACK
        LRR(ISM,K)=ISMIN
        nadd=1
      ENDIF
      ENDIF


      ENDIF
      ENDIF
c     link made: make another search
c     otherwise next module

      if(nadd.eq.1)goto200

C
C---  End of loop over supermodules
C  NEXT LINE SHOWS FINAL SELECTION
CDEB  WRITE(*,*)' DRMIN DRM ',ISM,DRMIN,DRM,ISMIN

   10 CONTINUE


C     PRINT 1000,K,(IRR(II,K),II=1,36),LRR(1,K),LRR(2,K),LRR(3,K)
 1000 FORMAT(' R',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)

      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.28.56  by  Girish D. Patel
*CMZ :  8.05/00 27/09/96  16.29.29  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  7.02/11 12/10/95  12.59.12  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.26  by  Stephen Burke
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Link single planar segments to radial segments
*          Planar(radial) segments have not been used
*          to make planar(radial) based tracks
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
* Planar track segments:
*          NFSEG segments/module
*          Hits                    :- IDGISG
*          Parameters(x0,y0,x',y') :- XYDXY in mm
*
*
*
*HTMLO     : Describe the Output of the routine
*
*          Planar-radial pointer   :- ISGR
*          Used flags              :- IUZP,IUSR
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPLKPR(ISMP,IDM )
**: FPLKPR 30907 RP. Farm changes.
**----------------------------------------------------------------------
**     ROUTINE TO JOIN ADJACENT RADIAL AND PLANAR MODULES
*     AS FPLKRP1 BUT FIND BEST RADIAL FOR SELECTED PLANAR
*
*     12/8/96  add d(phi)/dz cut
*
*

*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...


*     Common for segment numbers...
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      COMMON /FPSEG3/ ISGR(3,MAXSEG)

*     Local arrays...
      DIMENSION RSEG(4),PSEG(4)
      DIMENSION XX(20),YY(20)
      PARAMETER(PI2=6.2831853)

      LOGICAL FIRST/.TRUE./

      IF(FIRST) THEN
         FIRST = .FALSE.
*        note millimetres
         DRPCUT=  10.0
         DRCUT = 100.
         phicut=   0.002
         atcut =   0.15
      write(*,*)' new FPLKPR  - d(phi)/dz cut '
      ENDIF

C
C---   LOOP OVER SUPERMODULES - FOR RADIALS
C
C      ISMP- PLANAR MODULE
C      ISM - RADIAL MODULE
C
      DO 15 IP = 1,NFSEG(ISMP)
C
C---  search only unused segments
C
      IF(IUZP(IP,ISMP).NE.0)GOTO15
C
C---  search only the disconnected set
C
      IF( MASKSG(IP,ISMP) .NE. 0 )GO TO 15
C
C---  Extract planar segment and covariance matrix
C
C     STR LINES THROUGH PLANARS IN PHI-Z  R-Z
C     DISTANCES IN MM HERE FOR RCWH
      DO 30 I = 1,4
C---
      PSEG(I) = XYDXY(I,IP,ISMP)
C---
   30 CONTINUE
C---
      Z1MM=ZPP(1+12*(ISMP-1))*10.
      Z2MM=ZPP(12+12*(ISMP-1))*10.
      X1=PSEG(1)+Z1MM*PSEG(3)
      Y1=PSEG(2)+Z1MM*PSEG(4)
      X2=PSEG(1)+Z2MM*PSEG(3)
      Y2=PSEG(2)+Z2MM*PSEG(4)
      R1=SQRT(X1**2+Y1**2)
      R2=SQRT(X2**2+Y2**2)
      P1=ATAN2(Y1,X1)
      P1=AMOD(P1,PI2)
      IF(P1.LT.0.)P1=P1+PI2
      P2=ATAN2(Y2,X2)
      P2=AMOD(P2,PI2)
      IF(P2.LT.0.)P2=P2+PI2
      DP=P1-P2
      IF(DP.GT.6.0)DP=DP-PI2
      IF(DP.LT.-6.0)DP=DP+PI2
C     NOTE MM  THRUOUT
      RSS      =(R1-R2)/(Z1MM-Z2MM)
      RIS      =(R1-RSS*Z1MM)
      PSS      =DP/(Z1MM-Z2MM)
      PIS      =P1-PSS*Z1MM
C

      DO 50 ISM=1,3


      Z = ZP( 6 + (ISM -1)*12 )
      ZMM=Z*10.

*     R AND PHI FOR PLANAR SEGMENT AT POSITION OF RADIAL

      PHIPLA=PSS*ZMM+PIS
      RPL   =RSS*ZMM+RIS
      PHIPLA = AMOD(PHIPLA,PI2)
      IF(PHIPLA.LT.0.0) PHIPLA = PHIPLA + PI2


      ISMIN = 0
      DRMIN = 1000000.0
      DRM   = 1000000.0
      DO 20 K=1,NTRAKS(ISM)
      if(chsq(k,ism).gt.1000.0)goto20
      IF(IUZR(K,ISM).NE.0)GOTO20
C
      Z = ZP( 6 + (ISM -1)*12 )
C
C---  RR AND PHI CALCULATED FOR THIS Z AS FOUND     BY RADIALS
C
      RR  = PSINL(K,ISM)*Z + RZI(K,ISM)
      RRAD= RR*10.
      PHI = PCOSL(K,ISM)*Z + PHZL(K,ISM)
      PHI = AMOD(PHI,PI2)
      IF(PHI.LT.0.0) PHI = PHI + PI2


*     Believe the radial segment prediction in the 'drift' direction
*     only. More-or-less ignore rad radius...
      RMEAN = RPL
      DELP  = PHIPLA - PHI
      IF(DELP .GT. (PI2/2.)) THEN
           DELP = DELP -PI2
      ELSEIF(DELP .LT. -(PI2/2.)) THEN
           DELP = DELP +PI2
      ENDIF

      DRPHI = RMEAN*(DELP)
      DR    = RPL - RRAD
      DRPHI = ABS(DRPHI)
      DR    = ABS(DR)
      IF(DRPHI.LT.DRPCUT)THEN
      CALL SHS(1631,0,DR   )
      ENDIF
      IF(DRPHI .LT. DRMIN) THEN
      IF(DR    .LT. DRCUT) THEN
        DRMIN = DRPHI
        ISMIN = K
        DRM   = DR
      ENDIF
      ENDIF
C
C---  END OF LOOP OVER RADIAL  SEGMENTS FOR SUPERMODULE
C
   20 CONTINUE
C

C      GET  DISTANCE OF RADIAL POINTS FROM PREDICTION*******
      IF(ISMIN.NE.0)THEN
      IX=ISMIN
      LL=0
      DO 22 IPL=1,12
      JPL=IPL+(ISM-1)*12
      NP=IRPT(IPL,IX,ISM)
      IF(NP.NE.0)THEN
      LL=LL+1
      RR=RSS*ZP(JPL)*10.+RIS
      PHI=PSS*ZP(JPL)*10.+PIS
      IF(PHI.LT.0.0)PHI=PHI+PI2
      DRE=RR*SIN(PHI-WW(NP,JPL))/10.
      DRMM=SDRFT(IPL,IX,ISM)*DRI(NP,JPL)+DWS(NP,JPL)
      DIFF=DRE-DRMM
      XX(LL)=ZP(JPL)
      YY(LL)=DIFF
C     FOLLOWING HISTOGRAM SHOWS DATA SPREAD TO 1 CMS
c     CALL SHS(1632,0,DIFF)
      ENDIF
 22   CONTINUE
      CALL FTLFT(XX,YY,LL,0,AT,BT,EE)
c     compare radial d(phi)/dz with planar
      dphi=pcosl(ismin,ism)-pss*10.
      dphi1=dphi
      dphi=amod(dphi,pi2)
      if(drmin.lt.drpcut)then
      CALL SHS(1633,0,AT)
      CALL SHS(1636,0,AT)
*     if(dphi1.ne.dphi)write(*,*)' fplkpr ',dphi,dphi1
      CALL SHS(1635,0,dphi)
      endif
      DC=AT*XX(LL/2)+BT
      diff=dc
      CALL SHS(1632,0,DIFF)
C     CHECK SLOPE OF SEGMENT : HISTGRAM SUGGESTS 0.1
      IF(ABS(AT).GT.atcut)ISMIN=0
c     check d(phi)/dz
      if(abs(dphi).gt.phicut)ismin=0
      IF(ISMIN.NE.0)CALL SHS(1634,0,DC)
      ENDIF
C     END ADDITION *****************************************

      IF(ISMIN .NE. 0) THEN
      CALL SHS(1630,0,DRMIN)
      IF(DRMIN .LT. DRPCUT) THEN


C     LINK FLAG ISMP =PLANAR MODULE 2,3 . IP POINTS TO PLANAR SEGMENT
C     ISGR IS RADIAL SEGMENT IN MODULE ISMP-1
C     ISGR ZERO'D IN FTADD
         IF(ISMIN.GT.99)ISMIN=99
         ISGR(ISMP,IP)  = ISMIN*100**(ISM-1)+ISGR(ISMP,IP)
         IUZR(ISMIN,ISM)= 1
         IUZP(IP,ISMP)  = 1

CIOS     PRINT 2000,ISM,ISMP,ISMIN,IP
 2000    FORMAT(' PR LK1  ',2I3,3X,2I3)
CIOS     CALL SHD(212,0,DRMIN,DRM)


      ENDIF
      ENDIF
C
C---  End of loop over supermodules
C
C     PRINT 1000,(IRP(II,K),II=1,36)
 1000 FORMAT(' P ',12I2,3X,12I2,3X,12I2)


   50 CONTINUE


   15 CONTINUE
   10 CONTINUE
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  7.00/04 11/05/95  15.16.20  by  Stephen Burke
*CMZU:  5.03/00 12/09/94  15.55.38  by  Stephen J. Maxfield
*CMZU:  4.01/01 12/12/93  17.09.31  by  Stephen Burke
*CMZU:  4.00/08 18/11/93  09.10.22  by  Stephen J. Maxfield
*CMZU:  3.09/07 26/07/93  10.00.28  by  Stephen Burke
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTDPAT
**: FTDPAT 30907 RP. Farm changes.
**----------------------------------------------------------------------
***********************************************************
*                                                         *
*     Do Pattern recognition in FTD. Link segments.       *
*                                                         *
***********************************************************
*
      COMMON/FEVSAT/IEVSAT
      IEVSAT = 0

*     Make radial-radial links and pick up planar segments.
      CALL FRAPKR
*
*     Set area for histograms...
      CALL SAREA('FTREC',2)
*
*     Make planar-planar links and pick up radial segments.
      CALL FPLPKP
*
*     Merge track lists. Release radial segments not used by planars.
      CALL FTMERG
*
*     Make planar-radial links
      CALL FTPRLK
*
*     Pick up planar segments from connected set
      CALL FPCXTD
*
*     Pick up unused planar segments (connected and unconnected)
      CALL FPSPC
*     Pick up unused radial segments.
      CALL FSINGR
*
*     Drift velocity determination by projection from planars.
*     Do BEFORE radial segments are used to improve track!
*
      CALL SAREA('FPOKE', 0)
      CALL FPOKER
      CALL SAREA('FTREC', 2)
*
*     Improve track parameters with radial segments...
      CALL FPRFIT

*     Output results...
      CALL FPATUT
*
      IF(IEVSAT .NE. 0) THEN
       CALL ERRLOG(120,'W:FTDPAT: Pattern recognition saturated')
      ENDIF
*
*     Reset area for histograms...
      CALL SAREA('FTREC',1)
*
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.08/03 17/11/92  17.01.03  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   17/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRSEG
***********************************************************
*                                                         *
*     Find segments in Radial Drift chambers and make     *
*     output banks FRSG etc.                              *
*                                                         *
***********************************************************
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEND.
      COMMON/FVFLAG/IVERTX
      COMMON/CORRXY/CX1,CX2,CX3,CY1,CY2,CY3
C     INITIALISE FLAGS :  VERTEX NOT USED IN FITS
      IVERTX=0
C     NO CORRECTIONS TO RADIAL POSITIONS
      CX1=0.
      CX2=0.
      CX3=0.
      CY1=0.
      CY2=0.
      CY3=0.
*     Zero Arrays for this Event...
      CALL FPTZER
*     Unpack primary event vertex in Monte Carlo...
      CALL FPTVER
*     Unpack radial data...
      CALL FPTRDT
*     ...and planar data.
      CALL FPTPDT
*     Pattern recognise radials. One Module at a time...
      CALL  FTLSEG(1, 1)
      CALL  FTLSEG(13,2)
      CALL  FTLSEG(25,3)
*     Fit tracks without vertex constraint...
      CALL  FTFIT
*     Output radial segment banks FRSG...
      CALL FRSOUT
*
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.08/03 18/11/92  10.38.33  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   17/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRAPKR
*     Link helices...2,3-module fits...
      CALL  FTLINK
*     Pick up planar segments...
      CALL  FRPKPL
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.08/03 28/11/92  16.21.28  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   17/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
*
*        Planar Segment finding.
*
         SUBROUTINE FPLSG
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEND.
*        Unpack planar data to PLANAR H1WORK common          *
         CALL FPUDAT
*        Pattern recognise PLANAR Segments.
         CALL FPSEG
*        Make planar segment banks, FPSG etc.
         CALL FPSOUT
         IF(IREZ.NE.0)CALL FPREZI

         RETURN
         END
*CMZ :  8.06/00 11/11/96  21.05.37  by  Stephen Burke
*CMZ :  8.05/00 27/09/96  16.49.07  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  7.02/11 17/10/95  21.47.09  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.28  by  Stephen Burke
*-- Author :   I.O.SKILLICORN
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Finds planar line segments on radial-based tracks.
*          Calls FPLPKS to link the planars to the track.
*          Calls FREFIT to refit the radial-based track with
*          the planar data.
*
*HTMLI     : Describe the Input variables to the routine
*
*          See FPLPKS/FREFIT
*
*
*HTMLO     : Describe the Output of the routine
*
*          See FPLPKS/FREFIT
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FRPKPL
**----------------------------------------------------------------------
*
*     Pick up planar segments on radial-based tracks
*     I.O.Skillicorn


*     Array Dimensions...
*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
*
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEND.
*SUNDRY VERTICES...
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRWERR.
      COMMON /WERR/ERRVL,ERRV,ERRP,ERRRX
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEND.
*     FTTRAC Results.
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEND.
*
      COMMON /FLINK3/LNK3(MAXTRK,3)
      COMMON/CORRXY/CX1,CX2,CX3,CY1,CY2,CY3

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR

      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)

      COMMON /FPSEG1/ ISGG(3,MAXTRK)
*     LOCAL ARRAYS...
      DIMENSION IUSED(MAXHTS,36) ,IUSEDP(MAXHTS,36)
      DIMENSION IUSEG( MAXSEG, 3)
*     ADDED FOR COVARIANCE MATRIX
      DIMENSION TCOV(15), RCOV(15)
      DIMENSION NNOP(48)

      CHARACTER*15 FTEXT1
      CHARACTER*27 FTEXT
      CHARACTER*27 FTEXT2
      PARAMETER(PHII=0.130899693)
      PARAMETER(HPHII=PHII/2.)
      PARAMETER(PI2=6.2831853)
*     Location of endwall...
      PARAMETER(ZWALL=132.95)
*     Nominal error on x-y vertex...
      PARAMETER(SVER=0.02)
*     Cut to exclude poorly parameterised tracks...
      PARAMETER(DRHLCT=3.0)
      PARAMETER(IVDRF=4)
      PARAMETER(FQFAC=10000.)


      LOGICAL FIRST
*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.
      DATA FIRST/.TRUE./

      IF(FIRST) THEN
        FIRST = .FALSE.
        WRITE(6,'(///,5X,''FTREC: New version of FTREC used'')')
        IQF0R8 = NAMIND('F0R8')
      ENDIF

*     Zero Hit lists,signs etc.
      CALL VZERO(SDN,   MAXTRK*36)
      CALL VZERO(SDP,   MAXTRK*36)
      CALL VZERO(IRP,   MAXTRK*36)
      CALL VZERO(IRN,   MAXTRK*36)
      CALL VZERO(IUSED, MAXHTS*36)
      CALL VZERO(IUSEDP,MAXHTS*36)
      CALL VZERO(IUSEG, MAXSEG*3)
      CALL VZERO(ISGG,  MAXTRK*3)
      CALL VZERO(IGTTRK,MAXTRK)

*******************************************
*     Begin Main loop over linked tracks...
                           NTRK12=0
                           NTRK23=0
                           NTRK13=0
                           NTRK3 =0
                           DO 100 K=1,IG
*     Build list of radial points on the track...
      MOD3=0
      M1=LNK3(K,1)
      M2=LNK3(K,2)
      M3=LNK3(K,3)
*-----Debug---------------------------------------------------
*     Write(6,'('' FRPKPL>>>'',I4,6X,3I4)')K,M1,M2,M3

      IF(M1*M2*M3.NE.0)  THEN
        MOD3=1
        NTRK3 = NTRK3  + 1
      ELSEIF(M1*M2.NE.0) THEN
        NTRK12= NTRK12 + 1
      ELSEIF(M2*M3.NE.0) THEN
        NTRK23= NTRK23 + 1
      ELSEIF(M1*M3.NE.0) THEN
        NTRK13= NTRK13 + 1
      ELSE
      ENDIF

      IFIRR = 0
      ZMINR = 10000.
      DO 656 KK=1,3
        I=LNK3(K,KK)

        IF(I.EQ.0)THEN
          DO 657 KKK=1,12
           KP=12*(KK-1)+KKK
           IRN(KP,K)=0
 657      CONTINUE
        ELSE
          DO 658 KKK=1,12
           KP=12*(KK-1)+KKK
           IKK      =IRPT(KKK,I,KK)
           IF(IKK.NE.0) THEN
             IF(IUSED(IKK,KP) .EQ. 0) THEN
               IF(IFIRR.EQ.0) THEN
                IFIRR=KP
                ZMINR=ZP(KP)
               ENDIF
               IRN(KP,K)=IRPT(KKK,I,KK)
               SDN(KP,K)=SDRFT(KKK,I,KK)
               IUSED(IRN(KP,K),KP)=1
             ENDIF
           ENDIF
 658      CONTINUE
        ENDIF

 656  CONTINUE
 100            continue

*-----Debug---------------------------------------------------
*     WRITE(*,*)'   ***FRPKPLA** '
*     WRITE(*,*)IG,' RADIAL TRACKS '
*     PRINT 1001,K,(IRN(J,K),J=1,36),LNK3(K,1),LNK3(K,2),LNK3(K,3)
*     PRINT 1002,K,(IRP(J,K),J=1,36),ISGG(1,K),ISGG(2,K),ISGG(3,K)
*1001 FORMAT(' RR',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
*1002 FORMAT(' RP',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
*-----Debug---------------------------------------------------


c        pick up planar line segments
         CALL FPLPKS( IUSEDP, IUSEG)
c        refit r-z, phi-z radials + planars
         call frefit


      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.08/03 27/11/92  14.30.17  by  Stephen J. Maxfield
*-- Author :    I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Organise single planar-single radial linking
*
*HTMLI     : Describe the Input variables to the routine
*
*          See FPLKPR
*
*HTMLO     : Describe the Output of the routine
*
*          See FPLKPR
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTPRLK
*
*     Make links between single radial and planar segments.
*     and calculate track parameters.
*
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
      COMMON /FPSEG3/ ISGR(3,MAXSEG)

*     Zero pointer list...
      CALL VZERO(ISGR,MAXSEG*3)

*     Find links Rad0-Pla1 and Rad1-Pla2...
*     Start with 2,3 because these have adjacent radials
      CALL       FPLKPR(2,0)
      CALL       FPLKPR(3,0)
      CALL       FPLKPR(1,0)

*     Build list of hits, track parameters for these tracks...
      CALL       FTPRTR

      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.28  by  Stephen Burke
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Select best planar-based, radial-based tracks
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial-based tracks:
*          IG tracks
*          Hits/drift sign         :- IRN/SDN IRP/SDP
*          Segments planars/radials:- ISGG LNK3
* Planar-based tracks:
*          NPP tracks
*          Hits                    :- IRR/SRR IPP/SPP
*          Segments radials/planars:- LRR LPP
*
*
*HTMLO     : Describe the Output of the routine
*
*          Good radial-based track :- IBRR=1
*          Used radial segment     :- IUSR
*          Used planar segment     :- IUSP
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTMERG
**: FTMERG 30907 RP. Farm changes.
**----------------------------------------------------------------------
*
*     Merge lists of Radial-based and Planar-based tracks
*     resolving conflicts.
*         - Planar-based tracks win disputed segments
*  ***    - Radial-based tracks only accepted if verified by at
*           at least one planar.
*  ***    - Keep radial only tracks if 1 or 2 module.
*
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.



*     POINTERS TO RADIAL SEGMENTS FORMING TRACKS
      COMMON /FLINK3/LNK3(MAXTRK,3)

*     COMMON FOR IOS PLANAR LINK
      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)
*     COMMON FOR PLANAR FOUND TRACKS
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
C     COMMON FOR RADIALS ASSOCIATED WITH PLANAR TRACKS
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
C     PLANAR SEGMENTS ASSOCIATED  WITH RADIALS
C     ISGG POINTS TO ROB'S SEGMENT BANKS
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      COMMON /FPSEG3/ ISGR(3,MAXSEG)
C            RADIAL  REJECT , UNUSED  , RADIAL VERIFIED BY PLANAR
      COMMON/FTRFLG/ IBRR(MAXTRK),IBPP(100),IVRR(MAXTRK)
      DIMENSION PSEG(4)
      PARAMETER (PI2=6.2831853)
      DATA ISTART/0/


      CALL VZERO(IUZP,3*MAXSEG)
      CALL VZERO(IUZR,3*MAXTRK)
      CALL VZERO(IBRR,IG)
      CALL VZERO(IVRR,IG)
      CALL VZERO(IBPP,NPP)


      DO 100 I=1,IG
      DO 200 J=1,NPP
      DO 110 II=1,3
C     CHECK COMMON RADIAL SEGMENT
      IF(LNK3(I,II).EQ.LRR(II,J).AND.LRR(II,J).NE.0)THEN
      CALL SHS(713,0,2.01)
      GOTO 250
      ENDIF
 110  CONTINUE
      DO 120 II=1,3
C     CHECK COMMON PLANAR SEGMENT
      IF(ISGG(II,I).EQ.LPP(II,J).AND.LPP(II,J).NE.0)THEN
      CALL SHS(713,0,3.01)
      GOTO 250
      ENDIF
 120  CONTINUE
      GOTO200
 250  CONTINUE
C     HERE WE HAVE EITHER RADIAL OR PLANAR SEGMENT IN COMMON
C     BETWEEN RADIAL AND PLANAR FOUND TRACKS
C     MARK RADIAL LINKED TRACK AS BAD
C     NEXT LINE COUNTS RADIALS FOUND MORE THAN ONCE BY PLANARS
       IF(IBRR(I).EQ.1)CALL SHS(713,0,4.51)
      IBRR(I)=1
      CALL SHS(713,0,4.01)
 200  CONTINUE
 100  CONTINUE




*-----Debug---------------------------------------------------
*     WRITE(*,*)' ***FTMERG***'
*     WRITE(*,*)IG,' RADIAL TRACKS FTADD'
*
*     Mark planar and radial segments on verified radial tracks
*     used. Label the verified radial tracks in the IG list
*     Kill off bad links...
      DO 300 I=1,IG
      CALL SHS(711,0,5.01)
      IF(IBRR(I).EQ.0)THEN
       IF((ISGG(1,I)+ISGG(2,I)+ISGG(3,I)).NE.0)THEN
C       RADIAL TRACK VERIFIED BY PLANAR SEGMENT - GOOD TRACK
        IVRR(I)=1
        IF(LNK3(I,1).NE.0)IUZR(LNK3(I,1),1)=1
        IF(LNK3(I,2).NE.0)IUZR(LNK3(I,2),2)=1
        IF(LNK3(I,3).NE.0)IUZR(LNK3(I,3),3)=1
        IF(ISGG(1,I).NE.0)IUZP(ISGG(1,I),1)=1
        IF(ISGG(2,I).NE.0)IUZP(ISGG(2,I),2)=1
        IF(ISGG(3,I).NE.0)IUZP(ISGG(3,I),3)=1

*-----Debug---------------------------------------------------
*       Write(6,*) '       Verified Radial-based track:-'
*       PRINT 1001,I,(IRN(K,I),K=1,36),LNK3(I,1),LNK3(I,2),LNK3(I,3)
*       PRINT 1001,I,(IRP(K,I),K=1,36),ISGG(1,I),ISGG(2,I),ISGG(3,I)

        CALL SHS(711,0,2.01)
       ELSE
C       UNVERIFIED - SEEN RADIALS ONLY- ?

*-----Debug---------------------------------------------------
*       Write(6,*) '       Unverified Radial-based track:-'
*       PRINT 1001,I,(IRN(K,I),K=1,36),LNK3(I,1),LNK3(I,2),LNK3(I,3)
*       PRINT 1001,I,(IRP(K,I),K=1,36),ISGG(1,I),ISGG(2,I),ISGG(3,I)
*1001 FORMAT(' RR',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
*1002 FORMAT(' RP',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)

        CALL SHS(711,0,3.01)
*       'Verify' this track also.
        IVRR(I)=1
*       This assumes Radial tracks are at least two module...
        IF(LNK3(I,1).NE.0)IUZR(LNK3(I,1),1)=1
        IF(LNK3(I,2).NE.0)IUZR(LNK3(I,2),2)=1
        IF(LNK3(I,3).NE.0)IUZR(LNK3(I,3),3)=1
*       LNK3(I,1) = 0
*       LNK3(I,2) = 0
*       LNK3(I,3) = 0
        ISGG(1,I) = 0
        ISGG(2,I) = 0
        ISGG(3,I) = 0
       ENDIF
      ELSE
        LNK3(I,1) = 0
        LNK3(I,2) = 0
        LNK3(I,3) = 0
        ISGG(1,I) = 0
        ISGG(2,I) = 0
        ISGG(3,I) = 0

C     RADIAL BASED TRACK HAS SEGMENT IN COMMON WITH PLANAR BASED TRACK
C     SHARE PLANAR SEGMENT WITH PLANAR TRACK - REJECT - IBRR=1
C     SHARE RADIAL SEGMENT WITH PLANAR TRACK - REJECT- IBRR=1
*     PRINT 1005,I,(IRN(K,I),K=1,36),LNK3(I,1),LNK3(I,2),LNK3(I,3)
*     PRINT 1006,I,(IRP(K,I),K=1,36),ISGG(1,I),ISGG(2,I),ISGG(3,I)
      CALL SHS(711,0,4.01)
      ENDIF
 300  CONTINUE


CC    WRITE(*,*)NPP,' PLANAR TRACKS '
      DO 310 I=1,NPP
      IF( LRR(1,I).NE.0)IUZR( LRR(1,I),1)=1
      IF( LRR(2,I).NE.0)IUZR( LRR(2,I),2)=1
      IF( LRR(3,I).NE.0)IUZR( LRR(3,I),3)=1
      IF( LPP(1,I).NE.0)IUZP( LPP(1,I),1)=1
      IF( LPP(2,I).NE.0)IUZP( LPP(2,I),2)=1
      IF( LPP(3,I).NE.0)IUZP( LPP(3,I),3)=1
C     TRACKS BASED ON LINKED PLANAR SEGMENTS - ACCEPT AS GOOD
*     PRINT 1004,I,(IRR(K,I),K=1,36),LRR(1,I),LRR(2,I),LRR(3,I)
*     PRINT 1003,I,(IPP(K,I),K=1,36),LPP(1,I),LPP(2,I),LPP(3,I)
      CALL SHS(711,0,1.01)
      IF(LRR(1,I).NE.0.OR.LRR(2,I).NE.0.OR.LRR(3,I).NE.0)THEN
C     PLANAR VERIFIED BY RADIAL
      CALL SHS(713,0,1.01)
      ENDIF
C     FOR COMPLETENESS ADD DRIFT SIGNS FOR PLANAR AND RADIALS
      DO 311 IM=1,3
       IF(LPP(IM,I).NE.0)THEN
        IP=LPP(IM,I)
        DO 312 II=1,12
         IOSP=IDGISG(II,IP,IM)
         SPP(II+(IM-1)*12,I)=SIGN(1.0,FLOAT(IOSP))
 312    CONTINUE
       ENDIF
       IF(LRR(IM,I).NE.0)THEN
        IP=LRR(IM,I)
       ENDIF
 311  CONTINUE
C
 310  CONTINUE

      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.28  by  Stephen Burke
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Calculate track parameters and fill point banks
*          for tracks based on single planars
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
* Planar track segments:
*          NFSEG segments/module
*          Hits                    :- IDGISG
*          Parameters(x0,y0,x',y') :- XYDXY in mm
*
*          Planar-radial link flags:- ISGR
*HTMLO     : Describe the Output of the routine
*
*
* Planar-based and P->R link tracks:
*          NPP tracks
*          Hits                    :- IRR/SRR IPP/SPP
*          Segments radials/planars:- LRR LPP
*          Parameters(phi',phi0)   :- PSSS,PISS
*          Parameters(R',R0)       :- RSSS,RISS
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTPRTR
**: FTPRTR 30907 RP. Farm changes.
**----------------------------------------------------------------------
*
*     Calculate track parameters and fill lists of hits for the
*     Single-Planar extrapolated tracks.
*
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      COMMON /FPSEG3/ ISGR(3,MAXSEG)
      COMMON /FTPPBK/ NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON /FTPPBS/ SPP(36,100)
      COMMON /FPPFIT/ PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON /FPLNK/  KTIP(3,50),LPP(3,100)
      COMMON /FTRRBK/ IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
      COMMON /FLINK3/LNK3(MAXTRK,3)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT


      DIMENSION PSEG(4)
      PARAMETER (PI2=6.2831853)
*
*     Single planar module associated with one or more radial modules
      DO 350 ISMP=1,3
      DO 360 IP=1,NFSEG(ISMP)
      IF(ISGR(ISMP,IP).EQ.0)GOTO360
      CALL SHS(712,0,10.0)
      CALL SHS(716,0,10.0)

      NPP=NPP+1
      IF(NPP.GT.100) THEN
        NPP = 100
        IEVSAT = 1
      ENDIF
      KLOC(NPP) = 5

C     RADIAL POINTERS
      LRR(1,NPP)=0
      LRR(2,NPP)=0
      LRR(3,NPP)=0
C     PLANAR POINTERS
      LPP(1,NPP)=0
      LPP(2,NPP)=0
      LPP(3,NPP)=0
      DO 361 II=1,36
      IPP(II,NPP)=0
 361  IRR(II,NPP)=0
      NRR=0
      DO 366 ISM=1,3
      IF(ISM.EQ.1)THEN
      K3=ISGR(ISMP,IP)/10000
      K2=(ISGR(ISMP,IP)-10000*K3)/100
      K1=ISGR(ISMP,IP)-10000*K3-100*K2
      ENDIF
      IF(ISM.EQ.3)K=K3
      IF(ISM.EQ.2)K=K2
      IF(ISM.EQ.1)K=K1
         IF(ISM.EQ.1)THEN
         IF(ISMP.EQ.2.AND.K1 .NE.0)CALL SHS(712,0,1.01)
         IF(ISMP.EQ.3.AND.K2 .NE.0)CALL SHS(712,0,3.01)
         IF(ISMP.EQ.1.AND.K1 .NE.0)CALL SHS(712,0,5.01)
         IF(ISMP.EQ.2.AND.K2 .NE.0)CALL SHS(712,0,7.01)
         IF(ISMP.EQ.3.AND.K3 .NE.0)CALL SHS(712,0,9.01)
         ENDIF
      IF(K.EQ.0)GOTO366
      NRR=NRR+1
      LRR(ISM,NPP)=K
      DO 362 II=1,12
      IRR(II+(ISM-1)*12,NPP)=IRPT(II,K,ISM)
      SRR(II+(ISM-1)*12,NPP)=SDRFT(II,K,ISM)
 362  CONTINUE
 366  CONTINUE
C     NUMBER RADS/SINGLE PLANAR
      CALL SHS(712,0,FLOAT(NRR)+20.01)
      LPP(ISMP,NPP)=IP
      DO 365 II=1,12
      IOSP=IDGISG(II,IP,ISMP)
      IPP(II+(ISMP-1)*12,NPP)=IABS(IOSP)
      SPP(II+(ISMP-1)*12,NPP)=SIGN(1.0,FLOAT(IOSP))
 365  CONTINUE

      DO 363 II=1,4
      PSEG(II)=XYDXY(II,IP,ISMP)
 363  CONTINUE
C     FILL BANKS WITH STR LINES THROUGH PLANARS
C     DISTANCES IN MM HERE FOR RCWH
      Z1MM=ZPP(1+12*(ISMP-1))*10.
      Z2MM=ZPP(12+12*(ISMP-1))*10.
      X1=PSEG(1)+Z1MM*PSEG(3)
      Y1=PSEG(2)+Z1MM*PSEG(4)
      X2=PSEG(1)+Z2MM*PSEG(3)
      Y2=PSEG(2)+Z2MM*PSEG(4)
      R1=SQRT(X1**2+Y1**2)
      R2=SQRT(X2**2+Y2**2)
      P1=ATAN2(Y1,X1)
      P1=AMOD(P1,PI2)
      IF(P1.LT.0.)P1=P1+PI2
      P2=ATAN2(Y2,X2)
      P2=AMOD(P2,PI2)
      IF(P2.LT.0.)P2=P2+PI2
      DP=P1-P2
      IF(DP.GT.6.0)DP=DP-PI2
      IF(DP.LT.-6.0)DP=DP+PI2
C     BACK TO CMS
      RSSS(NPP)=(R1-R2)/(Z1MM-Z2MM)
      RISS(NPP)=(R1-RSSS(NPP)*Z1MM)/10.
      PSSS(NPP)=     DP*10./(Z1MM-Z2MM)
      PISS(NPP)=(P1-PSSS(NPP)*Z1MM/10.)
C
*        PRINT 2000,ISM,ISMP,K,ISGP(ISM,K),
*    1 (IRPT(I,K,ISM),I=1,12),
*    1 (IABS(IDGISG(II,IP,ISMP)),II=1,12)
 360  CONTINUE
 350  CONTINUE

*     From now on, this is diagnostic stuff...
*
C     COUNT UNUSED SEGMENTS
      DO 370 ISM=1,3
      NSS=0
      DO 371 I=1,NFSEG(ISM)
      IF(MASKSG(I,ISM).NE.0)GOTO 371
      NSS=NSS+1
      CALL SHS(714,0,FLOAT(15+ISM)+0.01)
      IF(IUZP(I,ISM).NE.0)GOTO371
      CALL SHS(714,0,FLOAT( 5+ISM)+0.01)
 371  CONTINUE
C     WRITE(*,*)' MOD,#SEGS ',ISM,NSS
      DO 372 I=1,NTRAKS(ISM)
      CALL SHS(714,0,FLOAT(10+ISM)+0.01)
      IF(IUZR(I,ISM).NE.0)GOTO372
      CALL SHS(714,0,FLOAT(ISM)+0.01)
 372  CONTINUE
 370  CONTINUE
C     CHECK PLANAR EFFICIENCY FOR R1-R2 TRACKS
      DO 380 K=1,IG
      IF(LNK3(K,1)*LNK3(K,2).NE.0)THEN
      CALL SHS(715,0,1.01)
C     R1-R2 TRACK
      IF(ISGG(2,K).NE.0)THEN
C     P2 PRESENT
      CALL SHS(715,0,2.01)
      ENDIF
      IF(ISGG(3,K).NE.0)THEN
C     P3 PRESENT
      CALL SHS(715,0,3.01)
      ENDIF
      ENDIF
C     CHECK PLANAR EFFICIENCY FOR R1-R2-R3 TRACKS
      IF(LNK3(K,1)*LNK3(K,2)*LNK3(K,3).NE.0)THEN
C     R1-R2-R3 TRACK
      CALL SHS(715,0,10.1)
      IF(ISGG(1,K).NE.0)THEN
C     P1 PRESENT
      CALL SHS(715,0,11.01)
      ENDIF
      IF(ISGG(2,K).NE.0)THEN
C     P2 PRESENT
      CALL SHS(715,0,12.01)
      ENDIF
      IF(ISGG(3,K).NE.0)THEN
C     P3 PRESENT
      CALL SHS(715,0,13.01)
      ENDIF
      ENDIF
 380  CONTINUE
C     CHECK RADIAL EFFICIENCY (XCHECK - SEE ALSO 710-FILLED FPKPKR)
C     CHECKED -OK
      DO 390 K=1,NPP
      IF( LPP(1,K)* LPP(2,K).NE.0)THEN
C     P1-P2 TRACK
      CALL SHS(715,0,20.01)
      IF( LRR(1,K).NE.0)THEN
C     R1 PRESENT
      CALL SHS(715,0,21.01)
      ENDIF
      ENDIF
      IF(LPP(1,K)*LPP(2,K)*LPP(3,K).NE.0)CALL SHS(716,0,1.01)
      IF(LPP(1,K)*LPP(2,K)*LPP(3,K).EQ.0)THEN
      IF(LPP(1,K)*LPP(2,K).NE.0)CALL SHS(716,0,3.01)
      IF(LPP(2,K)*LPP(3,K).NE.0)CALL SHS(716,0,5.01)
      IF(LPP(1,K)*LPP(3,K).NE.0)CALL SHS(716,0,7.01)
      ENDIF
 390  CONTINUE
 1001 FORMAT(' RR ',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1002 FORMAT(' RP ',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1003 FORMAT(' PP ',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1004 FORMAT(' PR ',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1005 FORMAT(' RRB',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1006 FORMAT(' RPB',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1007 FORMAT(' RRV',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1010 FORMAT('    ',I2,3X,12F3.0,3X,12F3.0,3X,12F3.0)
 2000 FORMAT(' RP LINK ',2I3,3X,2I3,2X,12I2,2X,12I2)
C     FINAL CHECK OF PLANARS
C     WRITE(*,*)'  PLANARS 2M 3M  R1P2 R2P3  '
      DO 400 I=1,NPP
      CALL SHS(716,0,12.0)
C     TRACKS BASED ON LINKED PLANAR SEGMENTS - ACCEPT AS GOOD
*     PRINT 1003,I,(IPP(K,I),K=1,36),LPP(1,I),LPP(2,I),LPP(3,I)
C     PRINT 1010,I,(SPP(K,I),K=1,36)
*     PRINT 1004,I,(IRR(K,I),K=1,36),LRR(1,I),LRR(2,I),LRR(3,I)
C     PRINT 1010,I,(SRR(K,I),K=1,36)

 400  CONTINUE
C     TRY TIME-ZERO AND VELOCITY DETERMINATION
C     4 FIT STR LINE
C     5  "           + VELOCITY FACTOR
C     6 FIT PARABOLAE
C     7   "          + VELOCITY FACTOR
C
*     CALL FTZFIT(TZZ,7,0.)
*     CALL FTVDET

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  7.02/11 26/10/95  18.15.50  by  Stephen J. Maxfield
*CMZU:  5.03/00 28/09/94  09.47.45  by  Stephen J. Maxfield
*CMZU:  4.00/08 22/11/93  10.45.56  by  Stephen J. Maxfield
*CMZU:  3.09/07 26/07/93  10.00.28  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   20/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPATUT
**: FPATUT 30907 RP. Farm changes.
*------------------------------------------------------------------*
*  OUTPUT RESULTS OF PATTERN RECOGNITION IN FORWARD DRIFT CHAMBERS *
*              MAKE LEVEL ZERO BANKS                               *
*                                                                  *
*------------------------------------------------------------------*
*  New version*********                                            *
*                                                                  *
*                                                                  *
*  OUTPUT:     FTUR,0     Reconstructed track parameters           *
*  =====       FPUR,0     Pointering bank to FRUX FPUX             *
*              FRUX,0     Pointers to hits (parallel to FRRE)      *
*              FPUX,0     Pointers to hits (parallel to FRPE)      *
*------------------------------------------------------------------*
*      FORMAT OF BANKS FROM FORWARD TRACK RECONSTRUCTION           *
*                                                                  *
*      FTUR    TABLE  FMT =        (6F,I,9F,I,F,3I)                *
*      ====                                                        *
*                                                                  *
*  1  KAPPA     F        1/radius (signed)                         *
*  2  PHI       F        Phi track angle in xy plane.              *
*  3  THETA     F        Theta polar angle.                        *
*  4  X         F        x    ) coords of point on track,          *
*  5  Y         F        y    ) either first measured point (FTUR) *
*  6  Z         F        z    ) or vertex (FTVR).(z is reference   *
*                               value NOT parameter.)              *
*  7  IPTYPE    I        Patyp = 2 type of parametrisation         *
*                                                                  *
*  8  SIGMA1             )                                         *
*  9  SIGMA2             )                                         *
* 10  SIGMA3             )                                         *
* 11  SIGMA4             )                                         *
* 12  SIGMA5             )                                         *
*                        )  Packed covariance matrix               *
* 13  CORR1              )                                         *
* 14  CORR2              )                                         *
* 15  CORR3              )                                         *
* 16  CORR4              )                                         *
*                                                                  *
* 17  NDF                Num degrees of freedom                    *
* 18  CHSQ               Chisq per degree of freedom               *
*                                                                  *
* 19  FTUR               Pointer to next set on track (=0)         *
* 20  NHIT **            Packed  number of radial and planar hits  *
*                                                                  *
* 21  FPUR               Pointer to pointering bank                *
*                                                                  *
* ** NHIT:  Bits 24-31 Number of Radial Points                     *
*           Bits 16-23 Number of Planar Points                     *
*                                                                  *
*                                                                  *
*                                                                  *
********************************************************************
*      FPUR    Pointering bank                                     *
*      ====                                                        *
*              FORMAT B16                                          *
*  1  NHITFR            Number of radial hits                      *
*  2  FRUX              pointer to FRUX bank                       *
*  3  NHITFP            Number of planar hits                      *
*  4  FPUX              pointer to FPUX bank                       *
*                                                                  *
*  Note: as there are only ever one set of track parameters on a   *
*        track at level 0, this bank is effectively parallel to    *
*        FTUR.                                                     *
*                                                                  *
********************************************************************
*      FRUX    bank PARALLEL to FRRE bank. Lists of radial digis   *
*      ====         on track using INTERNAL NEXT relation          *
*              FORMAT B16                                          *
*  1 PNHIT            I      Pointer to next hit on track          *
*  2 DTFLAG           I      0=positive drift ;  1=negative drift  *
*      FPUX    bank PARALLEL to FRPE bank. Lists of radial digis   *
*      ====         on track using INTERNAL NEXT relation          *
*              FORMAT B16                                          *
*  1 PNHIT            I      Pointer to next hit on track          *
*  2 DTFLAG           I      0=positive drift ;  1=negative drift  *
********************************************************************
*                                                                  *
* INPUT is from two lists of tracks:-                              *
*  a) Radial-based tracks:                                         *
*  a                      IG tracks                                *
*                         Hits:- IRN/SDN IRP/SDP                   *
*                         Segments:- ISGG LNK3                     *
*                         Parameters:- RPCOS, RPSIN etc.           *
*  b) Planar-based and R-P link tracks:                            *
*                         NPP tracks                               *
*                         Hits:- IRR/SRR IPP/SPP                   *
*                         Segments:- LRR LPP                       *
*                         Parameters:- RSSS, PSSS, RISS, PISS      *
********************************************************************
* BOS Commons...
*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
*     Common for work bank indices (just in case)
      COMMON/FWBIND/IWFRUX,IWFPUX,IWFPUR

*     Commons for planar found tracks
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)

*     Common for radials associated with planar tracks
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)

*     Common for segment numbers...
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      COMMON /FPSEG3/ ISGR(3,MAXSEG)
      COMMON /FLINK3/ LNK3(MAXTRK,3)

*     Radial  reject , unused  , radial verified by planar
      COMMON/FTRFLG/ IBRR(MAXTRK),IBPP(100),IVRR(MAXTRK)

*  Bank formatting data...
      PARAMETER(NCFTUR=21)
      PARAMETER(NCFPUR=4)
      PARAMETER(NCFRUX=2)
      PARAMETER(NCFPUX=2)
      PARAMETER(NCFPSX=1)
      PARAMETER(NCFRSX=1)
      PARAMETER(NBNN=0)
      PARAMETER(NPATYP=2)

*  Local arrays...
      DIMENSION IRPNT(36), IPPNT(36)
      DIMENSION IRSGN(36), IPSGN(36)
      DIMENSION UCOV(15),  VCOVCP(9)
      DIMENSION ISGPL(3) , ISGRA(3), NSR(3)

      DIMENSION BAR(NCFTUR),   IAR(NCFTUR)
      EQUIVALENCE(BAR(1), IAR(1))

      LOGICAL FIRST
      DATA FIRST/.TRUE./

*--------statement functions for table access -------------*
*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.
*------------------------BEGIN ROUTINE-------------------------------
      IF(FIRST) THEN
        FIRST = .FALSE.
*       Format output banks...
        CALL BKFMT('FTUR','2I,(6F,I,9F,I,F,3I)')
        CALL BKFMT('FPUR','B16')
        CALL BKFMT('FRUX','B16')
        CALL BKFMT('FPUX','B16')
        CALL BKFMT('FPSX','2I,(I)')
        CALL BKFMT('FRSX','2I,(I)')

        IQFPSG = NAMIND('FPSG')
        IQFRSG = NAMIND('FRSG')
        IQFPLC = NAMIND('FPLC')
        IQFRLC = NAMIND('FRLC')
      ENDIF


*     Open BANKS
      NFRRE  = IW(IW(IQFRLC)+2)
      NFRPE  = IW(IW(IQFPLC)+2)
      IWFRUX = 0
      IWFPUX = 0

*     Get access to segment banks...
      IWFPSG = IW(IQFPSG)
      IWFRSG = IW(IQFRSG)


*     Work banks for pointer lists...
      NWRD = 2+NFRRE*2
      CALL WBANK(IW,IWFRUX,NWRD,*999)
      CALL VZERO(IW(IWFRUX+1),NWRD)
      IW(IWFRUX+1) = 2
      IW(IWFRUX+2) = NFRRE

      NWRD = 2+NFRPE*2
      CALL WBANK(IW,IWFPUX,NWRD,*999)
      CALL VZERO(IW(IWFPUX+1),NWRD)
      IW(IWFPUX+1) = 2
      IW(IWFPUX+2) = NFRPE

*
*     Loop over patrec tracks.
*
*     There are two lists of tracks to loop over containing
*     Radial-based and Planar-based tracks respectively.
*
*     Tracks in the radial-based list may have been rejected in
*     Favour of planars or not verified by a planar segment or
*     otherwise marked as bad (IGTTRK)
*
      IROWF  = 0

*     precalculate number of good radial segments in each module
      Do jmod = 1, 3
       NSR(jmod) = 0
       Do k = 1, NTRAKS(jmod)
         If( chsq(k, jmod) .le. 1000.) NSR(jmod) = NSR(jmod) + 1
       Enddo
      Enddo


      DO 900 ILIST = 1, 2

      IF(ILIST .EQ. 1) THEN
        ITMAX = IG
      ELSE
        ITMAX = NPP
      ENDIF
      DO 100 ITRK = 1, ITMAX

*      ILIST 2 (planar-based tracks) are O.K. Otherwise track
*      may have been rejected:-

       IF(ILIST.EQ.2   .OR.
     +   (IGTTRK(ITRK).EQ.0 .AND. IVRR(ITRK).EQ.1) ) THEN

        IROWF = IROWF + 1
        CALL SHS(711,0,7.01)
*
*       Pointer lists for FRRE and FRPE banks. First points on track.
*
        CALL FILHTS(ITRK, ILIST,
     +               NMRAD, IRPNT, IRSGN, IFRP,
     +               NMPLA, IPPNT, IPSGN, IFPP,
     +               ZF)
*
*       Get HELIX parameters for this track...
*
        CALL FHEPAR(ITRK, ILIST, ZF, CU, PHI0, TH, X0, Y0)
*
*       Build Supermodule Mask
        MASK = 0
        IF(ILIST.EQ.1) THEN
*        Planar segments from Rad-based tracks...
         DO 75 I=1,3
          IF(ISGG(I,ITRK) .NE. 0) THEN
           MASK = MASK + 2**(I+2)
          ENDIF
 75      CONTINUE
*        Radial segments from Rad-based tracks...
         DO 76 I=1,3
          IF(LNK3(ITRK,I) .NE. 0) THEN
           MASK = MASK + 2**(I-1)
          ENDIF
 76      CONTINUE
        ELSE
*        Planar segments from Pla-based tracks...
         DO 77 I=1,3
          IF(LPP(I,ITRK) .NE. 0) THEN
           MASK = MASK + 2**(I+2)
          ENDIF
 77      CONTINUE
*        Radial segments from Pla-based tracks...
         DO 78 I=1,3
          IF(LRR(I,ITRK) .NE. 0) THEN
           MASK = MASK + 2**(I-1)
          ENDIF
 78     CONTINUE
        ENDIF
*
*       Fill the FTUR and pointering bank, FPUR
*
        BAR(1)   = CU
        BAR(2)   = PHI0
        BAR(3)   = TH
        BAR(4)   = X0
        BAR(5)   = Y0
        BAR(6)   = ZF
*
        IAR(7)   = NPATYP
*
*       Words 8 - 16 will contain packed covariance matrix...
*       Zero for now...
        DO 650 KCOV = 1, 9
          BAR(7+KCOV) = 0.0
 650    CONTINUE
*
        IAR(17)  = 0
        BAR(18)  = 0
*
        IAR(19)  = 0
*
*       Pack number of planar and radial hits.
*
        NHTFTD   = NMRAD*16777216 + NMPLA*65536 + MASK
*
        IAR(20)  = NHTFTD
        IAR(21)  = IROWF
*
        IFTUR  = IADROW('FTUR',NBNN,NCFTUR,BAR)
*
*  Fill pointering bank:
*
        IAR(1)   = NMRAD
        IAR(2)   = IFRP
        IAR(3)   = NMPLA
        IAR(4)   = IFPP
*
        IFPUR  = IADROW('FPUR',NBNN,NCFPUR,BAR)
*
*  Now do the pointers to the segments. Where to look depends on
*  the type of track.
*
        IF(ILIST.EQ.1) THEN

*        Planar segments from Rad-based tracks...
         NPSG=0
         DO 680 I=1,3
          IF(ISGG(I,ITRK) .NE. 0) THEN
           NPSG = NPSG + 1
*          Calculate row number in segment bank FPSG...
           ISGMOD     = ISGG(I, ITRK)
           IF(I.GT.1) ISGMOD = ISGMOD + NFSEG(1)
           IF(I.GT.2) ISGMOD = ISGMOD + NFSEG(2)
           ISGPL(NPSG) = ISGMOD
          ENDIF
 680     CONTINUE

*        Radial segments from Rad-based tracks...
*        more complicated because IOS segment may have
*        failed Chisq test...

         NRSG=0
         ISGOFF = 0

         DO 780 I=1,3
          IF(LNK3(ITRK,I) .NE. 0) THEN

           NRSG = NRSG + 1
*          ...assumes that only good segments have been linked!

*          Calculate row number in segment bank FRSG...
*          ...offset by number of good segments in prior modules...
           ISGMOD = ISGOFF

*          ...and increment offset ready for next module...
           ISGOFF = ISGOFF + NSR(I)

*          IOS segment number in this module...
           KLN        = LNK3(ITRK,I)

*          add to ISGMOD passing over bad segments...
           do kk = 1, KLN
               If( chsq(kk, I) .le. 1000.)ISGMOD = ISGMOD + 1
           enddo

           ISGRA(NRSG) = ISGMOD

          ENDIF
 780     CONTINUE

        ELSE

*        Planar segments from Pla-based tracks...
         NPSG=0
         DO 685 I=1,3
          IF(LPP(I,ITRK) .NE. 0) THEN
           NPSG = NPSG + 1
*          Calculate row number in segment bank FPSG...
           ISGMOD     = LPP(I, ITRK)
           IF(I.GT.1) ISGMOD = ISGMOD + NFSEG(1)
           IF(I.GT.2) ISGMOD = ISGMOD + NFSEG(2)
           ISGPL(NPSG) = ISGMOD
          ENDIF
 685     CONTINUE


*        Radial segments from Pla-based tracks...
         NRSG=0
         ISGOFF = 0

         DO 785 I=1,3
          IF(LRR(I,ITRK) .NE. 0) THEN

           NRSG = NRSG + 1
*          ...assumes that only good segments have been linked!

*          Calculate row number in segment bank FRSG...
*          ...offset by number of good segments in prior modules...
           ISGMOD = ISGOFF

*          ...and increment offset ready for next module...
           ISGOFF = ISGOFF + NSR(I)

*          IOS segment number in this module...
           KLN        = LRR(I,ITRK)

*          add to ISGMOD passing over bad segments...
           do kk = 1, KLN
               If( chsq(kk, I) .le. 1000.)ISGMOD = ISGMOD + 1
           enddo

           ISGRA(NRSG) = ISGMOD
          ENDIF
 785     CONTINUE

        ENDIF

*
*       Now fill the cross-reference FPSX FRSX and update the
*       the FRSG FPSG banks with pointers to next segments...
*
        IF(NPSG .NE. 0) THEN
*        ...pointer to first segment on track...
         IAR(1) = ISGPL(1)
         IFPSX  = IADROW('FPSX',NBNN,NCFPSX,BAR)

*        ...and fill chain in FPSG bank...
         DO 690 KSG = 1, NPSG - 1
           IW(INDCR(IWFPSG,10,ISGPL(KSG))) = ISGPL(KSG+1)
 690     CONTINUE
         IW(INDCR(IWFPSG,10,ISGPL(NPSG))) = ISGPL(1)
        ELSE
*        ...pointer to first segment on track... is zero
         IAR(1) = 0
         IFPSX  = IADROW('FPSX',NBNN,NCFPSX,BAR)
        ENDIF

        IF(NRSG .NE. 0) THEN
*        ...pointer to first segment on track...
         IAR(1) = ISGRA(1)
         IFRSX  = IADROW('FRSX',NBNN,NCFRSX,BAR)

*        ...and fill chain in FRSG bank...
         DO 790 KSG = 1, NRSG - 1
           IW(INDCR(IWFRSG,10,ISGRA(KSG))) = ISGRA(KSG+1)
 790     CONTINUE
         IW(INDCR(IWFRSG,10,ISGRA(NRSG))) = ISGRA(1)
        ELSE
*        ...pointer to first segment on track... is zero
         IAR(1) = 0
         IFRSX  = IADROW('FRSX',NBNN,NCFRSX,BAR)
        ENDIF
*
*  Now fill appropriate rows of FRUX and FPUX banks
*       Radial point list...
        IF(NMRAD.GT.0) THEN
          DO 700 KRP=1,NMRAD-1
            IW(INDCR(IWFRUX,1,IRPNT(KRP))) = IRPNT(KRP+1)
            IW(INDCR(IWFRUX,2,IRPNT(KRP))) = IRSGN(KRP)
 700      CONTINUE
          IW(INDCR(IWFRUX,1,IRPNT(NMRAD))) = IRPNT(1)
          IW(INDCR(IWFRUX,2,IRPNT(NMRAD))) = IRSGN(NMRAD)
        ENDIF
*       Planar point list...
        IF(NMPLA.GT.0) THEN
          DO 800 KPP=1,NMPLA-1
            IW(INDCR(IWFPUX,1,IPPNT(KPP))) = IPPNT(KPP+1)
            IW(INDCR(IWFPUX,2,IPPNT(KPP))) = IPSGN(KPP)
 800      CONTINUE
          IW(INDCR(IWFPUX,1,IPPNT(NMPLA))) = IPPNT(1)
          IW(INDCR(IWFPUX,2,IPPNT(NMPLA))) = IPSGN(NMPLA)
        ENDIF

       ENDIF

 100  CONTINUE
 900  CONTINUE
*   End loop over tracks.

*   Close banks...
      IF(IROWF .GT. 0) THEN
        IFTUR  = IADFIN('FTUR',NBNN)
        IFPUR  = IADFIN('FPUR',NBNN)
        IFPSX  = IADFIN('FPSX',NBNN)
        IFRSX  = IADFIN('FRSX',NBNN)
      ELSE
*        make empty banks
        IFTUR = NBANK('FTUR',NBNN,2)
        IW(IFTUR+1) = NCFTUR
        IW(IFTUR+2) = 0

        IFPSX = NBANK('FPSX',NBNN,2)
        IW(IFPSX+1) = NCFPSX
        IW(IFPSX+2) = 0

        IFRSX = NBANK('FRSX',NBNN,2)
        IW(IFRSX+1) = NCFRSX
        IW(IFRSX+2) = 0

        NWRD = 2
        CALL WBANK(IW,IWFPUR,NWRD,*999)
        IW(IWFPUR+1) = NCFPUR
        IW(IWFPUR+2) = 0
        CALL BKFRW(IW,'FPUR',NBNN,IW,IWFPUR,*999)
        CALL WDROP(IW,IWFPUR)

      ENDIF

*   Pack work banks into named banks...
      CALL BKFRW(IW,'FRUX',NBNN,IW,IWFRUX,*999)
      CALL BKFRW(IW,'FPUX',NBNN,IW,IWFPUX,*999)

*   Add Banks to list...
      CALL BLIST(IW,'R+','FTUR')
      CALL BLIST(IW,'R+','FPUR')
      CALL BLIST(IW,'R+','FRUX')
      CALL BLIST(IW,'R+','FPUX')
      CALL BLIST(IW,'R+','FRLC')
      CALL BLIST(IW,'R+','FPLC')
      CALL BLIST(IW,'R+','FRHC')
      CALL BLIST(IW,'R+','FPHC')
      CALL BLIST(IW,'R+','FAUX')

      CALL BLIST(IW,'R+','FPSX')
      CALL BLIST(IW,'R+','FRSX')

*   ...and drop work banks...
      CALL WDROP(IW,IWFRUX)
      CALL WDROP(IW,IWFPUX)
      RETURN

*     Error ...
 999  CONTINUE
      WRITE(6,*) ' FPTOUT>> Error in work bank creation.'
      CALL WDROP(IW,IWFRUX)
      CALL WDROP(IW,IWFPUX)
      RETURN


      END
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  12.24.13  by  Stephen Burke
*CMZU:  3.08/03 28/02/93  18.42.41  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   21/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
        SUBROUTINE FILHTS(ITRK, ILIST,
     +               NMRAD, IRPNT, IRSGN, IFRP,
     +               NMPLA, IPPNT, IPSGN, IFPP,
     +               ZBEG)
*
*     Builds lists of pointers into FRRE and FRPE banks for
*     hits on the track ITRK. ILIST tells which pointers to go
*     for (rad-based tracks or pla-based tracks.
*
*     The first radial and planar hit is found and the Z of the
*     first hit (radial or planar) on the track (where the track
*     parameters will be given)
*
*
*
*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEND.
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
      COMMON/FKLOC/KLOC(100)

      DIMENSION IRPNT(36), IPPNT(36)
      DIMENSION IRSGN(36), IPSGN(36)
      IFPP =  0
      NMPLA=  0
      IFRP =  0
      NMRAD=  0
      ZBEGR = 1000.
      ZBEGP = 1000.
      KFPWIR = 1000
      KFRWIR = 1000
      DO 200 KMOD=0, 2

        DO 300 IWIR=1,12
*         Planars
          KWIR   = IWIR + KMOD*12
          IF(ILIST.EQ.1) THEN
           JP     = IRP(KWIR,ITRK)
           SIGP   = SDP(KWIR, ITRK)
          ELSE
           JP     = IPP(KWIR,ITRK)
           SIGP   = SPP(KWIR, ITRK)
          ENDIF

          IF( SIGP .GT. 0) THEN
             JPSIGN = 0
          ELSE
             JPSIGN = 1
          ENDIF

          IF( JP .NE. 0) THEN
           IF(IPFRPE(JP,KWIR) .NE. 0) THEN
            NMPLA  = NMPLA  + 1
            IF(IFPP.EQ.0) THEN
              IFPP = IPFRPE(JP,KWIR)
              ZBEGP= ZPP(KWIR)
              KFPWIR = KWIR
            ENDIF
            IPPNT(NMPLA) = IPFRPE(JP,KWIR)
            IPSGN(NMPLA) = JPSIGN
           ELSE
            CALL ERRLOG(125,'S:FILHTS: Planar pointer list corrupted')
           ENDIF
          ENDIF
 300    CONTINUE
        DO 400 IWIR=1,12
*         Radials
          KWIR = IWIR + KMOD*12
          IF(ILIST.EQ.1) THEN
           JR     = IRN(KWIR,ITRK)
           SIGR   = SDN(KWIR, ITRK)
          ELSE
           JR     = IRR(KWIR,ITRK)
           SIGR   = SRR(KWIR, ITRK)
          ENDIF

          IF( SIGR .GT. 0) THEN
             JRSIGN = 0
          ELSE
             JRSIGN = 1
          ENDIF

          IF( JR .NE. 0) THEN
           IF(IPFRRE(JR,KWIR) .NE. 0) THEN
            NMRAD  = NMRAD  + 1
            IF(IFRP.EQ.0) THEN
              IFRP  = IPFRRE(JR,KWIR)
              ZBEGR = ZP(KWIR)
              KFRWIR = KWIR
            ENDIF
            IRPNT(NMRAD) = IPFRRE(JR,KWIR)
            IRSGN(NMRAD) = JRSIGN
           ELSE
            CALL ERRLOG(126,'S:FILHTS: Radial pointer list corrupted')
           ENDIF
          ENDIF
 400    CONTINUE

 200  CONTINUE


      ZBEG   = ZBEGP
      IF(ZBEGR.LT.ZBEGP)ZBEG=ZBEGR

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.08/03 22/11/92  14.35.43  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   21/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FHEPAR(K, ILIST, ZF, CU, PH, TH, X0, Y0)
*
*     Calculate track parameters for the ITRK'th track from the
*     Slopes and intercepts of the R-z and Phi-z fits.
*     INPUT: Track number K
*            ILIST track type (1-rad-based/2=pla-based)
*            ZF  z of first measured point
*
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEND.
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)

      IF(ILIST .EQ. 1) THEN
        SLPHI =RPCOSG(K)
        SLPR  =RPSING(K)
        PHZER =PHZG(K)
        RZER  =ZIG(K)
      ELSE
        SLPHI =PSSS(K)
        SLPR  =RSSS(K)
        PHZER =PISS(K)
        RZER  =RISS(K)
      ENDIF

      RR = SLPR  * ZF + RZER
      PHI= SLPHI * ZF + PHZER

      X0 = RR*COS(PHI) + XVV
      Y0 = RR*SIN(PHI) + YVV



      IF(SLPHI .EQ.0.0)THEN
       CU = 0.0
      ELSE
       BETA = SLPR/SLPHI
       U    = SQRT(RR*RR + BETA*BETA)
       CU = SIGN(1.,SLPHI)*(RR*RR + 2.0*BETA*BETA)/(U**3)
      ENDIF

      DXDZ = SLPR*COS(PHI) - RR*SLPHI*SIN(PHI)
      DYDZ = SLPR*SIN(PHI) + RR*SLPHI*COS(PHI)

      TH = ATAN(SQRT(SLPR**2 + (RR*SLPHI)**2))
      PH = ATAN2(DYDZ,DXDZ)

      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.37.53  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  12.13.21  by  Stephen Burke
*CMZU:  3.08/03 04/03/93  13.52.54  by  Stephen J. Maxfield
*-- Author :    I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTVDET
C     DRIFT VELOCITY DETERMINATION PER TRACK FOR RADIALS
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


*     Common for segment numbers...
      COMMON /FPSEGN/ ISG(3,MAXTRK)

*     COMMON FOR PLANAR PATREC  ...
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
C     POINTER TO RADIAL ASSOCIATED WITH NPP'TH PLANAR
      COMMON/FPPTR/LR(3,100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
C     COMMON FOR RADIALS ASSOCIATED WITH PLANAR TRACKS
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
*     Local arrays...
      DIMENSION IUSEDP(MAXTRK,36), IUSEG( MAXSEG, 3)
      DIMENSION RSEG(4),PSEG(4)
      PARAMETER(PI2=6.2831853)
      DO 100 K=1,NPP
C     CHECK WHICH PLANAR MODULES ARE FOUND
      IP1=0
      IP2=0
      IP3=0
      DO 70 IP=1,36
      IF(IP.GT.01.AND.IP.LE.12.AND.IPP(IP,K).NE.0)IP1=1
      IF(IP.GT.12.AND.IP.LE.24.AND.IPP(IP,K).NE.0)IP2=1
      IF(IP.GT.24.AND.IP.LE.36.AND.IPP(IP,K).NE.0)IP3=1
 70   CONTINUE
      SME=0.
      SEE=0.
      SSS=0.
      STZ=0.
      DO 50 ISM=1,3
      IP=LRR(ISM,K)
      IF(IP.EQ.0)GOTO50
      DO 22 IPL=1,12
C     CHECK RADIAL BETWEEN PLANAR SEGMENTS
      IF(ISM.EQ.1.AND.(IP1.EQ.0.OR.IP2.EQ.0))GOTO22
      IF(ISM.EQ.2.AND.(IP2.EQ.0.OR.IP3.EQ.0))GOTO22
      JPL=IPL+(ISM-1)*12
      NP=IRPT(IPL,IP,ISM)
      IF(NP.NE.0)THEN
      RR=RSSS(K)*ZP(JPL)+RISS(K)
      PHI=PSSS(K)*ZP(JPL)+PISS(K)
      IF(PHI.LT.0.0)PHI=PHI+PI2
      DRE=RR*SIN(PHI-WW(NP,JPL))
      IF (DRE.NE.0.) THEN
         SGN=DRE/ABS(DRE)
      ELSE
         SGN = 1.
      ENDIF
      DRMM=SDRFT(IPL,IP,ISM)*DRI(NP,JPL)+DWS(NP,JPL)
      IF(ABS(DRE-DRMM).LT.0.5)THEN
        IF(IP1.EQ.1.AND.IP2.EQ.1.AND.ISM.EQ.1)THEN
C       CALL SHS(704+ISM,0.,DRE-DRMM)
        SEE=SEE+DRE*DRE
        SME=SME+DRMM*DRE
        STZ=STZ+(DRMM-DRE)*SGN
        SSS=SSS+1.0
        ENDIF
        IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.2)THEN
C       CALL SHS(704+ISM,0.,DRE-DRMM)
        SEE=SEE+DRE*DRE
        SME=SME+DRMM*DRE
        STZ=STZ+(DRMM-DRE)*SGN
        SSS=SSS+1.0
        ENDIF
C       IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.3)THEN
C       CALL SHS(704+ISM,0.,DRE-DRMM)
C       SEE=DRE*DRE
C       SME=DRMM*DRE
C       SSS=SSS+1.0
C       ENDIF
      ENDIF
      ENDIF
 22   CONTINUE
 50   CONTINUE
      IF(SSS.GT.4)THEN
C     CALCULATE VELOCITY CORRECTION
      VFAC=SME/SEE
      CALL SHS(761,0,VFAC)
      TZ=STZ/SSS
      CALL SHS(762,0,TZ  )
      ENDIF
 100  CONTINUE
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.37.53  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.15  by  Stephen Burke
*CMZU:  3.08/03 29/11/92  16.36.58  by  Stephen J. Maxfield
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTZFIT(TZZ,NPAR,ZVERT,IMSTDY)
**: FTZFIT.......SM. New routine for monitoring.
**----------------------------------------------------------------------
C
C
C     TRY MODS TO FIT VELOCITY FACTOR TO RADIALS
C
C
C
C     MODIFIED TO WORK ON PLANAR-BASED PATTERN RECOGNITION
C     NOTE ROUTINES OF SAME NAME IN GRFTRAC !!!!!!!!!!!!!!
C
C
C     FIT PLANAR TRACKS TO GET T0 , FILL VERTEX HISTOGRAMS...
C     IF IRPIK=1    USE RADIAL POINTS ALSO
C     DMIN CUT INTRODUCED FOR PLANAR POINTS 25/2/92
C     PUT  (Z-200.) IN ALL TERMS   26/2/92
C     CHANGE TO Z  28/2/92  TO GET MOMENTUM
C     ADD RESIDUAL PRINT     2/3/92
C     TRY DRIFT VELOCITY DETERMINATION.. ...DOES NOT WORK
C     DUE TO STRONG CORRELATION WITH TIME-ZERO
C
C     27/4/92  INTRODUCE SECTION TO COMPARE SLOPE OF LINE SEGMENT
C     IN VERTICAL WIRES WITH FITTED LINE BETWEEN PLANAR CHAMBERS.
C     RATIO OF SLOPES SHOULD BE RATIO OF ASSUMED AND TRUE DRIFT
C     VELOCITIES .  FIND A VALUE CIRCA 1.02   THIS VALUE
C     GIVES BETTER RESIDUALS IN PLANARS. COSTXT NOW HAS 42.15
C     FOR PLANARS
C     1 /5/92  INCLUDE SECTION FOR RADIALS
C
      SAVE
*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FPFVTX.
      COMMON/VERTFF/ZFF,XFF,YFF
*
*KEND.
*
*FOR PLOTS...
*KEEP,FRPLTA.
      COMMON/PLOTA/KKK
*KEND.
*FTTRAC RESULTS (SJM)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEND.
*
*
*
*
      COMMON /FTTAKS/NTKSV,
     1   VXV(20),VYV(20),VZV(20),VFL(20),VFM(20),VFN(20),VR(20)
      COMMON/DISPL/IWKID
      COMMON/TRUTH/PTR(199),LLTT(3,199),NLT,THAAA(199,2),PHITR(199,2)
      COMMON/REZZID/RPH(4,72),RRZ(4,72),IPH(72),IRZ(72),INP,INR
      COMMON/PCLOSE/IPC(99,99)
      COMMON /FLINK3/LNK3(MAXTRK,3)
      COMMON/CORRXY/CX1,CX2,CX3,CY1,CY2,CY3
C      COMMON/FTVERT2/NNFTV,FLPP(10000),FMPP(10000),
C     1 FXPP(10000),FYPP(10000)
*
      COMMON/CMPR/PHID(200),PHIZ(200),RRD(200),RZZ(200),CHIF(200)
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.

************************************************************************
C       XXX ADDED 3/3/92
      COMMON/FPLFIT/NNDATA,MATOT,AA(100,50),YYY(100),SSIG(100),XXX(100)
      COMMON /FPLOUT/TZ,F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,CHI
C                    TZ=TIME-ZERO
C     ADDED  FOR RESIDUAL CHECK
      COMMON /FPRES/NPLA,RES(100),IPRES(100),THET(100)
      COMMON /FPSCAL/SF1,SF2,WZER(100)
C     BANKS FOR PLANAR PATTERN RECOGNITION
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
C     COMMON FOR RADIALS ASSOCIATED WITH PLANAR TRACKS
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
C     PLANAR SEGMENTS ASSOCIATED  WITH RADIALS
C     ISGG POINTS TO ROB'S SEGMENT BANKS
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      DIMENSION ARES(100),INX(100)
************************************************************************
C     GLOBAL FIT TO PLANAR LINE SEGMENTS
C     NPAR=4 STRAIGHT LINE IN X-Z , Y-Z PLANES
C     NPAR=6 PARABOLAE IN X-Z, Y-Z PLANES
C*********************************************************************
C     WITH SUITABLE MODS CAN FIT ALL MODULES SIMULTANEOUSLY
C     (EACH MODULE TO A (DIFFERENT) STRAIGHT LINE )
C     OR EACH TRACK TO A STRAIGHT LINE OR PARABOLA)
       DATA ISTART/0/
       DATA IITART/0/

C     MINIMUM NUMBER OF PLANAR POINTS
      NNPLA=20
C     NNPLA=25
C     PICK UP PLANAR POINTS ONLY IF DRIFT > DMIN
C     TO AVOID WRONG SIGN POINTS
      DMIN=0.5
C     TO USE RADIAL POINTS IRPIK=1
      IRPIK=1
      IF(ISTART.EQ.0)THEN
      ISTART=1
      IHX=3000
      CALL STEXT(IHX+270,4,' PROJECTED VERTEX  X       ' )
      CALL BHS(IHX+270,0,50,-5.,5.)
      CALL STEXT(IHX+271,4,' PROJECTED VERTEX  Y       ' )
      CALL BHS(IHX+271,0,50,-5.0,5.0)
      CALL STEXT(IHX+272,4,' 1/P FROM FIT              ' )
      CALL BHS(IHX+272,0,50,-2.5,2.5)
      CALL STEXT(IHX+273,4,' 1/P FROM FIT CHI < 5     ' )
      CALL BHS(IHX+273,0,50,-2.5,2.5)
      CALL STEXT(IHX+273,4,' 1/P FROM FIT CHI < 5     ' )
      CALL BHS(IHX+273,0,50,-2.5,2.5)
      CALL STEXT(IHX+280,4,' VFACTOR MEAS/PRED CHI < 5  PLANAR' )
      CALL BHS(IHX+280,0,50,00.5,1.5)
      CALL STEXT(IHX+281,4,'  SLOPE PREDICTED PLANAR         ' )
      CALL BHS(IHX+281,0,50,-0.5,0.5)
      CALL STEXT(IHX+282,4,'  SLOPE MEAS   PLANAR           ' )
      CALL BHS(IHX+282,0,50,-0.5,0.5)
      CALL STEXT(IHX+283,4,'  SLOPE MEAS -SLOPE PRED  PLANAR' )
      CALL BHS(IHX+283,0,50,-0.1,0.1)
      CALL STEXT(IHX+290,4,' VFACTOR MEAS/PRED CHI < 5  RADIAL' )
      CALL BHS(IHX+290,0,50,00.5,1.5)
      CALL STEXT(IHX+291,4,'  SLOPE PREDICTED RADIAL         ' )
      CALL BHS(IHX+291,0,50,-0.5,0.5)
      CALL STEXT(IHX+292,4,'  SLOPE MEAS   RADIAL           ' )
      CALL BHS(IHX+292,0,50,-0.5,0.5)
      CALL STEXT(IHX+293,4,'  SLOPE MEAS -SLOPE PRED  RADIAL' )
      CALL BHS(IHX+293,0,50,-0.1,0.1)
      IF(IRPIK.EQ.0)WRITE(*,*)' RADIALS NOT USED IN T0 FIT '
      IF(IRPIK.EQ.1)WRITE(*,*)' RADIALS     USED IN T0 FIT '
      WRITE(*,*)' FTZFIT DMIN,NNPLA=  ',DMIN,NNPLA
C     WRITE(*,*)' FTZFIT MIN # PLANAR PTS=  ',NNPLA
      WRITE(*,*)' RADIALS *NOT* DOWN-WEIGHTED  SIG =1000 MICRONS'
      WRITE(*,*)' PLANARS                SIG = 300 MICRONS'
      WRITE(*,*)' PLANARS  NO DMIN CUT,20 POINTS MIN      '
      WRITE(*,*)' NPAR = ',NPAR
      ENDIF
      IITART=IITART+1
      DO 3210 I=1,100
      DO 3211 II=1,50
      AA(I,II)=0.
 3211 CONTINUE
 3210 CONTINUE
C     COUNTS DATA POINTS
      NNDATA=0
C     COUNTS TRACK SEGMENTS
      NTT=0
C     LOOP TRACKS
C     WRITE(*,*)' NPP ',NPP
      DO 3000 K=1,NPP
C     WRITE(*,*)' FTZFIT K IRP,IRN ',K
CC    PRINT 1000,(IPP(JJ,K),JJ=1,36)
CC    PRINT 1001,(SPP(JJ,K),JJ=1,36)
CC    PRINT 1000,(IRR(JJ,K),JJ=1,36)
CC    PRINT 1001,(SRR(JJ,K),JJ=1,36)

C     TO FIT EACH TRACK FOR T0 - THESE  LINES  ADDED------------
      NTT=0
      NNDATA=0
      DO 3200 I=1,100
      DO 3201 II=1,50
      AA(I,II)=0.
 3201 CONTINUE
 3200 CONTINUE
C     --------------------------------------TO HERE
C     MODULES
      DO 3010 IMOD=1,3
      IGSEG=0
C     ORIENTATIONS
      DO 3020 IM=1,3
      IPT=0
C     WIRES /ORIENTATION
      DO 3030 IP=1,4
      IPL=IP+(IM-1)*4+(IMOD-1)*12
      IF(IPP(IPL,K).GT.0)THEN
      IPT=IPT+1
      ENDIF
 3030 CONTINUE
      IF(IPT.GE.2)IGSEG=IGSEG+1
 3020 CONTINUE
CTEMP IF(IGSEG.NE.3)GOTO3010
C     GOOD SEGMENT- AT LEAST 2 POINTS/PLANAR ORIENTATION
C     SUM SEGMENTS
      NTT=NTT+1
C     TO FIT WHOLE TRACK--- ADD NEXT LINE ----------
      NTT=1
C     WHOLE TRACK FITTED AS STRAIGHT LINE WITH T0 FIT
C     5 PARAMETER FIT
C------------------------------------------------------------
      IF(NTT.LE.8)THEN
C     FILL POINTS
      DO 3040 IM=1,3
      DO 3050 IP=1,4
      IPL=IP+(IM-1)*4+(IMOD-1)*12
      J=IPP(IPL,K)
      IF(J.EQ.0)GOTO3050
C     IF(DRIW(J,IPL).LT.DMIN)GOTO3050
      NNDATA=NNDATA+1
      IPRES(NNDATA)=IPL
      THET(NNDATA)=ATAN2(S(IPL),C(IPL))
C     IF(IITART.LT.10)WRITE(*,*)' FTZFIT  THET PLA ',THET(NNDATA)
      XXX(NNDATA)=ZPP(IPL)
      YYY(NNDATA)=SPP(IPL,K)*DRIW(J,IPL)+DW(J,IPL)
      WZER(NNDATA)=DW(J,IPL)
      KKK=4*(NTT-1)
C     DY/DZ
      AA(NNDATA,KKK+1)= (ZPP(IPL)- 00.)*C(IPL)
C     YZ
      AA(NNDATA,KKK+2)=          C(IPL)
C     DX/DZ
      AA(NNDATA,KKK+3)=-(ZPP(IPL)- 00.)*S(IPL)
C     XZ
      AA(NNDATA,KKK+4)=         -S(IPL)
C     PLUS
C     TWO TERMS TO GIVE CURVATURE---RY,RX--------------
      IF(NPAR.EQ.6.OR.NPAR.EQ.7) THEN
      AA(NNDATA,KKK+5)= (ZPP(IPL)- 00.)**2*C(IPL)
      AA(NNDATA,KKK+6)=-(ZPP(IPL)- 00.)**2*S(IPL)
      ENDIF
C     ------------------------------------------------
      AA(NNDATA,KKK+7)=        0.0
C
      AA(NNDATA,50)= SPP(IPL,K)
      SSIG(NNDATA)=   0.030
**********************************************************
C     DOWN WEIGHT PLANAR MODULE TO BE STUDIED
      IMM=(IPL-1)/12
C     IF(IMM.EQ.0)SSIG(NNDATA)=SSIG(NNDATA)*100.
C     IF(IMM.EQ.1)SSIG(NNDATA)=SSIG(NNDATA)*100.
C     IF(IMM.EQ.2)SSIG(NNDATA)=SSIG(NNDATA)*100.
**********************************************************
 3050 CONTINUE
 3040 CONTINUE
      ELSE
      NTT=NTT-1
      GOTO 3060
      ENDIF
 3010 CONTINUE
C     STORE NNDATA VALUE FOR PLANARS
      NPLA=NNDATA
C     ADD POINT COUNT CHECK INSTEAD OF SEGMENT COUNT
C     WRITE(*,*)' FTZFIT NPLA ',NPLA
      IF(NNDATA.LT.NNPLA)GOTO3000
C     PICK UP RADIALS .............................................
      IF(IRPIK.EQ.1)THEN
      DO 3070 IPL=1,36
      IM=(IPL-1)/12
      J=IRR(IPL,K)
      IF(J.EQ.0)GOTO3070
      NNDATA=NNDATA+1
      IPRES(NNDATA)=IPL
C     ADDED 3/3/92
      XXX(NNDATA)=ZP(IPL)
      YYY(NNDATA)=SRR(IPL,K)*DRI(J,IPL)+DWS(J,IPL)
      WZER(NNDATA)=DWS(J,IPL)
      CCC=COS(WW(J,IPL)+0.0000)
      SSS=SIN(WW(J,IPL)+0.0000)
      THET(NNDATA)=ATAN2(SSS   ,CCC   )
C     IF(IITART.LT.10)WRITE(*,*)' FTZFIT THET RAD',THET(NNDATA),
C    1   WW(J,IPL)
      KKK=4*(NTT-1)
C     DY/DZ
      AA(NNDATA,KKK+1)= (ZP(IPL)- 00.)*CCC
C     YZ
      AA(NNDATA,KKK+2)=         CCC
C     DX/DZ
      AA(NNDATA,KKK+3)=-(ZP(IPL)- 00.)*SSS
C     XZ
      AA(NNDATA,KKK+4)=        -SSS
C     PLUS
C     TWO TERMS TO GIVE CURVATURE---RY,RX--------------
      IF(NPAR.EQ.6.OR.NPAR.EQ.7) THEN
      AA(NNDATA,KKK+5)= (ZP(IPL)- 00.)**2*CCC
      AA(NNDATA,KKK+6)=-(ZP(IPL)- 00.)**2*SSS
      ENDIF
C     ------------------------------------------------
      IF(NPAR.EQ.7)THEN
C     CORRECT DRIFT BY A FACTOR FOR WRONG VELOCITY
      AA(NNDATA,KKK+7)=        YYY(NNDATA)
      ENDIF
      IF(NPAR.EQ.5)THEN
C     CORRECT DRIFT BY A FACTOR FOR WRONG VELOCITY
      AA(NNDATA,KKK+5)=        YYY(NNDATA)
      ENDIF
C
      AA(NNDATA,50)= SRR(IPL,K)
      SSIG(NNDATA)=   0.100
C
C
C
C
C
******************************************************************
C     DOWN-WEIGHT RADIAL MODULE TO BE STUDIED   IM=0,1,2
C     IM=2 GIVES SYSTEMATIC SHIFT AT LOW MOMENTA AND SIG=2.0
C     DUE TO EXTRAPOLATION FROM PLANARS
**    IF(IM.EQ.0)SSIG(NNDATA)=SSIG(NNDATA)*100.
**    IF(IM.EQ.1)SSIG(NNDATA)=SSIG(NNDATA)*100.
**    IF(IM.EQ.2)SSIG(NNDATA)=SSIG(NNDATA)*100.
******************************************************************
C     NOTE ANGLE SELECTION FOR RESIDUALS IN FXLFIT
******************************************************************
C
C
C
C
C
 3070 CONTINUE
      ENDIF
C.................................END RADIAL PICKUP SECTION
C     NEXT     LINE  FOR FIT /TRACK  -------------------------
      MATOT=NTT*NPAR
*********************************************
*********************************************
*********************************************
C     IF NO RADIAL DATA DO NOT FIT ADDITIONAL PARAMETER
      IF(NNDATA.EQ.NPLA)MATOT=MATOT-NTT
C     TO SET TO NORMAL 6 PARAMETER FIT UNCOMMENT NEXT LINE
CC    IF(NPAR.EQ.6)MATOT=NTT*6
C     TO SET TO NORMAL 4 PARAMETER FIT UNCOMMENT NEXT LINE
CC    IF(NPAR.EQ.4)MATOT=NTT*4
******************************************************
******************************************************
******************************************************
C     FIT W= (YZ+YD*(Z- 00.)+YR*(Z- 00.)**2 )*COS(THETA)
C           -(XZ+XD*(Z- 00.)+XR*(Z- 00.)**2 )*SIN(THETA)
C     WRITE(*,*) NPLA,(IPRES(KK),KK=1,NNDATA)
      IF(NTT.NE.0)CALL FXLFIT(NPAR)
      IF(NTT.NE.0)THEN
      IF(NPAR.EQ.4)F5=0.
      IF(NPAR.EQ.4)F6=0.
C     F1=DY , F3=DX
      FL=F3/SQRT(F3**2+F1**2)
      FM=F1/SQRT(F3**2+F1**2)
C     X,Y INTERCEPTS AT Z=ZVERT
      XZ=F3*(ZVERT- 00.)+F4+(ZVERT- 00.0)**2*F6
      YZ=F1*(ZVERT- 00.)+F2+(ZVERT- 00.0)**2*F5
C     TRACKS ALONG Y(X) AXIS DETERMINE X(Y) VERTEX.
      IF(ABS(FM).GT.0.7)CALL   SHS(IHX+270,0,XZ)
      IF(ABS(FL).GT.0.7)CALL   SHS(IHX+271,0,YZ)
      ENDIF
C
C     -------------------------------------------------------
      IF(NTT.NE.0.AND.NPAR.EQ.6)THEN
C     SECTION TO CALCULATE 1/PZ FOR TEST PURPOSES
      S1=0.
      S2=0.
C     SIGN CHANGE NEEDED FOR 'X' PARABOLA TERM
      FF6=0.
      FF5=0.
      IF(F1.NE.0.)FF6=-F6/F1
      IF(F3.NE.0.)FF5=F5/F3
      IF(FF6.NE.0.0)S1=FF6/ABS(FF6)
      IF(FF5.NE.0.0)S2=FF5/ABS(FF5)
      SS=S1
      IF(S1.NE.S2)THEN
      IF(ABS(F5).GT.ABS(F6))SS=S2
      ENDIF
      IF(S1.EQ.0.0)SS=S2
      IF(S2.EQ.0.0)SS=S1
      TTHET=SQRT(F1**2+F3**2)
      RPZ=2.*SQRT(F6**2+F5**2)/(0.0002998*12.*TTHET)*SS
      CALL   SHS(IHX+272,0,RPZ)
C     IF(ABS(RPZ).LT.0.5)THEN
      IF(CHI.LT.5.)CALL   SHS(IHX+273,0,RPZ)
C     ENDIF
***   WRITE(*,*)' FTZFIT  1/PZ  =  ',RPZ,S1,S2,SS
      WRITE(*,*)' F6,F1,F5,F3,F7 ',F6,F1,F5,F3,F7
      WRITE(*,*)' TZ  CHI',TZ,CHI
      ENDIF
C     -------------------------------------------------------
C     CHECK VELOCITY DETERMINATION - VERTICAL WIRES -PLANAR
      DO 3500 IM=1,3
      IPL=(IM-1)*12+1
      J=IPP(IPL,K)
      IF(J.EQ.0)GOTO3500
      SGN=SPP(IPL,K)
      KK=1
      XXX(KK)=ZPP(IPL)
      YYY(KK)=SPP(IPL,K)*DRIW(J,IPL)+DW(J,IPL)
      DO 3510  KKK=1,3
      IP=IPL+KKK
      J=IPP(IP,K)
      IF(J.EQ.0)GOTO3510
      IF(SPP(IP,K).NE.SGN)GOTO3510
      KK=KK+1
      XXX(KK)=ZPP(IP)
      YYY(KK)=SPP(IP,K)*DRIW(J,IP)+DW(J,IP)
 3510 CONTINUE
      IF(KK.NE.4)GOTO3500
C     FIT  SLOPE
      CALL FTLFT(XXX,YYY,KK,0,SLPM,B,E)
C     PREDICTED SLOPE
      SLPP=(F3+F6*(XXX(1)+XXX(4)))
      CALL SHS(IHX+281,0.,SLPP)
      CALL SHS(IHX+282,0.,SLPM)
      IF(ABS(SLPM-SLPP).LT.0.1)THEN
      IF(SLPP.GT.0.0)CALL SHS(IHX+283,0.,SLPM-SLPP)
      IF(SLPP.LT.0.0)CALL SHS(IHX+283,0.,SLPP-SLPM)
      ENDIF
      IF(ABS(SLPP).GT.0.10.AND.CHI.LT.5.0)THEN
C     WRITE(*,*)' SLOPE MEAS PRED  P',SLPM,SLPP,SLPM/SLPP
      IF(SLPM/SLPP.GT.0.5.AND.SLPM/SLPP.LT.1.5)
     1CALL SHS(IHX+280,0.,SLPM/SLPP)
      ENDIF
 3500 CONTINUE
C     -------------------------------------------------------
C     ----AS FILTER FORTRAN  (IOSXA ) SOME LINES REMOVED  4/5/92
C     CHECK VELOCITY DETERMINATION -  RADIAL
C     MODULES WITHIN PLANAR SYSTEM ONLY
      DO 3600 IM=1,2
      IPL=(IM-1)*12
      SGN=0.
      KK=0
      DO 3610  KKK=1,8
      IP=IPL+KKK
      J=IRR(IP,K)
      IF(J.EQ.0)GOTO3610
      IF(SGN.EQ.0.)SGN=SRR(IP,K)
      IF(SRR(IP,K).NE.SGN)GOTO3610
      XR=F3*ZP(IP)+F4+ZP(IP)**2*F6
      YR=F1*ZP(IP)+F2+ZP(IP)**2*F5
      KK=KK+1
      IF(KK.EQ.1)THEN
C     FIRST POINT
      W1=YR*COS(WW(J,IP))-XR*SIN(WW(J,IP))
      ENDIF
C     LAST POINT
      W2=YR*COS(WW(J,IP))-XR*SIN(WW(J,IP))
      XXX(KK)=ZP(IP)
      YYY(KK)=SRR(IP,K)*DRI(J,IP)+DWS(J,IP)
 3610 CONTINUE
      IF(KK.LT.5)GOTO3600
C     FIT  SLOPE
      CALL FTLFT(XXX,YYY,KK,0,SLPM,B,E)
C     PREDICTED SLOPE RELATIVE TO ANODE PLANE
      SLPP=(W2-W1)/(XXX(KK)-XXX(1))
      CALL SHS(IHX+291,0.,SLPP)
      CALL SHS(IHX+292,0.,SLPM)
      IF(ABS(SLPP).LT.0.1.AND.CHI.LT.5.0)THEN
      IF(SLPP.GT.0.0)CALL SHS(IHX+293,0.,(SLPM-SLPP))
      IF(SLPP.LT.0.0)CALL SHS(IHX+293,0.,(SLPP-SLPM))
      ENDIF
      IF(ABS(SLPP).GT.0.0500.AND.CHI.LT.5.0)THEN
C     WRITE(*,*)' SLOPE MEAS PRED R',SLPM,SLPP,SLPM/SLPP
      IF(SLPM/SLPP.GT.0.5.AND.SLPM/SLPP.LT.1.5)
     1CALL SHS(IHX+290,0.,SLPM/SLPP)
      ENDIF
 3600 CONTINUE
 3000 CONTINUE
 3060 CONTINUE
C     NEXT TWO LINES FOR FIT ALL SEGMENTS
CO    MATOT=NTT*4
CO    IF(NTT.NE.0)CALL FXLFIT
 1000 FORMAT(' ',12I2,2X,12I2,2X,12I2)
 1001 FORMAT(' ',12F3.0,2X,12F3.0,2X,12F3.0)
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.28.57  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZU:  3.08/03 29/11/92  16.40.36  by  Stephen J. Maxfield
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FXLFIT(NPAR)
C     3/2/92 SEARCH FOR BAD POINTS AND REFIT
      SAVE
*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.
C     XX ADDED FOR RESIDUAL CHECK - MEDFIT
      COMMON /FPLFIT/NNDATA,MATOT,AA(100,50),YY(100),SSIG(100),XX(100)
      COMMON /FPLOUT/TZ,F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,CHI
      COMMON /FPRES/NPLA,RES(100),IPRES(100),THET(100)
      COMMON /FPSCAL/SF1,SF2,WZER(100)
      DIMENSION ARES(100),INX(100)
      PARAMETER (MMAX=50,NDATA=510,MA=50,NCVM=100)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),A(MA),LISTA(MA),
     1 COVAR(NCVM,NCVM),BETA(MMAX),AFUNC(MMAX)
       DATA ISTART/0/
      IF(ISTART.EQ.0)THEN
      ISTART=1
      IHX=3000
      CALL STEXT(IHX+250,4,' TIME0 PLANAR FIT          ' )
      CALL BHS(IHX+250,0,50,-1.,1.)
      CALL STEXT(IHX+251,4,' TIME0 PLANAR FIT          ' )
      CALL BHS(IHX+251,0,50,-0.1,0.1)
      CALL STEXT(IHX+252,4,' CHI   PLANAR FIT          ' )
      CALL BHS(IHX+252,0,50,0.,10.)
      CALL STEXT(IHX+253,4,' TIME0 PLANAR FIT CHI <5    ' )
      CALL BHS(IHX+253,0,50,-1.,1.)
      CALL STEXT(IHX+254,4,' TIME0 PLANAR FIT CHI <5   ' )
      CALL BHS(IHX+254,0,50,-0.1,0.1)
      CALL STEXT(IHX+255,4,' ERROR IN T0      FIT CHI <5   ' )
      CALL BHS(IHX+255,0,50,0.0,0.025)
      CALL STEXT(IHX+256,4,' # POINTS IN T0 FIT          ' )
      CALL BHS(IHX+256,0,50,0.0,100. )
      CALL STEXT(IHX+257,4,' RESIDUAL CHI < 5  PLANARS  M0  ' )
      CALL BHS(IHX+257,0,50,-5.0,5.0 )
      CALL STEXT(IHX+258,4,' RESIDUAL CHI < 5  PLANARS  M1  ' )
      CALL BHS(IHX+258,0,50,-5.0,5.0 )
      CALL STEXT(IHX+259,4,' RESIDUAL CHI < 5  PLANARS  M2  ' )
      CALL BHS(IHX+259,0,50,-5.0,5.0 )
      CALL STEXT(IHX+260,4,' RESIDUAL CHI < 5  RADIALS  M0 ' )
      CALL BHS(IHX+260,0,50,-5.0,5.0 )
      CALL STEXT(IHX+261,4,' RESIDUAL CHI < 5  RADIALS  M1 ' )
      CALL BHS(IHX+261,0,50,-5.0,5.0 )
      CALL STEXT(IHX+262,4,' RESIDUAL CHI < 5  RADIALS  M2 ' )
      CALL BHS(IHX+262,0,50,-5.0,5.0 )
CC    CALL STEXT(IHX+263,4,' SCALE FACTOR CHI < 5 ' )
CC    CALL BHS(IHX+263,0,50,0.9,1.1)
      CALL STEXT(IHX+264,4,' SCALE FACTOR FOR RADIAL DRIFT CHI< 5 ')
      CALL BHS(IHX+264,0,50,-1.0,1.0)
      ENDIF
       DO 10 K=1,MATOT
       A(K)=0.
 10    LISTA(K)=K

      MFIT=MATOT
C     NEXT 2 LINES FOR T0 FIT *************************
      LISTA(MATOT+1)=50
      A(MATOT+1)=0.
      MFIT=MFIT+1
C******************************************************
C     FIRST FIT
      CALL  FXFIT(X,YY,SSIG,NNDATA,A,MA,LISTA,MFIT,COVAR,NCVM,CHISQ)
      CHI=CHISQ/FLOAT(NNDATA)
C     WRITE(*,*)' CHI 1 ',CHI
**    IF(CHI.GT.2.0)THEN
C     REMOVE BAD POINTS AND REFIT
**    RMAX=0.
**    DO 3100 I=1,NNDATA
**    ARES(I)=ABS(RES(I))
**    INX(I)=I
**    IF(ABS(RES(I)).GT.RMAX)RMAX=ABS(RES(I))
 3100 CONTINUE
C     CALL SORTFL(ARES,INX,NNDATA)
*     DO 3110 I=1,NNDATA
C     PRINT 2002,I,INX(I),ARES(INX(I))
 2002 FORMAT(1X,2I5,F8.2)
*     IF(ABS(RES(I)).GT.RMAX/1.5)THEN
***   SSIG(I)=1000.
*     ENDIF
*3110 CONTINUE
C     EXAMINE RESIDUALS WITH MEDFIT - REJECT IF > 2.5 * MEAN
C     ROBUST STR LINE FIT (LEAST ABSOLUTE DEVIATION)
**    CALL MEDFIT(XX,RES,NNDATA,AR,BR,ABDEV)
C     WRITE(*,*)' MEDFIT RESIDUALS ',ABDEV
**    DO 3300 I=1,NNDATA
**    RR=RES(I)-(AR+BR*XX(I))
C     PRINT2002,I,I,RR
C     TEMP REMOVAL OF POINT REJECT
**    IF(ABS(RR).GT.2.5*ABDEV)SSIG(I)=1000.
 3300 CONTINUE
C     REFIT AFTER POINT REJECT
**    CALL  FLFIT(X,YY,SSIG,NNDATA,A,MA,LISTA,MFIT,COVAR,NCVM,CHISQ)
**    CHI=CHISQ/FLOAT(NNDATA)
C     WRITE(*,*)' CHI 2 ',CHI
**    RMAX=0.
**    DO 3200 I=1,NNDATA
**    ARES(I)=ABS(RES(I))
**    INX(I)=I
*     IF(ABS(RES(I)).GT.RMAX)RMAX=ABS(RES(I))
 3200 CONTINUE
*     CALL SORTFL(ARES,INX,NNDATA)
*     DO 3210 I=1,NNDATA
C     PRINT 2002,I,INX(I),ARES(INX(I))
*     IF(ABS(RES(I)).GT.RMAX/1.5)THEN
*     SSIG(I)=1000.
*     ENDIF
*3210 CONTINUE
**    ENDIF
      TZ=A(50)
      F1=A(1)
      F2=A(2)
      F3=A(3)
      F4=A(4)
      F5=A(5)
      F6=A(6)
      F7=A(7)
      F8=A(8)
      F9=A(9)
      MOD=1
CC    PRINT 1000,MOD,NNDATA,CHI
CC    PRINT1001,(A(KK),KK=1,MFIT-1)
C     PRINT1001,(A(KK),KK=1,MFIT  )
CC    PRINT1002,A(50)
 1000 FORMAT(' FIT     ',2I5,F6.1,' YD,YZ,XD,XZ ,CY,CZ')
 1001 FORMAT('         ',16X,4F8.3,3E12.4)
 1002 FORMAT(' TIME ZERO  ',F8.3)
      CALL SHS(IHX+250,0,A(50))
      CALL SHS(IHX+251,0,A(50))
      CALL SHS(IHX+252,0,CHI)
      IF(CHI.LT.5.0)THEN
      CALL SHS(IHX+253,0,A(50))
      CALL SHS(IHX+254,0.,A(50))
      DTZ=SQRT(ABS(COVAR(MFIT,MFIT)))
      CALL SHS(IHX+255,0.,DTZ)
      CALL SHS(IHX+256,0.,FLOAT(NNDATA))
C     SCALE FACTOR = 1/FACTOR FOR DRIFT VELOCITY CHANGE
C     IE BETTER DRIFT VEL = DV ORIGINAL/SF
CCC   SF=SF1/SF2
C     WRITE(*,*)' FTZFIT SF ',SF
CCC   IF(ABS(SF-1.0).LT.0.1)CALL SHS(IHX+263,0.,SF)
      IF(NPAR.EQ.7.AND.F7.NE.0.0)CALL SHS(IHX+264,0.,F7)
      IF(NPAR.EQ.5.AND.F5.NE.0.0)CALL SHS(IHX+264,0.,F5)
**********************************************************************
C     SELECT ANGLE OF  WIRES -1.57,-2.62,-0.52    Y,U,V
      THSEL=-1.570796
C     THSEL=-0.52
C     THSEL=-2.62
**********************************************************************
      DO 3400 I=1,NNDATA
      IF(SSIG(I).GT.50.0)GOTO3400
C     WRITE(*,*)' THET ',I,THET(I)
C
C
C
C
C
*************************************************************
C     MODULE TO BE STUDIED HAS SSIG MULTPILIED BY 100.
C     IN FTZFIT
      IF(SSIG(I).GT.1.0)RES(I)=RES(I)*100.
C
      IM=(IPRES(I)-1)/12
      IF(ABS(RES(I)).GT.5.0)GOTO3400
C     PLANAR RESIDULALS
**************ANGLE SELECTION********************************
CX    IF(ABS(THET(I)-THSEL).LT.0.50)THEN
*************************************************************
      IF(I.LE.NPLA)CALL SHS(IHX+257+IM,0.,RES(I))
C     RADIAL RESIDUALS
      IF(I.GT.NPLA)CALL SHS(IHX+260+IM,0.,RES(I))
CX    ENDIF
 3400 CONTINUE
      ENDIF

      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.28.57  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZU:  3.08/03 29/11/92  16.41.48  by  Stephen J. Maxfield
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE  FXFIT(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,COVAR,NCVM,CHISQ)
      SAVE
C     ADDED FOR RESIDUALS
      COMMON /FPRES/NPLA,RES(100),IPRES(100),THET(100)
C     ADDED FOR SCALE FACTOR
      COMMON /FPSCAL/SF1,SF2,WZER(100)
      PARAMETER (MMAX=100)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),A(MA),LISTA(MA),
     1 COVAR(NCVM,NCVM),BETA(MMAX),AFUNC(MMAX)
      KK=MFIT+1
      DO 12 J=1,MA
      IHIT=0
      DO 11 K=1,MFIT
      IF(LISTA(K).EQ.J)IHIT=IHIT+1
 11   CONTINUE
      IF(IHIT.EQ.0)THEN
      LISTA(KK)=J
      KK=KK+1
      ELSEIF(IHIT.GT.1)THEN
      WRITE(*,*)' IMPROPER SET IN LISTA'
      RETURN
      ENDIF
 12   CONTINUE
      IF(KK.NE.MA+1)THEN
      WRITE(*,*)' IMPROPER SET IN LISTA '
      RETURN
      ENDIF
      DO 14 J=1,MFIT
      DO 13 K=1,MFIT
      COVAR(J,K)=0.
 13   CONTINUE
      BETA(J)=0.
 14   CONTINUE
      DO 18 I=1,NDATA
      CALL FFUNCS(I,AFUNC,MA)
      YM=Y(I)
      IF(MFIT.LT.MA)THEN
      DO 15 J=MFIT+1,MA
      YM=YM-A(LISTA(J))*AFUNC(LISTA(J))
 15   CONTINUE
      ENDIF
      SIG2I=1./SIG(I)**2
      DO 17 J=1,MFIT
      WT=AFUNC(LISTA(J))*SIG2I
      DO 16 K=1,J
      COVAR(J,K)=COVAR(J,K)+WT*AFUNC(LISTA(K))
 16   CONTINUE
      BETA(J)=BETA(J)+YM*WT
 17   CONTINUE
 18   CONTINUE
      IF(MFIT.GT.1)THEN
      DO 21 J=2,MFIT
      DO 19 K=1,J-1
      COVAR(K,J)=COVAR(J,K)
 19   CONTINUE
 21   CONTINUE
      ENDIF
      CALL FAUSSJ(COVAR,MFIT,NCVM,BETA,1,1)
      DO 22 J=1,MFIT
      A(LISTA(J))=BETA(J)
 22   CONTINUE
      CHISQ=0.
C     ADDED FOR SCALE FACTOR 9/4/92
      SF1=0.
      SF2=0.
      DO 24 I=1,NDATA
      CALL FFUNCS(I,AFUNC,MA)
      SUM=0.
      DO 23 J=1,MA
      SUM=SUM+A(J)*AFUNC(J)
 23   CONTINUE
      CHISQ=CHISQ+((Y(I)-SUM)/SIG(I))**2
C     ADDITION  2/3/92
      RES(I)=(Y(I)-SUM)/SIG(I)
      IF(I.GT.NPLA)GOTO24
C     ADDITION  9/4/92
C     SF1=SF1+(Y(I)-WZER(I))*(SUM-WZER(I))/SIG(I)**2
C     SF2=SF2+(SUM-WZER(I))**2/SIG(I)**2
C     Y-WZER  IS SIGNED DRIFT
      SF1=SF1+(Y(I)-WZER(I))/SIG(I)**2
      SF2=SF2+(SUM-WZER(I))/SIG(I)**2
 24   CONTINUE
C     CALL COVSRT(COVAR,NCVM,MA,LISTA,MFIT)
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.28.57  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZU:  3.08/03 29/11/92  18.34.51  by  Stephen J. Maxfield
*-- Author :    I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFUNCS(I,AFUNC,MA)
**: FFUNCS.......SM. New routine for monitoring. Moved to ft_newf
**----------------------------------------------------------------------
      COMMON /FPLFIT/NNDATA,MATOT,AA(100,50),YY(100),SSIG(100)
      DIMENSION AFUNC(MA)
      DO 10 K=1,MA
      AFUNC(K)=AA(I,K)
 10   CONTINUE
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.28.57  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZU:  3.08/03 29/11/92  18.35.12  by  Stephen J. Maxfield
*-- Author :    I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FAUSSJ(A,N,NP,B,M,MP)
**: FAUSSJ.......SM. New routine for monitoring. Moved to ft_newf
**----------------------------------------------------------------------
      PARAMETER (NMAX=50)
      DIMENSION A(NP,NP),B(NP,MP),IPIV(NMAX),INDXR(NMAX),INDXC(NMAX)
      DO 11 J=1,N
      IPIV(J)=0
 11   CONTINUE
      DO 22I=1,N
      BIG=0.
      DO 13 J=1,N
      IF(IPIV(J).NE.1)THEN
      DO 12 K=1,N
      IF(IPIV(K).EQ.0)THEN
      IF(ABS(A(J,K)).GE.BIG)THEN
      BIG=ABS(A(J,K))
      IROW=J
      ICOL=K
      ENDIF
      ELSEIF(IPIV(K).GT.1)THEN
*     WRITE(*,*)' SINGULAR MATRIX '
      RETURN
      ENDIF
 12   CONTINUE
      ENDIF
 13   CONTINUE
      IPIV(ICOL)=IPIV(ICOL)+1
C
      IF(IROW.NE.ICOL)THEN
      DO 14 L=1,N
      DUM=A(IROW,L)
      A(IROW,L)=A(ICOL,L)
      A(ICOL,L)=DUM
  14  CONTINUE
      DO 15 L=1,M
      DUM=B(IROW,L)
      B(IROW,L)=B(ICOL,L)
      B(ICOL,L)=DUM
 15   CONTINUE
      ENDIF
      INDXR(I)=IROW
      INDXC(I)=ICOL
      IF(A(ICOL,ICOL).EQ.0.)THEN
*     WRITE(*,*)' SINGULAR MATRIX '
      RETURN
      ENDIF
      PIVINV=1./A(ICOL,ICOL)
      A(ICOL,ICOL)=1.
      DO 16 L=1,N
      A(ICOL,L)=A(ICOL,L)*PIVINV
 16   CONTINUE
      DO 17 L=1,M
      B(ICOL,L)=B(ICOL,L)*PIVINV
 17   CONTINUE
      DO 21 LL=1,N
      IF(LL.NE.ICOL)THEN
      DUM=A(LL,ICOL)
      A(LL,ICOL)=0.
      DO 18 L=1,N
      A(LL,L)=A(LL,L)-A(ICOL,L)*DUM
 18   CONTINUE
      DO 19 L=1,M
      B(LL,L)=B(LL,L)-B(ICOL,L)*DUM
 19   CONTINUE
      ENDIF
 21   CONTINUE
 22   CONTINUE
      DO 24 L=N,1,-1
      IF(INDXR(L).NE.INDXC(L))THEN
      DO 23 K=1,N
      DUM=A(K,INDXR(L))
      A(K,INDXR(L))=A(K,INDXC(L))
      A(K,INDXC(L))=DUM
 23   CONTINUE
      ENDIF
 24   CONTINUE
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZU:  7.02/11 26/10/95  18.11.20  by  Stephen J. Maxfield
*CMZU:  3.09/07 26/07/93  10.00.29  by  Stephen Burke
*-- Author :    Stephen J. Maxfield   28/02/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FSINGR
**: FSINGR 30907 RP. Farm changes.
**----------------------------------------------------------------------
*
*     Keep single radial segments...
*
*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEND.
*     Radial  reject , unused  , radial verified by planar
      COMMON/FTRFLG/ IBRR(MAXTRK),IBPP(100),IVRR(MAXTRK)
*     Common for radials associated with planar tracks
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
*     Common for segment numbers...
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      COMMON /FPSEG3/ ISGR(3,MAXSEG)
      COMMON /FLINK3/ LNK3(MAXTRK,3)
      DIMENSION IRGONE(MAXTRK,3)



*     Find used segments...
      CALL VZERO(IRGONE,3*MAXTRK)
      DO 1 ISM = 1, 3
*       Radial segments from Rad-based tracks...
        DO 2 KTRK = 1, IG
          K = LNK3(KTRK,ISM)
          IF(K .NE. 0)IRGONE(K, ISM) = 1
 2      CONTINUE
*       Radial segments on planar-based tracks...
        DO 3 KTRK = 1, NPP
          K = LRR(ISM, KTRK)
          IF(K .NE. 0)IRGONE(K, ISM) = 1
 3      CONTINUE
 1    CONTINUE

*     Now pick up the unused segments
      DO 10 ISM = 1, 3
        DO 11 KSEG = 1, NTRAKS(ISM)
         IF(IRGONE(KSEG, ISM) .EQ. 0) THEN
         IF(IUZR(KSEG,ISM) .EQ. 0)    THEN
         IF(CHSQ(KSEG, ISM) .le. 1000.) Then
*        New segment. Add to Radial list.
         IF(IG .LT. MAXTRK) THEN
           IG = IG + 1
           CALL SHS(711,0,6.01)
*          Zero hit arrays...
           DO 13 KWIR = 1, 36
            IRN(KWIR,IG) = 0
            IRP(KWIR,IG) = 0
 13        CONTINUE

*          Fill hits...
           DO 12 KWIR = 1,12
            IRN(KWIR+(ISM-1)*12,IG) = IRPT (KWIR,KSEG,ISM)
            SDN(KWIR+(ISM-1)*12,IG) = SDRFT(KWIR,KSEG,ISM)
 12        CONTINUE

*          Copy the track parameters from module-based list.
           RPCOSG(IG) = PCOSL(KSEG,ISM)
           RPSING(IG) = PSINL(KSEG,ISM)
           PHZG(IG)   = PHZL (KSEG,ISM)
           RPCOSG(IG) = PCOSL(KSEG,ISM)
           ZIG(IG)    = RZI  (KSEG,ISM)

*          Fill segment pointer, flags etc...
           LNK3(IG,ISM) = KSEG
*          verify everything for now...
           IVRR(IG)   = 1
           IGTTRK(IG) = 0
         ENDIF
         ENDIF
         ENDIF
         ENDIF
 11     CONTINUE
 10   CONTINUE
      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.05/00 27/09/96  16.36.52  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZU:  5.03/00 03/11/94  17.56.36  by  Stephen Burke
*CMZU:  4.00/02 24/09/93  13.56.13  by  Rainer Prosi
*CMZ :  4.00/00 07/09/93  17.57.54  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.26  by  Stephen Burke
*-- Author :    I. O. Skillicorn      16/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Links planar segments to form planar-based tracks:
*          routines  FPPJN3,FPPJ12,FPPJ13,FPPJ23 .
*          Finds radial segments associated with the
*          planar-based tracks: FPKPKR
*
*HTMLI     : Describe the Input variables to the routine
*
* Planar track segments:
*          NFSEG segments/module
*          Hits                    :- IDGISG
*          Parameters(x0,y0,x',y') :- XYDXY in mm
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*
*
*HTMLO     : Describe the Output of the routine
*
* Planar-based  tracks:
*          NPP tracks
*          Hits                    :- IRR/SRR IPP/SPP
*          Segments radials/planars:- LRR LPP
*          Parameters(phi',phi0)   :- PSSS,PISS
*          Parameters(R',R0)       :- RSSS,RISS
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPLPKP
**: FPLPKP 40000 RP. New debug histos kicked out on the farm!
**: FPLPKP 40000 SM. New debug histos.
**----------------------------------------------------------------------
**: FPLPKP 30907 RP. Farm changes.
**----------------------------------------------------------------------
*
*     Routine to organise linking of planar segments
*     to form planar-based tracks and to pick up
*     radial line-segments
*
*
*MOD SJM. Add section to fill planar drift signs (moved from FTADD)
*MOD SJM. Ensure radial segments only used once!
*
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.


*     COMMON FOR IOS PLANAR LINK
      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)

      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
C     COMMON FOR RADIALS ASSOCIATED WITH PLANAR TRACKS
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
C     PLANAR SEGMENTS ASSOCIATED  WITH RADIALS
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FLINK3/LNK3(MAXTRK,3)
      COMMON/FTRSUS/IRUSED(3,100)

*KEEP,FPSTSG.
      COMMON/FPSTSG/ NSTC(9),NFSSEG(3),NFTSEG(3)
C---
*KEND.
      COMMON/fsegtp/iseg(100,3)

*     Local arrays...
      PARAMETER(PI2=6.2831853)
      DATA ISTART/0/


*     Zero used radial segment array. Note that radial segment may
*     have been used already on a radial-based trac. Such ambiguities
*     are removed later in FTMERG.
      CALL VZERO(IRUSED,300)
      call vzero(irr,3*maxtrk)
      call vzero(srr,3*maxtrk)

C
C---   Loop over supermodules
C
      DO 10 ISM = 1,3
      NS(ISM)=0
      K=0
      KK=0
CDEB  WRITE(*,*)' ISM NFSEG ',ISM,NFSEG(ISM)


C
C---   Loop over planar segments. Fill Arrays
C
c     number of primary segs
      npris=nfseg(ism)-nfsseg(ism)-nftseg(ism)
c     number primary +secondary
      npriss=npris+nfsseg(ism)
      DO 20 IP = 1,NFSEG(ISM)
C
C---  search only the disconnected set
C
      IF( MASKSG(IP,ISM) .NE. 0 )GO TO 20
      CALL SHS(765,0,FLOAT(ISM))
C
C---  EXTRACT PLANAR SEGMENT
C
      K=K+1
      KK=KK+1
      IF(K.GT.MAXTRK)GOTO20
      IF(KK.LE.50)THEN
c     set segment flags and note that max number of segments is 50
      if(ip.le.npris)iseg(kk,ism)=1
      if(ip.gt.npris.and.ip.le.npriss)iseg(kk,ism)=2
      if(ip.gt.npriss)iseg(kk,ism)=3
C     FILL IOS PARAMETERS FOR LINK
C     DY/DZ Y DX/DZ X
      SPAR(1,KK,ISM)=XYDXY(4,IP,ISM)
      SPAR(2,KK,ISM)=XYDXY(2,IP,ISM)/10.
      SPAR(3,KK,ISM)=XYDXY(3,IP,ISM)
      SPAR(4,KK,ISM)=XYDXY(1,IP,ISM)/10.
C     IOS TO RCWH NUMBER LINK
C     WRITE(*,*)' ISM ROB IOS #',ISM,IP,KK
      KTIP(ISM,KK)=IP
      NS(ISM)=KK
C     FILL POINT BANK AND SIGN
      FPTS=0.01
      DO 100 IW=1,12
      IOSP=IDGISG(IW,IP,ISM)
      IF(IOSP.NE.0)FPTS=FPTS+1.
      IPT(IW,KK,ISM)=IABS(IOSP)
      SGN(IW,KK,ISM)= SIGN(1.0, FLOAT(IOSP))
 100  CONTINUE
      CALL SHS(764,0,FPTS)
C     PRINT 2000,ISM,IP,KK,(IPT(IWW,KK,ISM),IWW=1,12)
 2000 FORMAT(' ISM,R,IOS ',2I3,3X,12I2)
      ENDIF

C
C---  End of loop over planars segments for supermodule
C
   20 CONTINUE
      IF(KK.NE.0)CALL SHS(720+ISM,0,FLOAT(KK)+0.01)

C
C---  End of loop over supermodules
C
   10 CONTINUE



C     CALL ROUTINES TO LINK SEGMENTS

      CALL FPPJN3

      CALL FPPJ12

      CALL FPPJ23

      CALL FPPJ13


C     LIST LINKS
      CALL SHS(560,0,FLOAT(NPP)+0.01)

      IF(NPP.NE.0)THEN

      DO 200 I=1,NPP
      IP1=0
      IP2=0
      IP3=0
      IF(LP(1,I).NE.0)IP1=KTIP(1,LP(1,I))
      IF(LP(2,I).NE.0)IP2=KTIP(2,LP(2,I))
      IF(LP(3,I).NE.0)IP3=KTIP(3,LP(3,I))
*     PRINT 1001,I,(IPP(II,I),II=1,36),CHPP(I),IP1,IP2,IP3
C     STORE RCWH POINTERS
      LPP(1,I)=IP1
      LPP(2,I)=IP2
      LPP(3,I)=IP3


C     zero radial pointers
      LRR(1,I)=0
      LRR(2,I)=0
      LRR(3,I)=0


 200  CONTINUE
      ENDIF
C     END OF LINK SECTION
c     pick up radials
      CALL FPKPKR


*-----Debug---------------------------------------------------
*     WRITE(*,*)'   ***FPLPKP*** '
*     WRITE(*,*)IG,' RADIAL TRACKS '
*-------------------------------------------------------------

*-----Debug---------------------------------------------------
*     DO 300 I=1,IG
*     PRINT 1001,I,(IRN(K,I),K=1,36),LNK3(I,1),LNK3(I,2),LNK3(I,3)
*     PRINT 1002,I,(IRP(K,I),K=1,36),ISGG(1,I),ISGG(2,I),ISGG(3,I)
*300  CONTINUE
*-------------------------------------------------------------

*-----Debug---------------------------------------------------
*     WRITE(*,*)NPP,' PLANAR TRACKS '
      DO 310 I=1,NPP
C
      IF(LPP(1,I).NE.0)CALL SHS(766,0,11.01)
      IF(LPP(2,I).NE.0)CALL SHS(766,0,12.01)
      IF(LPP(3,I).NE.0)CALL SHS(766,0,13.01)
C
      IF(LPP(1,I)*LPP(2,I)*LPP(3,I).NE.0)THEN
      CALL SHS(766,0, 1.01)
      ENDIF
      IF(LPP(1,I)*LPP(2,I).NE.0.AND.LPP(3,I).EQ.0)THEN
      CALL SHS(766,0, 2.01)
      ENDIF
      IF(LPP(2,I)*LPP(3,I).NE.0.AND.LPP(1,I).EQ.0)THEN
      CALL SHS(766,0, 3.01)
      ENDIF
      IF(LPP(1,I)*LPP(3,I).NE.0.AND.LPP(2,I).EQ.0)THEN
      CALL SHS(766,0, 4.01)
      ENDIF
*     PRINT 1004,I,(IRR(K,I),K=1,36),LRR(1,I),LRR(2,I),LRR(3,I)
*     PRINT 1003,I,(IPP(K,I),K=1,36),LPP(1,I),LPP(2,I),LPP(3,I)
 310  CONTINUE
*-------------------------------------------------------------
 1001 FORMAT(' RR',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1002 FORMAT(' RP',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1003 FORMAT(' PP',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1004 FORMAT(' PR',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 31/07/96  21.32.45  by  Stephen Burke
*CMZU:  7.00/04 24/04/95  17.15.33  by  Stephen Burke
*CMZU:  6.00/00 25/11/94  11.50.20  by  Stephen Burke
*CMZU:  5.03/00 01/11/94  18.38.57  by  Stephen J. Maxfield
*CMZU:  4.00/08 18/11/93  08.50.01  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.54  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.27  by  Stephen Burke
*-- Author :    I. O. Skillicorn      16/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Links three planar line segments to form
*          a planar-based track
*
*HTMLI     : Describe the Input variables to the routine
*
*          See FPLPKP
*
*HTMLO     : Describe the Output of the routine
*
*          See FPLPKP
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPPJN3
c     fpphit called to check link in phi
c     ie check momentum consistency
**: FPPJN3 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FPPJN3 30907 RP. Farm changes.
**----------------------------------------------------------------------
C     JOIN 3 PLANAR MODULES
C     1MM ERRORS USED IN CHI .
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FPFVTX.
      COMMON/VERTFF/ZFF,XFF,YFF
*
*KEEP,FPJPAR.
      COMMON/FPJPAR/
     +      RRCUT1, RRCUT2, RRCUT3,
     +      PLCC3, PLCC12, PLCC23, PLCC13
*KEND.
      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)
      COMMON/FTPLNK/LINK,CHIL(100),LNK(3,100),IUS(100,3)
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT
      COMMON/fsegtp/iseg(100,3)

      DIMENSION PSS(100),PIS(100),RSS(100),RIS(100)
      DIMENSION TH(50),XX(50),YY(50),ZZ(50),WP(50),WPP(50)
      DIMENSION ICM(100),RRR(3),RRZ(3),PPP(3),FNR(3),PZZ(50),IPZ(50)
      DIMENSION WDP(50),CH(100)
      PI2=6.283185307

      LINK=0
*     RRCUT=5.0
      DO 20 I=1,36
      DO 20 J=1,100
      IPP(I,J)=0
 20   CONTINUE

      NPP=0

      DO 10 I=1,3
      DO 10 J=1,50
 10   IUS(J,I)=0

      DO 100 I=1,NS(1)
      Z1=ZPP(6)
      X1=SPAR(3,I,1)*Z1+SPAR(4,I,1)
      Y1=SPAR(1,I,1)*Z1+SPAR(2,I,1)
      DO 200 J=1,NS(2)
      Z2=ZPP(18)
      X2=SPAR(3,J,2)*Z2+SPAR(4,J,2)
      Y2=SPAR(1,J,2)*Z2+SPAR(2,J,2)
      ZM=0.5*(Z1+Z2)
      X1M=SPAR(3,I,1)*ZM+SPAR(4,I,1)
      Y1M=SPAR(1,I,1)*ZM+SPAR(2,I,1)
      X2M=SPAR(3,J,2)*ZM+SPAR(4,J,2)
      Y2M=SPAR(1,J,2)*ZM+SPAR(2,J,2)
C     PLANAR SEGMENTS ARE JOINED BY PROJECTING THE SEGMENTS TO A
C     PLANE MIDWAY BETWEEN THE SEGMENTS. THE DISTANCE**2 BETWEEN
C     THE PROJECTIONS,RR, ON THIS PLANE IS USED AS A MEASURE OF
C     THE GOODNESS OF LINKAGE.  IF RR IS LESS THAN RCUT THE
C     LINK IS ACCEPTED.
      RR=(X1M-X2M)**2+(Y1M-Y2M)**2
      IF (ABS(Y1M-Y2M).LT.2.0) CALL SHS(907,0,X1M-X2M)
      IF (ABS(X1M-X2M).LT.2.0) CALL SHS(908,0,Y1M-Y2M)
      CALL SHS(904,0,RR)
      RRCUT=RRCUT1
      If(   iseg(i,1).gt.1
     + .or. iseg(j,2).gt.1  )RRCUT=RRCUT2
      If(   iseg(i,1).gt.2
     + .or. iseg(j,2).gt.2  )RRCUT=RRCUT3
      IF(RR.GT.RRCUT)GOTO200
c     plots to check link consistency in phi
      call fpphit(1,2,i,j,iflag)
      if(iflag.eq.1)goto200
      DO 300 K=1,NS(3)
      Z3=ZPP(30)
      X3=SPAR(3,K,3)*Z3+SPAR(4,K,3)
      Y3=SPAR(1,K,3)*Z3+SPAR(2,K,3)
      ZM=0.5*(Z2+Z3)
      X2M=SPAR(3,J,2)*ZM+SPAR(4,J,2)
      Y2M=SPAR(1,J,2)*ZM+SPAR(2,J,2)
      X3M=SPAR(3,K,3)*ZM+SPAR(4,K,3)
      Y3M=SPAR(1,K,3)*ZM+SPAR(2,K,3)
      RR=(X3M-X2M)**2+(Y3M-Y2M)**2
      CALL SHS(905,0,RR)
      RRCUT=RRCUT1
      If(   iseg(i,1).gt.1
     + .or. iseg(j,2).gt.1
     + .or. iseg(k,3).gt.1  )RRCUT=RRCUT2
      If(   iseg(i,1).gt.2
     + .or. iseg(j,2).gt.2
     + .or. iseg(k,3).gt.2  )RRCUT=RRCUT3
      IF(RR.GT.RRCUT)GOTO300
      call fpphit(1,2,i,j,iflag)
      if(iflag.eq.1)goto300
C     POTENTIAL LINK - CALCULATE CHI BETWEEN PARABOLA AND
C     FITTED LINE SEGMENTS
C     PARABOLA IS THRU CENTRE OF SEGMENTS
      CHI=0.
      IBAD=0
      IC=0
      ICC=0
      DO 310 IL=1,3
      RRR(IL)=0.
      RRZ(IL)=0.
      PPP(IL)=0.
      FNR(IL)=0.
 310  CONTINUE
      DO 400 L=1,3
      IF(L.EQ.1)II=I
      IF(L.EQ.2)II=J
      IF(L.EQ.3)II=K
      DO 410 LL=1,12
      IP=(L-1)*12+LL
      ZA=ZPP(IP)
      JJ=IPT(LL,II,L)
      IF(JJ.NE.0)THEN
      SGNN=SGN(LL,II,L)
      ICC=ICC+1
C     DRIFT COORDS FOR PLANARS
      WDP(ICC)=SGNN*DRIW(JJ,IP)+DW(JJ,IP)
      PZZ(ICC)=ZA
      IPZ(ICC)=IP
      ENDIF
      XP=FPARAB(ZA,X1,X2,X3,Z1,Z2,Z3)
      XF=SPAR(3,II,L)*ZA+SPAR(4,II,L)
*     CHI=CHI+(XF-XP)**2/(0.10)**2
      YP=FPARAB(ZA,Y1,Y2,Y3,Z1,Z2,Z3)
      YF=SPAR(1,II,L)*ZA+SPAR(2,II,L)
*     CHI=CHI+(YF-YP)**2/(0.10)**2
      IC=IC+1
      XX(IC)=ZA
      YY(IC)=ATAN2(YF,XF)
      ZZ(IC)=SQRT(XF**2+YF**2)
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
      WP(IC)=1./(0.10/ZZ(IC))
      WPP(IC)=1.0
      ICM(IC)=L
      RRZ(L)=RRZ(L)+ZA
      RRR(L)=RRR(L)+ZZ(IC)
      FNR(L)=FNR(L)+1.0
 410  CONTINUE
      IF(FNR(L).NE.0.)RRZ(L)=RRZ(L)/FNR(L)
      IF(FNR(L).NE.0.)RRR(L)=RRR(L)/FNR(L)
 400  CONTINUE
      IF(IC .GT. 1)THEN
      DO 600 JJ=2,IC
       DP = YY(JJ)-YY(JJ-1)
       IF(DP.GT.0.) THEN
       IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
       ELSE
       IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
       ENDIF
 600  CONTINUE
      ENDIF
******ADDED   IOS   16/11/93**************************************
C     CALCULATE MEAN PHI FOR PARABOLA
      FNR(1)=0
      FNR(2)=0
      FNR(3)=0
      DO 610 JJ=1,IC
      L=ICM(JJ)
      PPP(L)=PPP(L)+YY(JJ)
      FNR(L)=FNR(L)+1.
 610  CONTINUE
      IF(FNR(1).NE.0.)PPP(1)=PPP(1)/FNR(1)
      IF(FNR(2).NE.0.)PPP(2)=PPP(2)/FNR(2)
      IF(FNR(3).NE.0.)PPP(3)=PPP(3)/FNR(3)
******END ADD  16/11/93*******************************************
C     FIT PHI-Z
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
C     FIT R-Z
      CALL FTLFTW(XX,ZZ,WPP,IC,0,2,RS,RI,D1,D2,D3,D4)
      CHIP=0.
      DO 700 JJ=1,IC
      CHIP=CHIP+(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2
      DIFF=YY(JJ)-PS*XX(JJ)-PI
C     PRINT1002,JJ,(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2,YY(JJ),DIFF
 1002 FORMAT(' ',I3, F10.2,2F10.4)
 700  CONTINUE
      CHIP=CHIP/36.
      CALL SHS(500,0,CHIP)
C     CHI FOR DRIFT RELATIVE TO PARABOLAE IN PHI-Z , R-Z
      CHID=0.
      DO 710 JJ=1,ICC
      ZED=PZZ(JJ)
      PHI=FPARAB(ZED,PPP(1),PPP(2),PPP(3),
     1               RRZ(1),RRZ(2),RRZ(3))
      RRP=FPARAB(ZED,RRR(1),RRR(2),RRR(3),
     1               RRZ(1),RRZ(2),RRZ(3))
      THETA=ATAN2(S(IPZ(JJ)),C(IPZ(JJ)))
      WE=RRP*SIN(PHI-THETA)
      CHID=CHID+(WE-WDP(JJ))**2/(0.04)**2
 710  CONTINUE
      CHID=CHID/FLOAT(ICC)
      CALL SHS(571,0,CHID)
*     Remove Links with poor Chisq...  18/11/93
      IF(CHID.GT.PLCC3)GOTO300
*
      LINK=LINK+1
      IF(LINK.GT.100)LINK=100
      PSS(LINK)=PS
      PIS(LINK)=PI
      RSS(LINK)=RS
      RIS(LINK)=RI
      CHIL(LINK)=CHI
      CH(LINK)=CHID
      LNK(1,LINK)=I
      LNK(2,LINK)=J
      LNK(3,LINK)=K
*     II=LINK
C     PRINT 1001,II,LNK(1,II),LNK(2,II),LNK(3,II),CHIL(II)
 1001 FORMAT(' PJN3I',I3,2X,3I3,F10.2)
C     CALCULATE   A CURVATURE IN THE X,Y PLANE HENCE MOMENTUM
C     SS=SAGITTA SQUARED   USE R=L**2/(8*S)
C     WORKS OK 1 GEV AND ABOVE. BELOW OVERESTIMATES P DUE TO
C     WRONG SLOPE PROBABLY
*     SS=(X2-0.5*(X1+X3))**2+(Y2-0.5*(Y1+Y3))**2
*     RAD=((X3-X1)**2+(Y3-Y1)**2)/(8.0*SQRT(SS))
*     TANT=(SQRT(X2**2+Y2**2)-SQRT(X1**2+Y1**2))/(Z2-Z1)
*     THET=ATAN(TANT)
*     TH(LINK)=THET
*     RAD=RAD/SIN(THET)
*     PP=12.*0.0002998*RAD
*     PH1=ATAN2(Y1,X1)
*     PH2=ATAN2(Y2,X2)
*    IF(PH1.LT.0.0)PH1=PH1+PI2
*     IF(PH2.LT.0.0)PH2=PH2+PI2
*     SIGN=1.0
*     DIFF=PH2-PH1
*     IF(DIFF.LT.-3.14)DIFF=DIFF+PI2
*     IF(DIFF.GT.3.14)DIFF=DIFF-PI2
*     IF(DIFF.GT.0.)SIGN=-1.
*     PP=PP*SIGN

C      IF(ABS(PP).LT.1.0)THEN
C      WRITE(*,*)' PP  XYZ 123 ',PP ,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3
C      WRITE(*,*)' SS LL**2  ',SQRT(SS),(X3-X1)**2+(Y3-Y1)**2
C      ENDIF
*     PPP(LINK)=PP
 300  CONTINUE
 200  CONTINUE
 100  CONTINUE
C     NEW COMPARE SECTION
      LLL=LINK
      DO 500 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 510 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 510
      IF(LNK(1,K).EQ.0)GOTO 510
      IF(LNK(2,K).EQ.0)GOTO 510
      IF(LNK(3,K).EQ.0)GOTO 510
*      WRITE(*,*)' K ,CHI  ',K,CH(K),LNK(1,K),LNK(2,K),LNK(3,K)
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 510  CONTINUE
*      WRITE(*,*)' KB,CHIB ',KB,CHB
      IF(KB.EQ.0)GOTO 545
C     COMPARE BEST WITH REMAINDER
      DO 520 K=1,LLL
      IF(K.EQ.KB)GOTO520
      IF(LNK(1,K).EQ.0)GOTO520
      IF(LNK(2,K).EQ.0)GOTO520
      IF(LNK(3,K).EQ.0)GOTO520
      IF(LNK(1,K).EQ.LNK(1,KB))GOTO530
      IF(LNK(2,K).EQ.LNK(2,KB))GOTO530
      IF(LNK(3,K).EQ.LNK(3,KB))GOTO530
      GOTO 520
C     REMOVE LINK
 530  LNK(1,K)=0
      LNK(2,K)=0
      LNK(3,K)=0
*      WRITE(*,*)' REMOVE ',K
 520  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 500  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 545  DO 540 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 540  CONTINUE
C

C
C
      DO 550 I=1,LINK
      IF(LNK(1,I).EQ.0)GOTO550
      NPP=NPP+1
      IF(NPP.GT.100) THEN
        NPP = 100
        IEVSAT = 1
      ENDIF
      KLOC(NPP) = 1

C     SET USED FLAG
C      PRINT 1000,I,LNK(1,I),LNK(2,I),LNK(3,I),CHIL(I)
      L1=LNK(1,I)
      L2=LNK(2,I)
      L3=LNK(3,I)
      LP(1,NPP)=L1
      LP(2,NPP)=L2
      LP(3,NPP)=L3
      PSSS(NPP)=PSS(I)
      PISS(NPP)=PIS(I)
      RSSS(NPP)=RSS(I)
      RISS(NPP)=RIS(I)
C     PRINT 1000,I,(IPT(III,L1,1),III=1,12)
C    1,(IPT(III,L2,2),III=1,12)
C    1,(IPT(III,L3,3),III=1,12),CHIL(I)
 1000 FORMAT(' PJN3 ',I3,1X,3(1X,12I2),F6.2,F7.2)
 1200 FORMAT('     ',12I3)
      DO 551 KK=1,12
      IPP(KK,NPP)=IPT(KK,L1,1)
      IPP(KK+12,NPP)=IPT(KK,L2,2)
      IPP(KK+24,NPP)=IPT(KK,L3,3)
 551  CONTINUE
      CHPP(NPP)=CH(I)
      IUS(LNK(1,I),1)=1
      IUS(LNK(2,I),2)=1
      IUS(LNK(3,I),3)=1
      PROD=PROB(CH(I)*36.,36)
      CALL SHS(575,0,PROD )
      CALL SHS(550,0,2.001)
      CALL SHS(550,0,10.001)

 550  CONTINUE
CIOS  CALL PLAFIT(TH)
      RETURN
      END
*CMZ :  8.06/00 11/11/96  15.51.18  by  Stephen Burke
*CMZ :  8.05/03 08/10/96  22.28.03  by  Stephen Burke
*CMZ :  8.04/00 31/07/96  17.16.20  by  Stephen Burke
*CMZU:  6.00/00 25/11/94  11.50.20  by  Stephen Burke
*CMZU:  5.03/00 01/11/94  18.38.58  by  Stephen J. Maxfield
*CMZU:  4.00/08 18/11/93  08.51.29  by  Stephen J. Maxfield
*CMZU:  4.00/01 21/09/93  16.21.32  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.54  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.27  by  Stephen Burke
*-- Author :    I. O. Skillicorn      16/11/92
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Links two planar line segments to form
*          a planar-based track
*
*HTMLI     : Describe the Input variables to the routine
*
*          See FPLPKP
*
*HTMLO     : Describe the Output of the routine
*
*          See FPLPKP
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPPJ12
*     call fpphit
**: FPPJ12.......IS. Small bug fixed.
**----------------------------------------------------------------------
**: FPPJ12 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FPPJ12 30907 RP. Farm changes.
**----------------------------------------------------------------------
C     JOIN 2 PLANAR MODULES  - 1+2
       COMMON/FGMIOS/
*    PLANAR GEOMETRY
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    RADIAL GEOMETRY
     + ZP(36),PHW(36),WS(36)

*KEEP,FPJPAR.
      COMMON/FPJPAR/
     +      RRCUT1, RRCUT2, RRCUT3,
     +      PLCC3, PLCC12, PLCC23, PLCC13
*KEND.

      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)
      COMMON/FTPLNK/LINK,CHIL(100),LNK(3,100),IUS(100,3)
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT
      COMMON/fsegtp/iseg(100,3)

      DIMENSION PSS(100),PIS(100),RSS(100),RIS(100)
      DIMENSION PPP(50),XX(36),YY(36),ZZ(36),WP(36),WPP(36)
      DIMENSION CH(100)
      PI2=6.283185307

*     RRCUT=10.0
      LINK=0
      LINKO=LINK
      DO 100 I=1,NS(1)
      IF(IUS(I,1).NE.0)GOTO100
      Z1=ZPP(6)
      DO 200 J=1,NS(2)
      IF(IUS(J,2).NE.0)GOTO200
      Z2=ZPP(18)
      ZM=0.5*(Z1+Z2)
      X1M=SPAR(3,I,1)*ZM+SPAR(4,I,1)
      Y1M=SPAR(1,I,1)*ZM+SPAR(2,I,1)
      X2M=SPAR(3,J,2)*ZM+SPAR(4,J,2)
      Y2M=SPAR(1,J,2)*ZM+SPAR(2,J,2)
      RR=    ((X1M-X2M)**2 +(Y1M-Y2M)**2)
      CALL SHS(901,0,RR)
      RRCUT=RRCUT1
      If(   iseg(i,1).gt.1
     + .or. iseg(j,2).gt.1  )RRCUT=RRCUT2
      If(   iseg(i,1).gt.2
     + .or. iseg(j,2).gt.2  )RRCUT=RRCUT3
      IF(RR.GT.RRCUT)GOTO300
      call fpphit(1,2,i,j,iflag)
      if(iflag.eq.1)goto300
      IC=0
      DO 400 L=1,2
      IF(L.EQ.1)II=I
      IF(L.EQ.2)II=J
CSB      IF(L.EQ.3)II=K
      DO 410 LL=1,12
      IP=(L-1)*12+LL
      ZA=ZPP(IP)
      XF=SPAR(3,II,L)*ZA+SPAR(4,II,L)
      YF=SPAR(1,II,L)*ZA+SPAR(2,II,L)

C     FIT IN PHI-Z
      IC=IC+1
      XX(IC)=ZA
      YY(IC)=ATAN2(YF,XF)
      ZZ(IC)=SQRT(XF**2+YF**2)
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
      WP(IC)=1./(0.10/ZZ(IC))
      WPP(IC)=1.0
 410  CONTINUE
 400  CONTINUE
      IF(IC .GT. 1)THEN
      DO600 JJ=2,IC
       DP = YY(JJ)-YY(JJ-1)
       IF(DP.GT.0.) THEN
       IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
       ELSE
       IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
       ENDIF
 600  CONTINUE
      ENDIF
C     FIT PHI-Z
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
C     FIT R-Z
      CALL FTLFTW(XX,ZZ,WPP,IC,0,2,RS,RI,D1,D2,D3,D4)
      CHIP=0.
      DO 700 JJ=1,IC
      CHIP=CHIP+(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2
      DIFF=YY(JJ)-PS*XX(JJ)-PI
C     PRINT1002,JJ,(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2,YY(JJ),DIFF
 1002 FORMAT(' ',I3,F10.2,2F10.4)
 700  CONTINUE
      CHIP=CHIP/24.
      CALL FPCHI(1,2,I,J,CHID)
      CALL SHS(510,0,CHIP)
      CALL SHS(572,0,CHID)
*     Remove Links with poor Chisq...  18/11/93
      IF(CHID.GT.PLCC12)GOTO300
*
      LINK=LINK+1
      IF(LINK.GT.100)LINK=100
      PSS(LINK)=PS
      PIS(LINK)=PI
      RSS(LINK)=RS
      RIS(LINK)=RI
      CHIL(LINK)=CHIP
      CH(LINK)=CHID
      LNK(1,LINK)=I
      LNK(2,LINK)=J
      LNK(3,LINK)=0
C     MOMENTUM FROM ANGLE CHANGE
*     T1=ATAN2(SPAR(1,I,1),SPAR(3,I,1))
*     IF(T1.LT.0.)T1=T1+PI2
*     T2=ATAN2(SPAR(1,J,2),SPAR(3,J,2))
*     IF(T2.LT.0.)T2=T2+PI2
*     TANT=(SQRT(X2**2+Y2**2)-SQRT(X1**2+Y1**2))/(Z2-Z1)
*     SL=SQRT((X2-X1)**2+(Y2-Y1)**2)
*     THET=ATAN(TANT)
*     DIFF=T2-T1
*     IF(DIFF.LT.-3.14)DIFF=DIFF+PI2
*     IF(DIFF.GT.3.14)DIFF=DIFF-PI2
*     PP=1000.
*     IF(DIFF.NE.0.0)PP=-0.0002998*12.*SL/(DIFF*SIN(THET))
*     PPP(LINK)=PP
C     CALL SHS(570,0,1./PP)
C     CALL SHS(571,0,1./PP)
C     CALL SHS(572,0,PP)
*     II=LINK
*     PRINT 1001,II,LNK(1,II),LNK(2,II),LNK(3,II),CHIL(II)
 1001 FORMAT(' PJ12I',I3,2X,3I3,F10.2)
 300  CONTINUE
 200  CONTINUE
 100  CONTINUE
C     NEW COMPARE SECTION
      LLL=LINK
      DO 500 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 510 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 510
      IF(LNK(1,K).EQ.0)GOTO 510
      IF(LNK(2,K).EQ.0)GOTO 510
*      IF(LNK(3,K).EQ.0)GOTO 510
*      WRITE(*,*)' K ,CHI  ',K,CH(K),LNK(1,K),LNK(2,K),LNK(3,K)
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 510  CONTINUE
*      WRITE(*,*)' KB,CHIB ',KB,CHB
      IF(KB.EQ.0)GOTO 545
C     COMPARE BEST WITH REMAINDER
      DO 520 K=1,LLL
      IF(K.EQ.KB)GOTO520
      IF(LNK(1,K).EQ.0)GOTO520
      IF(LNK(2,K).EQ.0)GOTO520
*      IF(LNK(3,K).EQ.0)GOTO520
      IF(LNK(1,K).EQ.LNK(1,KB))GOTO530
      IF(LNK(2,K).EQ.LNK(2,KB))GOTO530
*      IF(LNK(3,K).EQ.LNK(3,KB))GOTO530
      GOTO 520
C     REMOVE LINK
 530  LNK(1,K)=0
      LNK(2,K)=0
      LNK(3,K)=0
*      WRITE(*,*)' REMOVE ',K
 520  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 500  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 545  DO 540 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 540  CONTINUE
C
C
C

      DO 550 I=LINKO+1,LINK
      IF(LNK(1,I).EQ.0)GOTO550
C     SET USED FLAG
      IUS(LNK(1,I),1)=1
      IUS(LNK(2,I),2)=1
C     IUS(LNK(3,I),3)=1
      L1=LNK(1,I)
      L2=LNK(2,I)
C     L3=LNK(3,I)
C     PRINT 1000,I,(IPT(III,L1,1),III=1,12)
C    1,(IPT(III,L2,2),III=1,12)
C    1,CHIL(I),PPP(I)
 1000 FORMAT(' PJN12',I3,1X,2(1X,12I2),F6.2,F7.2)
      NPP=NPP+1
      IF(NPP.GT.100) THEN
        NPP = 100
        IEVSAT = 1
      ENDIF
      KLOC(NPP) = 2

      LP(1,NPP)=L1
      LP(2,NPP)=L2
      LP(3,NPP)=00
      PSSS(NPP)=PSS(I)
      PISS(NPP)=PIS(I)
      RSSS(NPP)=RSS(I)
      RISS(NPP)=RIS(I)
      DO 551 KK=1,12
      IPP(KK,NPP)=IPT(KK,L1,1)
      IPP(KK+12,NPP)=IPT(KK,L2,2)
C     IPP(KK+24,NPP)=IPT(KK,L3,3)
 551  CONTINUE
      CHPP(NPP)=CH(I)
      PROD=PROB(CH(I)*24.,24)
      CALL SHS(576,0,PROD )
      CALL SHS(550,0,4.001)
      CALL SHS(550,0,10.001)
 550  CONTINUE

      RETURN
      END
*CMZ :  8.06/00 11/11/96  15.52.42  by  Stephen Burke
*CMZ :  8.05/03 08/10/96  22.29.46  by  Stephen Burke
*CMZ :  8.04/00 31/07/96  21.28.28  by  Stephen Burke
*CMZU:  6.00/00 25/11/94  11.50.20  by  Stephen Burke
*CMZU:  5.03/00 01/11/94  18.38.58  by  Stephen J. Maxfield
*CMZU:  4.00/08 18/11/93  08.51.54  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.54  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.27  by  Stephen Burke
*-- Author :    I. O. Skillicorn      16/11/92
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Links two planar line segments to form
*          a planar-based track
*
*HTMLI     : Describe the Input variables to the routine
*
*          See FPLPKP
*
*HTMLO     : Describe the Output of the routine
*
*          See FPLPKP
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPPJ23
c   fpphit called
**: FPPJ23 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FPPJ23 30907 RP. Farm changes.
**----------------------------------------------------------------------
C     JOIN 2 PLANAR MODULES  - 2+3
       COMMON/FGMIOS/
*    PLANAR GEOMETRY
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    RADIAL GEOMETRY
     + ZP(36),PHW(36),WS(36)

*KEEP,FPJPAR.
      COMMON/FPJPAR/
     +      RRCUT1, RRCUT2, RRCUT3,
     +      PLCC3, PLCC12, PLCC23, PLCC13
*KEND.

      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)
      COMMON/FTPLNK/LINK,CHIL(100),LNK(3,100),IUS(100,3)
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT
      COMMON/fsegtp/iseg(100,3)

      DIMENSION PSS(100),PIS(100),RSS(100),RIS(100)
      DIMENSION PPP(50) ,TH(50),XX(50),YY(50),ZZ(50),WP(50),WPP(50)
      DIMENSION CH(100)
      PI2=6.283185307
*     RRCUT=10.0
      LINK=0
      LINKO=LINK
      DO 200 J=1,NS(2)
      IF(IUS(J,2).NE.0)GOTO200
      Z2=ZPP(18)
*     X2=SPAR(3,J,2)*Z2+SPAR(4,J,2)
*     Y2=SPAR(1,J,2)*Z2+SPAR(2,J,2)
      DO 300 K=1,NS(3)
      IF(IUS(K,3).NE.0)GOTO300
      Z3=ZPP(30)
*     X3=SPAR(3,K,3)*Z3+SPAR(4,K,3)
*     Y3=SPAR(1,K,3)*Z3+SPAR(2,K,3)
      ZM=0.5*(Z2+Z3)
      X2M=SPAR(3,J,2)*ZM+SPAR(4,J,2)
      Y2M=SPAR(1,J,2)*ZM+SPAR(2,J,2)
      X3M=SPAR(3,K,3)*ZM+SPAR(4,K,3)
      Y3M=SPAR(1,K,3)*ZM+SPAR(2,K,3)
      RR=    ((X2M-X3M)**2+(Y2M-Y3M)**2)
      CALL SHS(902,0,RR)
      RRCUT=RRCUT1
      If(   iseg(j,2).gt.1
     + .or. iseg(k,3).gt.1  )RRCUT=RRCUT2
      If(   iseg(j,2).gt.2
     + .or. iseg(k,3).gt.2  )RRCUT=RRCUT3
      IF(RR.GT.RRCUT)GOTO300
      call fpphit(2,3,j,k,iflag)
      if(iflag.eq.1)goto300
      IC=0
      DO 400 L=2,3
CSB      IF(L.EQ.1)II=I
      IF(L.EQ.2)II=J
      IF(L.EQ.3)II=K
      DO 410 LL=1,12
      IP=(L-1)*12+LL
      ZA=ZPP(IP)
      XF=SPAR(3,II,L)*ZA+SPAR(4,II,L)
      YF=SPAR(1,II,L)*ZA+SPAR(2,II,L)
      IC=IC+1
      XX(IC)=ZA
      YY(IC)=ATAN2(YF,XF)
      ZZ(IC)=SQRT(XF**2+YF**2)
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
      WP(IC)=1./(0.10/ZZ(IC))
      WPP(IC)=1.0
 410  CONTINUE
 400  CONTINUE
      IF(IC .GT. 1)THEN
      DO600 JJ=2,IC
      DP = YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.) THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 600  CONTINUE
      ENDIF
C     FIT PHI-Z
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
C     FIT R-Z
      CALL FTLFTW(XX,ZZ,WPP,IC,0,2,RS,RI,D1,D2,D3,D4)
      CHIP=0.
      DO 700 JJ=1,IC
      CHIP=CHIP+(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2
*     DIFF=YY(JJ)-PS*XX(JJ)-PI
*     PRINT1002,JJ,(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2,YY(JJ),DIFF
 1002 FORMAT(' ',I3,F10.2,2F10.4)
 700  CONTINUE
      CHIP=CHIP/24.
      CALL FPCHI(2,3,J,K,CHID)
      CALL SHS(520,0,CHIP)
      CALL SHS(573,0,CHID)
*     Remove Links with poor Chisq...  18/11/93
      IF(CHID.GT.PLCC23)GOTO300
*
      LINK=LINK+1
      IF(LINK.GT.100)LINK=100
      CHIL(LINK)=CHIP
      CH(LINK)=CHID
      LNK(1,LINK)=0
      LNK(2,LINK)=J
      LNK(3,LINK)=K
      PSS(LINK)=PS
      PIS(LINK)=PI
      RSS(LINK)=RS
      RIS(LINK)=RI
C     MOMENTUM FROM ANGLE CHANGE
*     T1=ATAN2(SPAR(1,J,2),SPAR(3,J,2))
*     IF(T1.LT.0.)T1=T1+PI2
*     T2=ATAN2(SPAR(1,K,3),SPAR(3,K,3))
*     IF(T2.LT.0.)T2=T2+PI2
*     TANT=(SQRT(X3**2+Y3**2)-SQRT(X2**2+Y2**2))/(Z3-Z2)
*     SL=SQRT((X2-X3)**2+(Y2-Y3)**2)
*     THET=ATAN(TANT)
*     DIFF=T2-T1
*     IF(DIFF.LT.-3.14)DIFF=DIFF+PI2
*     IF(DIFF.GT.3.14)DIFF=DIFF-PI2
*     PP=1000.
*     IF(DIFF.NE.0.0)PP=-0.0002998*12.*SL/(DIFF*SIN(THET))
*     PPP(LINK)=PP
C     CALL SHS(580,0,1./PP)
C     CALL SHS(581,0,1./PP)
C     CALL SHS(582,0,PP)
*     II=LINK
*     PRINT 1001,II,LNK(1,II),LNK(2,II),LNK(3,II),CHIL(II)
 1001 FORMAT(' PJ12I',I3,2X,3I3,F10.2)
 300  CONTINUE
 200  CONTINUE
 100  CONTINUE

C     NEW COMPARE SECTION
      LLL=LINK
      DO 500 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 510 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 510
*      IF(LNK(1,K).EQ.0)GOTO 510
      IF(LNK(2,K).EQ.0)GOTO 510
      IF(LNK(3,K).EQ.0)GOTO 510
*      WRITE(*,*)' K ,CHI  ',K,CH(K),LNK(1,K),LNK(2,K),LNK(3,K)
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 510  CONTINUE
*      WRITE(*,*)' KB,CHIB ',KB,CHB
      IF(KB.EQ.0)GOTO 545
C     COMPARE BEST WITH REMAINDER
      DO 520 K=1,LLL
      IF(K.EQ.KB)GOTO520
*      IF(LNK(1,K).EQ.0)GOTO520
      IF(LNK(2,K).EQ.0)GOTO520
      IF(LNK(3,K).EQ.0)GOTO520
*      IF(LNK(1,K).EQ.LNK(1,KB))GOTO530
      IF(LNK(2,K).EQ.LNK(2,KB))GOTO530
      IF(LNK(3,K).EQ.LNK(3,KB))GOTO530
      GOTO 520
C     REMOVE LINK
 530  LNK(1,K)=0
      LNK(2,K)=0
      LNK(3,K)=0
*      WRITE(*,*)' REMOVE ',K
 520  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 500  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 545  DO 540 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 540  CONTINUE
C
C
C
      DO 550 I=LINKO+1,LINK
      IF(LNK(2,I).EQ.0)GOTO550
C     SET USED FLAG
C     IUS(LNK(1,I),1)=1
      IUS(LNK(2,I),2)=1
      IUS(LNK(3,I),3)=1
 1000 FORMAT(' PJN23',I3,1X,2(1X,12I2),F6.2,F7.2)
C     L1=LNK(1,I)
      L2=LNK(2,I)
      L3=LNK(3,I)
C     PRINT 1000,I,(IPT(III,L2,2),III=1,12)
C    1,(IPT(III,L3,3),III=1,12)
C    1,CHIL(I),PPP(I)
      NPP=NPP+1
      IF(NPP.GT.100) THEN
        NPP = 100
        IEVSAT = 1
      ENDIF
      KLOC(NPP)=3

      LP(1,NPP)=00
      LP(2,NPP)=L2
      LP(3,NPP)=L3
      PSSS(NPP)=PSS(I)
      PISS(NPP)=PIS(I)
      RSSS(NPP)=RSS(I)
      RISS(NPP)=RIS(I)
      DO 551 KK=1,12
C     IPP(KK,NPP)=IPT(KK,L1,1)
      IPP(KK+12,NPP)=IPT(KK,L2,2)
      IPP(KK+24,NPP)=IPT(KK,L3,3)
 551  CONTINUE
      CHPP(NPP)=CH(I)
      PROD=PROB(CH(I)*24.,24)
      CALL SHS(577,0,PROD )
      CALL SHS(550,0,6.001)
      CALL SHS(550,0,10.001)
 550  CONTINUE

      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 31/07/96  21.26.17  by  Stephen Burke
*CMZU:  6.00/00 25/11/94  11.50.20  by  Stephen Burke
*CMZU:  5.03/00 02/11/94  19.44.03  by  Stephen Burke
*CMZU:  4.00/08 18/11/93  08.52.14  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.54  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.27  by  Stephen Burke
*-- Author :    I. O. Skillicorn      16/11/92
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Links two planar line segments to form
*          a planar-based track
*
*
*HTMLI     : Describe the Input variables to the routine
*
*          See FPLPKP
*
*
*HTMLO     : Describe the Output of the routine
*
*          See FPLPKP
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPPJ13
*     call fpphit
**: FPPJ13 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FPPJ13 30907 RP. Farm changes.
**----------------------------------------------------------------------
C     JOIN 2 PLANAR MODULES  - 1+3
       COMMON/FGMIOS/
*    PLANAR GEOMETRY
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    RADIAL GEOMETRY
     + ZP(36),PHW(36),WS(36)

*KEEP,FPJPAR.
      COMMON/FPJPAR/
     +      RRCUT1, RRCUT2, RRCUT3,
     +      PLCC3, PLCC12, PLCC23, PLCC13
*KEND.

      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)
      COMMON/FTPLNK/LINK,CHIL(100),LNK(3,100),IUS(100,3)
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT
      COMMON/fsegtp/iseg(100,3)

      DIMENSION PSS(100),PIS(100),RSS(100),RIS(100)
      DIMENSION PPP(50),XX(36),YY(36),ZZ(36),WP(36),WPP(36)
      DIMENSION CH(100)
      PI2=6.283185307
*     RRCUT=10.0
      LINK=0
      LINKO=LINK
      DO 100 I=1,NS(1)
      IF(IUS(I,1).NE.0)GOTO100
      Z1=ZPP(6)
*     X1=SPAR(3,I,1)*Z1+SPAR(4,I,1)
*     Y1=SPAR(1,I,1)*Z1+SPAR(2,I,1)
      DO 300 K=1,NS(3)
      IF(IUS(K,3).NE.0)GOTO300
      Z3=ZPP(30)
*     X3=SPAR(3,K,3)*Z3+SPAR(4,K,3)
*     Y3=SPAR(1,K,3)*Z3+SPAR(2,K,3)
      ZM=0.5*(Z1+Z3)
      X1M=SPAR(3,I,1)*ZM+SPAR(4,I,1)
      Y1M=SPAR(1,I,1)*ZM+SPAR(2,I,1)
      X3M=SPAR(3,K,3)*ZM+SPAR(4,K,3)
      Y3M=SPAR(1,K,3)*ZM+SPAR(2,K,3)
      RR=    ((X1M-X3M)**2+(Y1M-Y3M)**2)
      CALL SHS(903,0,RR)
      RRCUT=RRCUT1
      If(   iseg(i,1).gt.1
     + .or. iseg(k,3).gt.1  )RRCUT=RRCUT2
      If(   iseg(i,1).gt.2
     + .or. iseg(k,3).gt.2  )RRCUT=RRCUT3
      IF(RR.GT.RRCUT)GOTO300
      call fpphit(1,3,i,k,iflag)
      if(iflag.eq.1)goto300
      IC=0
      DO 400 L=1,3
      IF(L.EQ.2)GOTO400
      IF(L.EQ.1)II=I
C      IF(L.EQ.2)II=J
      IF(L.EQ.3)II=K
      DO 410 LL=1,12
      IP=(L-1)*12+LL
      ZA=ZPP(IP)
      XF=SPAR(3,II,L)*ZA+SPAR(4,II,L)
      YF=SPAR(1,II,L)*ZA+SPAR(2,II,L)
      IC=IC+1
      XX(IC)=ZA
      YY(IC)=ATAN2(YF,XF)
      ZZ(IC)=SQRT(XF**2+YF**2)
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
      WP(IC)=1./(0.10/ZZ(IC))
      WPP(IC)=1.0
 410  CONTINUE
 400  CONTINUE
      IF(IC .GT. 1)THEN
      DO600 JJ=2,IC
      DP = YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.) THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 600  CONTINUE
      ENDIF
C     FIT PHI-Z
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
C     FIT R-Z
      CALL FTLFTW(XX,ZZ,WPP,IC,0,2,RS,RI,D1,D2,D3,D4)
      CHIP=0.
      DO 700 JJ=1,IC
      CHIP=CHIP+(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2
*     DIFF=YY(JJ)-PS*XX(JJ)-PI
*     PRINT1002,JJ,(YY(JJ)-PS*XX(JJ)-PI)**2*WP(JJ)**2,YY(JJ),DIFF
 1002 FORMAT(' ',I3,F10.2,2F10.4)
 700  CONTINUE
      CHIP=CHIP/24.
      CALL FPCHI(1,3,I,K,CHID)
      CALL SHS(530,0,CHIP)
      CALL SHS(574,0,CHID)
*     Remove Links with poor Chisq...  18/11/93
      IF(CHID.GT.100.)GOTO300
*
      LINK=LINK+1
      IF(LINK.GT.100)LINK=100
      PSS(LINK)=PS
      PIS(LINK)=PI
      RSS(LINK)=RS
      RIS(LINK)=RI
      CHIL(LINK)=CHIP
      CH(LINK)=CHID
      LNK(1,LINK)=I
      LNK(2,LINK)=0
      LNK(3,LINK)=K
*      WRITE(*,*)' I,K,LINK,CHIP,CHID ',I,K,LINK,CHIP,CHID
C     MOMENTUM FROM ANGLE CHANGE
*     T1=ATAN2(SPAR(1,I,1),SPAR(3,I,1))
*     IF(T1.LT.0.)T1=T1+PI2
*     T2=ATAN2(SPAR(1,K,3),SPAR(3,K,3))
*     IF(T2.LT.0.)T2=T2+PI2
*     TANT=(SQRT(X3**2+Y3**2)-SQRT(X1**2+Y1**2))/(Z3-Z1)
*     SL=SQRT((X1-X3)**2+(Y1-Y3)**2)
*     THET=ATAN(TANT)
*     DIFF=T2-T1
*     IF(DIFF.LT.-3.14)DIFF=DIFF+PI2
*     IF(DIFF.GT.3.14)DIFF=DIFF-PI2
*     PP=1000.
*     IF(DIFF.NE.0.0)PP=-0.0002998*12.*SL/(DIFF*SIN(THET))
*     PPP(LINK)=PP
C     CALL SHS(590,0,1./PP)
C     CALL SHS(591,0,1./PP)
C     CALL SHS(592,0,PP)
*     II=LINK
*     PRINT 1001,II,LNK(1,II),LNK(2,II),LNK(3,II),CHIL(II)
 1001 FORMAT(' PJ13I',I3,2X,3I3,F10.2)
 300  CONTINUE
 200  CONTINUE
 100  CONTINUE

C     NEW COMPARE SECTION
      LLL=LINK
      DO 500 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 510 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 510
      IF(LNK(1,K).EQ.0)GOTO 510
*     IF(LNK(2,K).EQ.0)GOTO 510
      IF(LNK(3,K).EQ.0)GOTO 510
*      WRITE(*,*)' K ,CHI  ',K,CH(K),LNK(1,K),LNK(2,K),LNK(3,K)
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 510  CONTINUE
*      WRITE(*,*)' KB,CHIB ',KB,CHB
      IF(KB.EQ.0)GOTO 545
C     COMPARE BEST WITH REMAINDER
      DO 520 K=1,LLL
      IF(K.EQ.KB)GOTO520
      IF(LNK(1,K).EQ.0)GOTO520
*     IF(LNK(2,K).EQ.0)GOTO520
      IF(LNK(3,K).EQ.0)GOTO520
      IF(LNK(1,K).EQ.LNK(1,KB))GOTO530
*     IF(LNK(2,K).EQ.LNK(2,KB))GOTO530
      IF(LNK(3,K).EQ.LNK(3,KB))GOTO530
      GOTO 520
C     REMOVE LINK
 530  LNK(1,K)=0
      LNK(2,K)=0
      LNK(3,K)=0
*      WRITE(*,*)' REMOVE ',K
 520  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 500  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 545  DO 540 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 540  CONTINUE
C
C
      DO 550 I=LINKO+1,LINK
      IF(LNK(1,I).EQ.0)GOTO550
C     SET USED FLAG
      IUS(LNK(1,I),1)=1
C     IUS(LNK(2,I),2)=1
      IUS(LNK(3,I),3)=1
      L1=LNK(1,I)
C     L2=LNK(2,I)
      L3=LNK(3,I)
C     PRINT 1000,I,(IPT(III,L1,1),III=1,12)
C    1,(IPT(III,L3,3),III=1,12)
C    1,CHIL(I),PPP(I)
 1000 FORMAT(' PJN13',I3,1X,2(1X,12I2),F6.2,F7.2)
      NPP=NPP+1
      IF(NPP.GT.100) THEN
        NPP = 100
        IEVSAT = 1
      ENDIF
      KLOC(NPP) = 4

      LP(1,NPP)=L1
      LP(2,NPP)=00
      LP(3,NPP)=L3
      PSSS(NPP)=PSS(I)
      PISS(NPP)=PIS(I)
      RSSS(NPP)=RSS(I)
      RISS(NPP)=RIS(I)
      DO 551 KK=1,12
      IPP(KK,NPP)=IPT(KK,L1,1)
C     IPP(KK+12,NPP)=IPT(KK,L2,2)
      IPP(KK+24,NPP)=IPT(KK,L3,3)
 551  CONTINUE
      CHPP(NPP)=CH(I)
      PROD=PROB(CH(I)*24.,24)
      CALL SHS(578,0,PROD )
      CALL SHS(550,0,8.001)
      CALL SHS(550,0,10.001)
 550  CONTINUE

      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.55  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.29  by  Stephen Burke
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Calculate parameters of single(unlinked)
*          planar line segments. OBSOLETE -
*          replaced by FPSPC
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPSP
**: FPSP 40000 SM.   Undo +SEQ expansion.
**----------------------------------------------------------------------
**: FPSP   30907 RP. Farm changes.
**----------------------------------------------------------------------
*
*     SELECT SINGLE  PLANAR SEGMENTS IN 1ST MODULE
*     THAT DO NOT PROJECT INTO FIRST RADIAL MODULE
*
*     Fit parameters are in H1WORK:
*     RPCOSG(K) = Slope of Phi-z fit
*     RPSING(K) = Slope of R-z fit
*     PHZG(K)   = Intercept of Phi-z fit (at z=0)
*     ZIG(K)    = Intercept of R-z fit (at z=0)
*     Errors are in FTRERR:
*     COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR
*     Dxxxx = sigma (not squared) of parameter xxxx
*     COVP  = covariance of Phi-z fit parameters
*     COVR  = covariance of R  -z fit parameters

*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
*     Common for segment numbers...
      COMMON /FPSEGN/ ISG(3,MAXTRK)
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      COMMON /FPSEG3/ ISGR(3,MAXSEG)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT


*     Local arrays...
      DIMENSION IUSEDP(MAXTRK,36), IUSEG( MAXSEG, 3)
      DIMENSION RSEG(4),PSEG(4)
      DIMENSION XX(20),YY(20)
      PARAMETER(PI2=6.2831853)
      DATA ISTART/0/
C
C
C---   LOOP OVER SUPERMODULES - FOR RADIALS
C
C      MOD 20/1/93  TO PICK UP SINGLE SEMENTS IN ALL MODULES
C

      DO 20 ISMP=1,3
      DO 15 IP = 1,NFSEG(ISMP)
C
C---  search only unused segments
C
      IF(IUZP(IP,ISMP).NE.0)GOTO15
C
C---  search only the disconnected set
C
      IF( MASKSG(IP,ISMP) .NE. 0 )GO TO 15
C
C---  Extract planar segment and covariance matrix
C
C     STR LINES THROUGH PLANARS IN PHI-Z  R-Z
C     DISTANCES IN MM HERE FOR RCWH
      DO 30 I = 1,4
C---
      PSEG(I) = XYDXY(I,IP,ISMP)
C---
   30 CONTINUE
C---
      Z1MM=ZPP(1+12*(ISMP-1))*10.
      Z2MM=ZPP(12+12*(ISMP-1))*10.
      X1=PSEG(1)+Z1MM*PSEG(3)
      Y1=PSEG(2)+Z1MM*PSEG(4)
      X2=PSEG(1)+Z2MM*PSEG(3)
      Y2=PSEG(2)+Z2MM*PSEG(4)
      R1=SQRT(X1**2+Y1**2)
      R2=SQRT(X2**2+Y2**2)
      P1=ATAN2(Y1,X1)
      P1=AMOD(P1,PI2)
      IF(P1.LT.0.)P1=P1+PI2
      P2=ATAN2(Y2,X2)
      P2=AMOD(P2,PI2)
      IF(P2.LT.0.)P2=P2+PI2
      DP=P1-P2
      IF(DP.GT.6.0)DP=DP-PI2
      IF(DP.LT.-6.0)DP=DP+PI2
      RSS      =(R1-R2)/(Z1MM-Z2MM)
      RIS      =(R1-RSS*Z1MM)
C     TEST IF EXTRAPOLATED PLANAR SEGMENT SHOULD HIT RADIAL
CTEMP R160=RSS*1600. +RIS
CTEMP IF(R160.LT.800.)GOTO15
C


      NPP=NPP+1
      IF(NPP.GT.100) THEN
        NPP = 100
        IEVSAT = 1
      ENDIF
      KLOC(NPP) = 6
      CALL SHS(716,0,11.01)

C     BACK TO CMS
      RSSS(NPP)=(R1-R2)/(Z1MM-Z2MM)
      RISS(NPP)=(R1-RSSS(NPP)*Z1MM)/10.
      PSSS(NPP)=     DP*10./(Z1MM-Z2MM)
      PISS(NPP)=(P1-PSSS(NPP)*Z1MM/10.)
      LPP(1   ,NPP)=0
      LPP(2   ,NPP)=0
      LPP(3   ,NPP)=0
      LPP(ISMP,NPP)=IP
      LRR(1,NPP)=0
      LRR(2,NPP)=0
      LRR(3,NPP)=0
      DO 36 II=1,36
      IRR(II,NPP)=0
      IPP(II,NPP)=0
 36   CONTINUE
      DO 35 II=1,12
      IOSP=IDGISG(II,IP,ISMP)
      IPP(II+(ISMP-1)*12,NPP)=IABS(IOSP)
      SPP(II+(ISMP-1)*12,NPP)=SIGN(1.0,FLOAT(IOSP))
 35   CONTINUE

   15 CONTINUE
   20 CONTINUE
      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.55  by  Stephen Burke
*-- Author :    I. O. Skillicorn      31/08/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Calculate chi**2 of helix through planar-
*          based track
*
*HTMLI     : Describe the Input variables to the routine
*
*          Line  segment parameters , see FPLPKP
*
*HTMLO     : Describe the Output of the routine
*
*          CHID: chi**2 of track model
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPCHI(IM1,IM2,I,J,CHID)
**: FPCHI 40000 IS.  New routine to calculate chi-squared.
**----------------------------------------------------------------------
C234567
C     CALCULATES CHI RELATIVE TO HELIX FOR TWO-MODULE TRACKS
*ARRAY DIMENSIONS...
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FPFVTX.
      COMMON/VERTFF/ZFF,XFF,YFF
*
*KEND.
      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)

      DIMENSION XX(50),YY(50),ZZ(50),WP(50)
      PI2=2.*ACOS(-1.)
C     VERTEX FROM FIRST PLANAR MODULE
C     HELIX DEFINED RELATIVE TO THIS VERTEX
      IF(IM1.EQ.1)ZED=ZPP(1)
      IF(IM1.EQ.2)ZED=ZPP(13)
      XFFF=SPAR(3,I,IM1)*ZED+SPAR(4,I,IM1)
      YFFF=SPAR(1,I,IM1)*ZED+SPAR(2,I,IM1)
      ZFFF=ZED
C     FIT HELIX TO FITTED LINE SEGMENTS
C     STRAIGHT LINE PHI-Z
      IC=0
C      WRITE(*,*)' M1,M2,I,J ',IM1,IM2,I,J
C      WRITE(*,*)' XFFF,YFFF,ZFFF ',XFFF,YFFF,ZFFF
      DO 10 IP=1,36
      IM=(IP-1)/12+1
      IF((IM.NE.IM1).AND.(IM.NE.IM2))GOTO 10
      IC=IC+1
      IF(IM.EQ.IM1)II=I
      IF(IM.EQ.IM2)II=J
      ZED=ZPP(IP)
      XF=SPAR(3,II,IM)*ZED+SPAR(4,II,IM)
      YF=SPAR(1,II,IM)*ZED+SPAR(2,II,IM)
      XH=XF-XFFF
      YH=YF-YFFF
      RH=SQRT(XH**2+YH**2)
C      WRITE(*,*)' IM,II,RH,XH,YH ',IM,II,RH,XH,YH
      IF(RH.NE.0.0)THEN
      XX(IC)=ZED
      YY(IC)=ATAN2(YH/RH,XH/RH)
      ZZ(IC)=RH
      WP(IC)=1./(0.1/RH)
      ELSE
      XX(IC)=ZED
      YY(IC)=0.0001
      ZZ(IC)=RH
      WP(IC)=0.0
      ENDIF
 10   CONTINUE
      DO 20 JJ=2,IC
      DP=YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.0)THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 20   CONTINUE
C     FIT PHI-Z IN HELIX FRAME
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
      IF(PS.EQ.0.0)PS=0.0000001
C     FIT R-Z IN HELIX FRAME
C     STRAIGHT LINE IN R - SIN(.....)
      IC=0
      DO 30 IP=1,36
      IM=(IP-1)/12+1
      IF((IM.NE.IM1).AND.(IM.NE.IM2))GOTO 30
      IC=IC+1
      XX(IC)=SIN(PS*(ZPP(IP)-ZFFF))/PS
      WP(IC)=1.0
 30   CONTINUE
      CALL FTLFTW(XX,ZZ,WP,IC,0,2,RS,RI,D1,D2,D3,D4)
C     EXAMINE PLANAR RESIDUALS WITH RESPECT TO HELIX
      CHID=0.
      IC=0
      DO 40 IP=1,36
      IM=(IP-1)/12+1
      IF((IM.NE.IM1).AND.(IM.NE.IM2))GOTO40
      LL=IP-(IM-1)*12
      IF(IM.EQ.IM1)II=I
      IF(IM.EQ.IM2)II=J
      JJ=IPT(LL,II,IM)
      IF(JJ.LE.0)GOTO40
      SGNN=SGN(LL,II,IM)
      WM=SGNN*DRIW(JJ,IP)+DW(JJ,IP)
      ZED=ZPP(IP)
      PHIH=PS*ZED+PI
      RRH=RS*SIN(PS*(ZED-ZFFF))/PS+RI
      THETA=ATAN2(S(IP),C(IP))
      WEH=RRH*SIN(PHIH-THETA)+YFFF*COS(THETA)-XFFF*SIN(THETA)
      IC=IC+1
      CHID=CHID+(WM-WEH)**2/(0.03)**2
 40   CONTINUE
      CHID=CHID/FLOAT(IC)
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.37.54  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.16  by  Stephen Burke
*CMZU:  4.00/08 18/11/93  08.59.35  by  Stephen J. Maxfield
*-- Author :    I. O. Skillicorn      18/11/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Refit planar-based tracks including radial
*          information.  Phi-z refitted.
*
*HTMLI     : Describe the Input variables to the routine
*
*
* Planar-based and P->R link tracks:
*          NPP tracks
*          Hits                    :- IRR/SRR IPP/SPP
*          Parameters(phi',phi0)   :- PSSS,PISS
*          Parameters(R',R0)       :- RSSS,RISS
*
*
*HTMLO     : Describe the Output of the routine
*
*          Parameters(phi',phi0)   :- PSSS,PISS
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPRFIT
*     REFIT TRACK MODEL( PHI-Z) INCLUDING RADIALS
*     CALL THIS ROUTINE WHEN ALL PLANAR PATREC IS COMPLETE
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


*     Common for segment numbers...
      COMMON /FPSEGN/ ISG(3,MAXTRK)


*     COMMON FOR IOS PLANAR LINK
      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)

      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
C     THE SIGN OF THE PLANAR DRIFT IS FILLED IN FTADD
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
C     COMMON FOR RADIALS ASSOCIATED WITH PLANAR TRACKS
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
C     PLANAR SEGMENTS ASSOCIATED  WITH RADIALS
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FLINK3/LNK3(MAXTRK,3)

*     Local arrays...
      DIMENSION XX(100),YY(100),WP(100)
      PARAMETER(PI2=6.283185307)
      DO 100 I=1,NPP
      IC=0
      DO 200 ISM=1,3
      IPLAN=LPP(ISM,I)
      I1=(ISM-1)*12+1
      I2=ISM*12
C     PLANARS
      IF(IPLAN.NE.0)THEN
      DO 210 IP=I1,I2
      Z1=ZPP(IP)
      XF=XYDXY(1,IPLAN,ISM)/10.+Z1*XYDXY(3,IPLAN,ISM)
      YF=XYDXY(2,IPLAN,ISM)/10.+Z1*XYDXY(4,IPLAN,ISM)
      IC=IC+1
      XX(IC)=Z1
      YY(IC)=ATAN2(YF,XF)
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
      WP(IC)=1./(0.1/SQRT(XF**2+YF**2))
 210  CONTINUE
      ENDIF
C     RADIALS
      DO 220 IP=I1,I2
      Z1=ZP(IP)
C     RADIUS DEFINED BY PLANARS
      RR=RISS(I)+RSSS(I)*Z1
C     FOR GRAPHICS
C     J=IRN(IP,I)
C     FOR H1REC
      J=IRR(IP,I)
      IF(J.EQ.0)GOTO220
      IC=IC+1
C     FOR GRAPHICS
C     PHI=ATAN((DRI(J,IP)*SDN(IP,I)+DWS(J,IP))/RR) +WW(J,IP)
C     FOR H1REC
      PHI=ATAN((DRI(J,IP)*SRR(IP,I)+DWS(J,IP))/RR) +WW(J,IP)
      IF(PHI.LT.0.0)PHI=PHI+PI2
      XX(IC)=Z1
      YY(IC)=PHI
      WP(IC)=1./(0.1/RR)
 220  CONTINUE
 200  CONTINUE
      IF(IC.GT.1)THEN
      DO 250 JJ=2,IC
      DP=YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.0)THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 250  CONTINUE
      ENDIF
C     REFIT PHI-Z INCLUDING RADIALS (NOTE: FPSP DOES NOT FIT
C                                                THE LINESEG  )
C     WRITE(*,*)I,PISS(I),PSSS(I)
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
      PISS(I)=PI
      PSSS(I)=PS
C     WRITE(*,*)I,PISS(I),PSSS(I)
 100  CONTINUE
      RETURN
      END
*CMZ :  8.07/00 20/11/96  21.52.11  by  Stephen Burke
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  7.02/11 27/10/95  17.30.13  by  Stephen Burke
*CMZU:  7.00/04 24/04/95  17.02.17  by  Stephen Burke
*-- Author :    "I. O. Skillicorn"   24/04/95
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Link planar and radial based tracks
*          to connected and disconnected set planar
*          line segments ( primary+secondary+tertiary).
*          Note: this is the only routine that uses
*          connected planars. Note also the check that
*          points have not been previously used.
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial-based tracks:
*          IG tracks
*          Hits/drift sign         :- IRN/SDN IRP/SDP
*          Segments planars/radials:- ISGG LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
* Planar-based and P->R link tracks:
*          NPP tracks
*          Hits                    :- IRR/SRR IPP/SPP
*          Segments radials/planars:- LRR LPP
*          Parameters(phi',phi0)   :- PSSS,PISS
*          Parameters(R',R0)       :- RSSS,RISS
*
*
*HTMLO     : Describe the Output of the routine
*
*          Used point flag         :- IPUZE
*          Hits/drift sign         :- IRN/SDN IRP/SDP
*          Segments planars/radials:- ISGG LNK3
*          Hits                    :- IRR/SRR IPP/SPP
*          Segments radials/planars:- LRR LPP
*
*HTMLE     : Terminates the HTML documentation
*
*
*
*
      SUBROUTINE FPCXTD
*
*
*      test8.f reject segment if it does not link
*      mid plane with all planar segments for
*      planar based track : cut 5cms**2
*
*
*    fpcxtd.new.f  remove radial based (2):-
*    planar pickup from planars appears unsafe
*
*    searches connected + disconnected set
*
*
*
*
*
*
*
*
*     Routine to pick up planar segments from connected set.
*
*     radial based tracks:-
*     1)Searches for closest segment to track K in the R-Phi
*     direction which is sufficiently close in the radial direction.
*     Separation is Rmean*delta-phi, where Rmean is R
*     of planar segment  and delta-phi
*     is separation in Phi.
*     2) Uses each first-pass associated planar to search for
*     a link to a planar in the connected set(dd defined) that
*     is close to the radial-defined track.
*
*     Radial only: associates planars using (1).
*     Radial+planar: uses (1)+(2).
*
*     cuts changed relative to fpcxtd.test4.f
*     open dd cut for  radial based tracks to 5 cm**2
*     use sum of sep+dd < 3 cm**2 for planars
*
*
*
*
*
*
*     planar based tracks:-
*     uses each found planar to search for a link (DD defined)
*     to a planar segment in connected set. checks planar coord.
*     is within 1 cm of expectation from str. line phi-z,r-z.
*
*
*
*     Fit parameters are in H1WORK:
*     RPCOSG(K) = Slope of Phi-z fit
*     RPSING(K) = Slope of R-z fit
*     PHZG(K)   = Intercept of Phi-z fit (at z=0)
*     ZIG(K)    = Intercept of R-z fit (at z=0)
*     Errors are in FTRERR:
*     COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR
*     Dxxxx = sigma (not squared) of parameter xxxx
*     COVP  = covariance of Phi-z fit parameters
*     COVR  = covariance of R  -z fit parameters

*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


*     Common for segment numbers...
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FTRFLG/ IBRR(MAXTRK),IBPP(100),IVRR(MAXTRK)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
      common/fcnset/ipuze(maxhts,numwpl)

*     Local arrays...
      DIMENSION  IUSEG( MAXSEG, 3)
      DIMENSION RSEG(4),PSEG(4)
      PARAMETER(PI2=6.2831853)
      data istart/0/
c     debug **************************************************
      if(istart.eq.0)then
      istart=1
      endif
c*************************************************************
*     cuts   mm  for radials
       DRPCUT = 2.
       DRCUT  = 100.
c     hard wired 5 cm**2 cut in DDmin
********************************************************************
c      and note hard wired cuts below
c      for planar linkage!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c      planar linkage cuts in cm or cm**2
c      sep + ddmin < 3 cm**2
c******************************************************************
c
c     Examine multimodule radial and planar based tracks that
c     have been linked using planar segments in the disconnected
c     set. Set these points used and search for additional planar
c     segments ( made of unused points)  in the connected set.
c
c
      call vzero(ipuze,maxhts*numwpl)
c     for radial/planar tracks mark points(discon. set) used.
      do 110 i=1,ig
      if(ivrr(i).ne.1)goto110
      do120 j=1,36
      jp=irp(j,i)
      if(jp.ne.0)ipuze(jp,j)=1
 120  continue
 110  continue
      do 115 i=1,npp
      do125 j=1,36
      jp=ipp(j,i)
      if(jp.ne.0)ipuze(jp,j)=1
 125  continue
 115  continue


*     write(*,*)' fpcxtd entered '



      do 200 ity=1,2
c     ity=1 planar based tracks
c     ity=2 radial based tracks
      if(ity.eq.1)igg=npp
      if(ity.eq.2)igg=ig
      do 100 k=1,igg
c     good radials only
      if(ity.eq.2.and.ivrr(k).ne.1)goto100
c     debug ********************************************************
      if(ity.eq.2)then
*     PRINT 1001,k,(IRN(n,k),n=1,36),LNK3(k,1),LNK3(k,2),LNK3(k,3)
*     PRINT 1002,k,(IRP(n,k),n=1,36),ISGG(1,k),ISGG(2,k),ISGG(3,k)
      iplaa=0
      if(isgg(1,k)+isgg(2,k)+isgg(3,k).ne.0)iplaa=1
*     write(*,*)' k,iplar',k,iplaa
c     if(isgg(1,k)+isgg(2,k)+isgg(3,k).ne.0)then
c       write(*,*)' fpcxtd  p ',k,ivrr(k),ibrr(k),iplaa
c     endif
      endif
c     end debug *************************************************
C
C---   Loop over supermodules
C

      DO 10 ISM = 1,3
C
C---  Calculate  prediction for segment in this supermodule
C
      Z = ZPP( 6 + (ISM -1)*12 )

      if(ity.eq.2)then
c     radial based track
c     skip module if segment found
      if(isgg(ism,k).ne.0)goto10

C
C---  RR and PHI calculated for this Z as predicted by radials
C
      RR  = RPSING(K)*Z + ZIG(K)
      RRAD= RR*10.
      PHI = RPCOSG(K)*Z + PHZG(K)
      PHI = AMOD(PHI,PI2)
      IF(PHI.LT.0.0) PHI = PHI + PI2
C
C---  Convert to cartesian coordinates
C
      X = RR * COS(PHI)  +  XVV
      Y = RR * SIN(PHI)  +  YVV
C
C---  Find differentials of x,y wrt z
C
      XDZ = RPSING(K)*COS(PHI) - RR*RPCOSG(K)*SIN(PHI)
      YDZ = RPSING(K)*SIN(PHI) + RR*RPCOSG(K)*COS(PHI)

      endif
      if(ity.eq.1)then
c
c     planar based track
c
c     skip module if segment found
      if(lpp(ism,k).ne.0)goto 10

C
C---  RR and PHI calculated for this Z as predicted by planars
C
      RR  = rsss(K)*Z + riss(K)
      RRAD= RR*10.
      PHI = psss(K)*Z + piss(K)
      PHI = AMOD(PHI,PI2)
      IF(PHI.LT.0.0) PHI = PHI + PI2
C
C---  Convert to cartesian coordinates
C
      X = RR * COS(PHI)  +  XVV
      Y = RR * SIN(PHI)  +  YVV
C
C---  Find differentials of x,y wrt z
C
      XDZ = rsss(K)*COS(PHI) - RR*psss(K)*SIN(PHI)
      YDZ = rsss(K)*SIN(PHI) + RR*psss(K)*COS(PHI)

      endif
C
C---  Form  segment cartesian vector converting to mm
C
      RSEG(1) = X*10.0
      RSEG(2) = Y*10.0
      RSEG(3) = XDZ
      RSEG(4) = YDZ
      ZMM     = Z*10.0
C
      ISMIN = 0
      DRMIN = 1000000.0
      DRM   = 1000000.0
      ddmin=  1000000000.
      ismind=0
      isminr=0
      DO 20 IP = 1,NFSEG(ISM)
C
C---  search only unused segments
C
C
C---  search only the connected set
c     ( a check has been made of searching all -
c       a negligible number of additional planars
c       are found)
C
C
C     However: this does provide a technique for re-searching
c              for segments unlinked in the first pass;
c              so reexamine the disconnected set.
c
C
c     IF( MASKSG(IP,ISM) .eq. 0 )GO TO 20

c     check if points have been used
      do 25 i=1,12
      iosp=idgisg(i,ip,ism)
      if(iosp.eq.0)goto25
      ipu=iabs(iosp)
      ipl=I+(ism-1)*12
      if(ipuze(ipu,ipl).eq.1)goto20
 25   continue
C
C---  Extract planar segment and covariance matrix
C
      DO 30 I = 1,4
C---
      PSEG(I) = XYDXY(I,IP,ISM)
C---
   30 CONTINUE
C---

*     R and Phi for planar segment
      PSEG(1)  = PSEG(1)  +  ZMM * PSEG(3)
      PSEG(2)  = PSEG(2)  +  ZMM * PSEG(4)
      RPL = SQRT(PSEG(1)**2 + PSEG(2)**2)

      PHIPLA = ATAN2(PSEG(2), PSEG(1))
      PHIPLA = AMOD(PHIPLA,PI2)
      IF(PHIPLA.LT.0.0) PHIPLA = PHIPLA + PI2

*     Believe the radial segment prediction in the 'drift' direction
*     only. More-or-less ignore rad radius...
*     RMEAN = 0.2*(RRAD + 4.0*RPL)
      RMEAN = RPL
*     RMEAN = RRAD
      DELP  = PHIPLA - PHI
      IF(DELP .GT. (PI2/2.)) THEN
           DELP = DELP -PI2
      ELSEIF(DELP .LT. -(PI2/2.)) THEN
           DELP = DELP +PI2
      ENDIF

      DRPHI = RMEAN*(DELP)
      DR    = RPL - RRAD
      DRPHI = ABS(DRPHI)
      DR    = ABS(DR)

      if(ity.eq.2)then
c      write(*,*)' rb tr ',k,ip,delp,rmean,drphi
c     radial based track:
c     check if planar segment links to
c     an associated planar.
      ddm=100000.
      fnd=0.
      do 92 ismm=1,3
c     link adjacent only
      if(iabs(ismm-ism).gt.1)goto92
      if(ismm.eq.ism)goto92
      if(isgg(ismm,k).ne.0)then
      ipl=isgg(ismm,k)
      z1=zpp(6+(ismm-1)*12)*10.
      zm=(z1+zmm)*0.5
      x1m=(xydxy(1,ipl,ismm)+zm*xydxy(3,ipl,ismm))*.1
      y1m=(xydxy(2,ipl,ismm)+zm*xydxy(4,ipl,ismm))*.1
      x2m=(xydxy(1,ip,ism)+zm*xydxy(3,ip,ism))*.1
      y2m=(xydxy(2,ip,ism)+zm*xydxy(4,ip,ism))*.1
c      note units  cm**2
      dd=(x1m-x2m)**2+(y1m-y2m)**2
c     may link to more than one planar seg
c     forming track
      if(dd.lt.ddm)then
      ddm=dd
      fnd=1.
      endif
      endif
 92   continue
c     if(fnd.ne.0.0)call  shs(3018,0,ddm)
c
      if(ddm.lt.ddmin.and.fnd.ne.0.0)then
      ddmin=ddm
      isminr=ip
      endif

      endif


      if(ity.eq.2)then
      IF(DRPHI .LT. DRMIN) THEN
      IF(DR    .LT. DRCUT) THEN
        DRMIN = DRPHI
        ISMIN = IP
        DRM   = DR
      ENDIF
      ENDIF
      endif
C
C---
C
      if(ity.eq.1)then
c      dd parameter calculated as in planar linking.
c     select best if several planars already found to
c     which a link may be made
      ddm=100000.
      fnd=0.
      do 91 ismm=1,3
c     link adjacent only
      if(iabs(ismm-ism).gt.1)goto91
      if(ismm.eq.ism)goto91
      if(lpp(ismm,k).ne.0)then
      ipl=lpp(ismm,k)
      z1=zpp(6+(ismm-1)*12)*10.
      zm=(z1+zmm)*0.5
      x1m=(xydxy(1,ipl,ismm)+zm*xydxy(3,ipl,ismm))*.1
      y1m=(xydxy(2,ipl,ismm)+zm*xydxy(4,ipl,ismm))*.1
      x2m=(xydxy(1,ip,ism)+zm*xydxy(3,ip,ism))*.1
      y2m=(xydxy(2,ip,ism)+zm*xydxy(4,ip,ism))*.1
c     note units cm**2
      dd=(x1m-x2m)**2+(y1m-y2m)**2
*********************************************
c     segment has to mid-plane point to all adjacent
c     planar linesegs
c     new 26/10/95
      if(dd.gt.5.0)go to 20
*********************************************
c     may link to more than one planar seg
c     forming track
      if(dd.lt.ddm)then
      ddm=dd
      xs=pseg(1)/10.
      ys=pseg(2)/10.
      fnd=1.
      endif
      endif
 91   continue
c     if(fnd.ne.0.0)call  shs(3013,0,ddm)
c
      if(ddm.lt.ddmin.and.fnd.ne.0.0)then
      ddmin=ddm
      ismind=ip
      xsm=xs
      ysm=ys
      endif

      endif
C
C---  End of loop over planar  segments for supermodule
C
   20 CONTINUE


C
C---  Build list of planar hits and mark segment and hits used
C
      IFR =  1+(ISM-1)*12
      ILS =  11+IFR


      if(ity.eq.2)then
c     radial based tracks

      IF(ISMIN .NE. 0) THEN
      IF(DRMIN .LT. DRPCUT) THEN
c     no planar linked by planar
c     use planar associated by track model
         IUSEG(ISMIN, ISM) = 1
         ISGG(ISM,K) = ISMIN
        II=0
        DO 50 IWIR= IFR, ILS
         II   = II+1
         IOSP = IDGISG(II,ISMIN,ISM)
         IF (IOSP.EQ.0) GOTO 50
         IRP(IWIR, K) = IABS(IOSP)
         SDP(IWIR, K) = SIGN(1.0, FLOAT(IOSP))
         Ipuze(IABS(IOSP), IWIR)=1
 50     CONTINUE
c      write(*,*)' fpcxtd: plseg added  r-b tr,mod ',k,ism,drmin

      ENDIF
      ENDIF




      endif


      if(ity.eq.1)then
c     planar based tracks

      ibad=0

      IF(ISMINd.NE. 0) THEN
c     centre of planar segment with respect to track model
       sep=(xsm-x)**2+(ysm-y)**2
c     hard wired 3 cm**2  cut ************************************************
      if(sep.gt.3.0)ibad=1

c
c     planar based tracks
c     select on sep+dd:      3 cm**2 hard wired cut********************


      IF((sep+ddmin).lt.3.0.and.ibad.eq.0) THEN

c     good link - store ,  set points used

         IUSEG(ISMINd, ISM) = 1
         lpp(ISM,K) = ISMINd

        II=0
        DO 70 IWIR= IFR, ILS
         II   = II+1
         IOSP = IDGISG(II,ISMINd,ISM)
         IF (IOSP.EQ.0) GOTO 70
         IpP(IWIR, K) = IABS(IOSP)
         SpP(IWIR, K) = SIGN(1.0, FLOAT(IOSP))
         ipuze(IABS(IOSP), IWIR)=1
 70     CONTINUE

c       write(*,*)' fpcxtd: pl seg added to p-b  tr,mod ',k,ism



      ENDIF
      ENDIF
      endif
C
C
C---  End of loop over supermodules
C
   10 CONTINUE


 100  continue
 200  continue
 1001 FORMAT(' RR',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1002 FORMAT(' RP',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1003 FORMAT(' PP',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
 1004 FORMAT(' PR',I2,3X,12I2,3X,12I2,3X,12I2,2X,3I2)
      RETURN
      END
*CMZU:  8.06/00 23/10/96  14.19.22  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  7.00/04 24/04/95  17.03.31  by  Stephen Burke
*-- Author :    I. O. Skillicorn   24/04/95
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Calculate track parameters for single
*          planars(unlinked)
*
*HTMLI     : Describe the Input variables to the routine
*
*          Used point flag         :- IPUZE
* Planar track segments:
*          NFSEG segments/module
*          Hits                    :- IDGISG
*          Parameters(x0,y0,x',y') :- XYDXY in mm
*
*
*
*HTMLO     : Describe the Output of the routine
*
* Planar-based and P->R link tracks:
*          NPP tracks
*          Hits                    :- IRR/SRR IPP/SPP
*          Segments radials/planars:- LRR LPP
*          Parameters(phi',phi0)   :- PSSS,PISS
*          Parameters(R',R0)       :- RSSS,RISS
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPSPC
*
*     SELECT SINGLE  PLANAR SEGMENTS IN 1ST MODULE
*     THAT DO NOT PROJECT INTO FIRST RADIAL MODULE
*
*     Fit parameters are in H1WORK:
*     RPCOSG(K) = Slope of Phi-z fit
*     RPSING(K) = Slope of R-z fit
*     PHZG(K)   = Intercept of Phi-z fit (at z=0)
*     ZIG(K)    = Intercept of R-z fit (at z=0)
*     Errors are in FTRERR:
*     COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR
*     Dxxxx = sigma (not squared) of parameter xxxx
*     COVP  = covariance of Phi-z fit parameters
*     COVR  = covariance of R  -z fit parameters

*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
*     Common for segment numbers...
      COMMON /FPSEGN/ ISG(3,MAXTRK)
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FPSEG2/ ISGP(3,MAXTRK),IUZP(MAXSEG,3),IUZR(MAXTRK,3)
      COMMON /FPSEG3/ ISGR(3,MAXSEG)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT
      common/fcnset/ipuze(maxhts,numwpl)


*     Local arrays...
      DIMENSION IUSEDP(MAXTRK,36), IUSEG( MAXSEG, 3)
      DIMENSION RSEG(4),PSEG(4)
      DIMENSION XX(20),YY(20)
      PARAMETER(PI2=6.2831853)
      DATA ISTART/0/
C
C
C---   LOOP OVER SUPERMODULES - FOR RADIALS
C
C      MOD 20/1/93  TO PICK UP SINGLE SEMENTS IN ALL MODULES
C

      DO 20 ISMP=1,3
      DO 15 IP = 1,NFSEG(ISMP)
C
C---  search only unused segments
C
      IF(IUZP(IP,ISMP).NE.0)GOTO15
C
C---  search only the disconnected set
C
      IF( MASKSG(IP,ISMP) .NE. 0 )GO TO 15

c     check if points have been used
      do 25 i=1,12
      iosp=idgisg(i,ip,ismp)
      if(iosp.eq.0)goto25
      ipu=iabs(iosp)
      ipl=I+(ismp-1)*12
      if(ipuze(ipu,ipl).eq.1)goto15
 25   continue
C
C
C---  Extract planar segment and covariance matrix
C
C     STR LINES THROUGH PLANARS IN PHI-Z  R-Z
C     DISTANCES IN MM HERE FOR RCWH
      DO 30 I = 1,4
C---
      PSEG(I) = XYDXY(I,IP,ISMP)
C---
   30 CONTINUE
C---
      Z1MM=ZPP(1+12*(ISMP-1))*10.
      Z2MM=ZPP(12+12*(ISMP-1))*10.
      X1=PSEG(1)+Z1MM*PSEG(3)
      Y1=PSEG(2)+Z1MM*PSEG(4)
      X2=PSEG(1)+Z2MM*PSEG(3)
      Y2=PSEG(2)+Z2MM*PSEG(4)
      R1=SQRT(X1**2+Y1**2)
      R2=SQRT(X2**2+Y2**2)
      P1=ATAN2(Y1,X1)
      P1=AMOD(P1,PI2)
      IF(P1.LT.0.)P1=P1+PI2
      P2=ATAN2(Y2,X2)
      P2=AMOD(P2,PI2)
      IF(P2.LT.0.)P2=P2+PI2
      DP=P1-P2
      IF(DP.GT.6.0)DP=DP-PI2
      IF(DP.LT.-6.0)DP=DP+PI2
      RSS      =(R1-R2)/(Z1MM-Z2MM)
      RIS      =(R1-RSS*Z1MM)
C     TEST IF EXTRAPOLATED PLANAR SEGMENT SHOULD HIT RADIAL
CTEMP R160=RSS*1600. +RIS
CTEMP IF(R160.LT.800.)GOTO15
C


      NPP=NPP+1
      IF(NPP.GT.100) THEN
        NPP = 100
        IEVSAT = 1
      ENDIF
      KLOC(NPP) = 6
      CALL SHS(716,0,11.01)

C     BACK TO CMS
      RSSS(NPP)=(R1-R2)/(Z1MM-Z2MM)
      RISS(NPP)=(R1-RSSS(NPP)*Z1MM)/10.
      PSSS(NPP)=     DP*10./(Z1MM-Z2MM)
      PISS(NPP)=(P1-PSSS(NPP)*Z1MM/10.)
      LPP(1   ,NPP)=0
      LPP(2   ,NPP)=0
      LPP(3   ,NPP)=0
      LPP(ISMP,NPP)=IP
      LRR(1,NPP)=0
      LRR(2,NPP)=0
      LRR(3,NPP)=0
      DO 36 II=1,36
      IRR(II,NPP)=0
      IPP(II,NPP)=0
 36   CONTINUE
      DO 35 II=1,12
      IOSP=IDGISG(II,IP,ISMP)
      IPP(II+(ISMP-1)*12,NPP)=IABS(IOSP)
      SPP(II+(ISMP-1)*12,NPP)=SIGN(1.0,FLOAT(IOSP))
 35   CONTINUE

   15 CONTINUE
   20 CONTINUE
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.47.12  by  Girish D. Patel
*CMZ :  8.04/00 31/07/96  21.40.05  by  Stephen Burke
*-- Author :    I. O. Skillicorn      31/07/96
*HTMLP*    : Describe the Purpose of the routine
*
*          Check that d(phi)/dz for planar
*          line segment agrees with that from
*          planar-based track model
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
* Planar track segments:
*          NFSEG segments/module
*          Hits                    :- IDGISG
*          Parameters(x0,y0,x',y') :- XYDXY in mm
*          XYDXY has been transfered to SPAR(cms)
*
*
*HTMLO     : Describe the Output of the routine
*
*          IFLAG=1 for good link
*
*
*HTMLE     : Terminates the HTML documentation
      SUBROUTINE FPPHIT(m1,m2,i,j,iflag)
c     check planar linking in phi:
c     d(phi)/dz for the line segments should agree
c     with  that from the track model.
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FPFVTX.
      COMMON/VERTFF/ZFF,XFF,YFF
*
*KEEP,FPJPAR.
      COMMON/FPJPAR/
     +      RRCUT1, RRCUT2, RRCUT3,
     +      PLCC3, PLCC12, PLCC23, PLCC13
*KEND.
      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)
      COMMON/FTPLNK/LINK,CHIL(100),LNK(3,100),IUS(100,3)
      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)

      COMMON/FKLOC/KLOC(100)
      COMMON/FEVSAT/IEVSAT
      COMMON/fsegtp/iseg(100,3)

      data istart/0/

      if(istart.eq.0)then
         istart=1
         call stext(970,4,' fpphit phips1-phipl 12 ')
         call bhs(970,0,50,-0.005,0.005)
         call stext(971,4,' fpphit phips2-phipl 12 ')
         call bhs(971,0,50,-0.005,0.005)
         call stext(972,4,' fpphit phips2-phips1 12')
         call bhs(972,0,50,-0.01,0.01)
         call stext(973,4,' fpphit phi2-phi1 midplane 12')
         call bhs(973,0,50,-0.50,0.50)
         call stext(974,4,' fpphit phips1-phipl 23 ')
         call bhs(974,0,50,-0.005,0.005)
         call stext(975,4,' fpphit phips2-phipl 23 ')
         call bhs(975,0,50,-0.005,0.005)
         call stext(976,4,' fpphit phips2-phips1 23')
         call bhs(976,0,50,-0.01,0.01)
         call stext(977,4,' fpphit phi2-phi1 midplane 23')
         call bhs(977,0,50,-0.50,0.50)
         call stext(978,4,' fpphit phips1-phipl 13 ')
         call bhs(978,0,50,-0.005,0.005)
         call stext(979,4,' fpphit phips2-phipl 13 ')
         call bhs(979,0,50,-0.005,0.005)
         call stext(980,4,' fpphit phips2-phips1 13')
         call bhs(980,0,50,-0.01,0.01)
         call stext(981,4,' fpphit phi2-phi1 midplane 13')
         call bhs(981,0,50,-0.50,0.50)
      endif

      PI2=6.283185307
      if(m1.eq.1)ip1=6
      if(m1.eq.2)ip1=18
      if(m2.eq.2)ip2=18
      if(m2.eq.3)ip2=30
      Z1=ZPP(ip1)
      X1=SPAR(3,I,m1)*Z1+SPAR(4,I,m1)
      Y1=SPAR(1,I,m1)*Z1+SPAR(2,I,m1)
      Z2=ZPP(ip2)
      X2=SPAR(3,J,m2)*Z2+SPAR(4,J,m2)
      Y2=SPAR(1,J,m2)*Z2+SPAR(2,J,m2)
      zm=0.5*(z1+z2)
c     get parameters of line connecting centres of
c     segments
      p1=atan2(y1,x1)
      p1=amod(p1,pi2)
      if(p1.lt.0.0)p1=p1+pi2
      p2=atan2(y2,x2)
      p2=amod(p2,pi2)
      if(p2.lt.0.0)p2=p2+pi2
      dp=p2-p1
      if(dp.gt.6.0)dp=dp-pi2
      if(dp.lt.-6.0)dp=dp+pi2
      ps=dp/(z2-z1)
      pi=(p1-ps*z1)
c
c     get parameters of each segment
c     segment start 1
      Z11=ZPP(ip1-5)
      X1=SPAR(3,I,m1)*Z11+SPAR(4,I,m1)
      Y1=SPAR(1,I,m1)*Z11+SPAR(2,I,m1)
c     segment end 1
      Z12=ZPP(ip1+6)
      X2=SPAR(3,I,m1)*Z12+SPAR(4,I,m1)
      Y2=SPAR(1,I,m1)*Z12+SPAR(2,I,m1)
      p1=atan2(y1,x1)
      p1=amod(p1,pi2)
      if(p1.lt.0.0)p1=p1+pi2
      p2=atan2(y2,x2)
      p2=amod(p2,pi2)
      if(p2.lt.0.0)p2=p2+pi2
      dp=p2-p1
      if(dp.gt.6.0)dp=dp-pi2
      if(dp.lt.-6.0)dp=dp+pi2
c     parameters of first segment
      ps1=dp/(z12-z11)
      pii1=(p1-ps1*z11)
c
c     segment start 2
      Z11=ZPP(ip2-5)
      X1=SPAR(3,j,m2)*Z11+SPAR(4,j,m2)
      Y1=SPAR(1,j,m2)*Z11+SPAR(2,j,m2)
c     segment end 2
      Z12=ZPP(ip2+6)
      X2=SPAR(3,j,m2)*Z12+SPAR(4,j,m2)
      Y2=SPAR(1,j,m2)*Z12+SPAR(2,j,m2)
      p1=atan2(y1,x1)
      p1=amod(p1,pi2)
      if(p1.lt.0.0)p1=p1+pi2
      p2=atan2(y2,x2)
      p2=amod(p2,pi2)
      if(p2.lt.0.0)p2=p2+pi2
      dp=p2-p1
      if(dp.gt.6.0)dp=dp-pi2
      if(dp.lt.-6.0)dp=dp+pi2
c     parameters of second segment
      ps2=dp/(z12-z11)
      pii2=(p1-ps2*z11)
      ps1ps=amod(ps1-ps,pi2)
      ps2ps=amod(ps2-ps,pi2)
      ps2ps1=amod(ps2-ps1,pi2)
c     phi midplane
      ph1=ps1*zm+pii1
      ph2=ps2*zm+pii2
      ph1ph2=amod(ph1-ph2,pi2)
      iflag=0
      if(abs(ps1ps).gt.0.002)iflag=1
      if(abs(ps2ps).gt.0.002)iflag=1

      if(m1.eq.1.and.m2.eq.2)then
         call shs(970,0,ps1ps)
         call shs(971,0,ps2ps)
         if(iflag.eq.0)then
            call shs(972,0,ps2ps1)
         endif
         call shs(973,0,ph1ph2)
      endif
      if(m1.eq.2.and.m2.eq.3)then
         call shs(974,0,ps1ps)
         call shs(975,0,ps2ps)
         if(iflag.eq.0)then
            call shs(976,0,ps2ps1)
         endif
         call shs(977,0,ph1ph2)
      endif
      if(m1.eq.1.and.m2.eq.3)then
         call shs(978,0,ps1ps)
         call shs(979,0,ps2ps)
         if(iflag.eq.0)then
            call shs(980,0,ps2ps1)
         endif
         call shs(981,0,ph1ph2)
      endif

      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.46.54  by  Girish D. Patel
*CMZ :  8.05/00 27/09/96  16.51.36  by  I.O. Skillicorn
*-- Author :    I.O. Skillicorn   27/09/96
*HTMLP*    : Describe the Purpose of the routine
*
*          Refit radial-based tracks including
*          planar information.
*
*
*HTMLI     : Describe the Input variables to the routine
*
* Planar track segments:
*          NFSEG segments/module
*          Parameters(x0,y0,x',y') :- XYDXY in mm
* Radial-based tracks:
*          IG tracks
*          Hits/drift sign         :- IRN/SDN IRP/SDP
*          Segments planars/radials:- ISGG LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*
*HTMLO     : Describe the Output of the routine
*
*
* Radial-based tracks:
*          IG tracks
*          Hits/drift sign         :- IRN/SDN IRP/SDP
*          Segments planars/radials:- ISGG LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*HTMLE     : Terminates the HTML documentation
      SUBROUTINE FREFIT
*     REFIT TRACK MODEL INCLUDING PLANARS
*     this routine updates the radial-based track parameters
*     using planar data. both phi-z and r-z are updated.
*     planars alone define r-z
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


*     Common for segment numbers...
      COMMON /FPSEGN/ ISG(3,MAXTRK)


*     COMMON FOR IOS PLANAR LINK
      COMMON/FTPS3/NS(3),SPAR(4,50,3),IPT(12,50,3),IPLA(12,50,3),
     1  SGN(12,50,3),YYS(12,50,3),YYF(12,50,3)

      COMMON/FTPPBK/NPP,IPP(36,100),CHPP(100),LP(3,100)
C     THE SIGN OF THE PLANAR DRIFT IS FILLED IN FTADD
      COMMON/FTPPBS/SPP(36,100)
      COMMON/FPPFIT/PSSS(100),PISS(100),RSSS(100),RISS(100)
      COMMON/FPLNK/KTIP(3,50),LPP(3,100)
C     COMMON FOR RADIALS ASSOCIATED WITH PLANAR TRACKS
      COMMON/FTRRBK/IRR(36,MAXTRK),SRR(36,MAXTRK),LRR(3,MAXTRK)
C     PLANAR SEGMENTS ASSOCIATED  WITH RADIALS
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      COMMON /FLINK3/LNK3(MAXTRK,3)

*     Local arrays...
      DIMENSION XX(100),YY(100),WP(100)
      PARAMETER(PI2=6.283185307)
      if(ig.eq.0)return
      DO 100 I=1,ig
      iF((isgg(1,i)+isgg(2,i)+isgg(3,i)).ne.0)then
c     at least one planar: - fit r-z
      IC=0
      DO 20 ISM=1,3
      IPLAN=isgg(ISM,I)
      I1=(ISM-1)*12+1
      I2=ISM*12
C     PLANARS
      IF(IPLAN.NE.0)THEN
      DO 21 IP=I1,I2
      Z1=ZPP(IP)
      XF=XYDXY(1,IPLAN,ISM)/10.+Z1*XYDXY(3,IPLAN,ISM)
      YF=XYDXY(2,IPLAN,ISM)/10.+Z1*XYDXY(4,IPLAN,ISM)
      IC=IC+1
      XX(IC)=Z1
      YY(IC)=sqrt(xf**2+yf**2)
      WP(IC)=1.
 21   CONTINUE
      ENDIF
 20   continue
c     fit r-z defined by planars
      CALL FTLFTW(XX,YY,WP,IC,0,2,RS,RI,D1,D2,D3,D4)
c     replace radial-defined r-z by planar-defined r-z
      rpsing(i)=rs
      zig(i)=ri
      endif
      IC=0
      DO 200 ISM=1,3
      IPLAN=isgg(ISM,I)
      I1=(ISM-1)*12+1
      I2=ISM*12
C     PLANARS
      IF(IPLAN.NE.0)THEN
      DO 210 IP=I1,I2
      Z1=ZPP(IP)
      XF=XYDXY(1,IPLAN,ISM)/10.+Z1*XYDXY(3,IPLAN,ISM)
      YF=XYDXY(2,IPLAN,ISM)/10.+Z1*XYDXY(4,IPLAN,ISM)
      IC=IC+1
      XX(IC)=Z1
      YY(IC)=ATAN2(YF,XF)
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
      WP(IC)=1./(0.1/SQRT(XF**2+YF**2))
 210  CONTINUE
      ENDIF
C     RADIALS
      DO 220 IP=I1,I2
      Z1=ZP(IP)
C     RADIUS DEFINED BY  radials
      RR=rpsing(I)*z1+zig(I)
      J=irn(IP,I)
      IF(J.EQ.0)GOTO220
      IC=IC+1
      PHI=ATAN((DRI(J,IP)*sdn(IP,I)+DWS(J,IP))/RR) +WW(J,IP)
      IF(PHI.LT.0.0)PHI=PHI+PI2
      XX(IC)=Z1
      YY(IC)=PHI
      WP(IC)=1./(0.1/RR)
 220  CONTINUE
 200  CONTINUE
      IF(IC.GT.1)THEN
      DO 250 JJ=2,IC
      DP=YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.0)THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 250  CONTINUE
      ENDIF
C     REFIT PHI-Z INCLUDING planars
C     WRITE(*,*)I,phzg(I),rpcosg(I)
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
      phzg(I)=PI
      rpcosg(I)=PS
C     WRITE(*,*)I,phzg(I),rpcosg(I)
 100  CONTINUE
      RETURN
      END

*CMZU:  8.06/00 04/11/96  12.31.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.42  by  Girish D. Patel
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Interpolate a point on a parabola
*
*HTMLI     : Describe the Input variables to the routine
*
*          Three points on parabola (x,z)
*
*HTMLO     : Describe the Output of the routine
*
*          Value of function is x for given z
*
*HTMLE     : Terminates the HTML documentation
*
      FUNCTION FPARAB(Z,X1,X2,X3,Z1,Z2,Z3)
C     CALCULATE X FOR Z ON PARABOLA THRU X1,X2,X3,Z1,Z2,Z3
      X=(Z-Z2)*(Z-Z3)/((Z1-Z2)*(Z1-Z3))*X1
      X=X+(Z-Z1)*(Z-Z3)/((Z2-Z1)*(Z2-Z3))*X2
      X=X+(Z-Z1)*(Z-Z2)/((Z3-Z1)*(Z3-Z2))*X3
      FPARAB=X
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  3.05/04 14/08/92  17.06.57  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Use radial and planar points to make
*          least squares fits in phi-z, r-z.
*          Calculate chi**2 of fits.
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial-based tracks:
*          Hits/drift sign         :- IRN/SDN IRP/SDP
*
*
*HTMLO     : Describe the Output of the routine
*
*
*          Parameters(phi',phi0)   :- RPCOS,phz
*          Parameters(R',R0)       :- THET,RZII
*          Errors in above parameters
*          Chi**2 radius , drift (CHR,CHISQ)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTFHPL(NPLA,IPA,SD,IPP,SDP,
     1    RPCOS, PHZ, DRPCOS, DPHZ, COVP,
     1    THET,  RZII,DTHET,  DRZI, COVR, CH, CHR, CHISQ, NDF)
*
*     Calling sequence changed. Error in R-z intercept put out
*     Unused arguments removed. Overall 'Chisq' added.
*
C     LEAST SQUARES FIT IN R-Z, PHI-Z  HELIX FRAME
C     UPDATED FROM FT205PP  3/12/91
C     INCLUDES PLANARS IN R-Z FIT
C     INCLUDES PLANARS IN PHI-Z FIT - REMOVED
C     AUTHOR   I.O.SKILLICORN
C     SET FOR FAST FILTER
C     STR LINE FIT IN R-Z
C     STR LINE FIT IN PHI-Z
C
C     VERTEX CORRECTED - FIT IN HELIX COORDS TO ALLOW FOR AN OFFSET
C                        VERTEX XVV,YVV
C
C    CORRECTED FOR OFFSET RADIALS
*
C     *************************************************************
C     REJECT R-Z FITS WITH UNREASONABLE INTERCEPT    SEE ZCUT
C     DISABLED 6/6/90
C     ******************************************************
C     FOR THREE MODULE FIT ONLY   ABS(ZINT) GT ZCUT
C     CORRECTED TO AVOID DIVIDE CHECK  11/6/90
C     VARIABLE ANGLE PLANARS  1/11/90
*
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRWERR.
      COMMON /WERR/ERRVL,ERRV,ERRP,ERRRX
*KEND.
      COMMON/FVFLAG/IVERTX
      COMMON/CORRXY/CX1,CX2,CX3,CY1,CY2,CY3

      DIMENSION XX(80),YY(80),WP(80)
      DIMENSION IPA(36),SD(36),IPP(36),SDP(36),CB(36)
      DIMENSION IPAA(36),IPZZ(36),CHHH(36) ,CRRR(36)
*
*
C     TO USE Z-VERTEX  IVERTX=1
C
C     NOTE THAT XV,YV MUST ALWAYS BE USED TO GET CORRECT HELIX FRAME -
C     NOMINAL BEAM POSITION WOULD BE USED IN PRACTISE .
*
C     Z-VERTEX NEED NOT BE USED . IT'S USE RESULTS IN A BETTER DEFINITIO
C     OF THE R-Z SLOPE - FEWER PATREC  ERRORS - BETTER D(1/P)
C     USE PLANARS IN FINAL PHI-Z FIT TO IMPROVE R   : IPL=1
      IPL=1
      IVERTX=0
*
C     WRITE(*,*)' FTFHPL ERRORS ',ERRVL,ERRV,ERRP,ERRRX
      PI2=6.2831853
C     Z INTERCEPT CUT *******************
      ZCUT=1000.
C     ***********************************
C      TO CALCULATE R  USE:
C      R=RD*Z +RO
*
C     TO CALCULATE PHI USE:
C     PHI=Z*RPCOS+PHZ
*
*
      NDF = 0
      CHISQ = 0.
*
C     FIT R-Z    IN HELIX COORDS - NO VERTEX CONSTRAINT
*
      II=0
C*********************************************************
C     ADD IN VERTEX
      IF(IVERTX.EQ.1)THEN
      II=1
      XX(II)=ZV
      YY(II)=0.
      WP(II)=1./0.02
      J=0
C      PRINT1003,II,J,XX(II),YY(II),WP(II)
      ENDIF
C*********************************************************
*
      DO 20 K=1,NPLA
C     J IS POINT NO.     K=PLANE NO.
C     RADIALS
      J=IPA(K)
      IF(J.EQ.0)GOTO120
      IF(DRI(J,K).GT.900.)GOTO120
************************************************************************
*     CORRECT FOR ERRORS IN POSITION OF RADIAL HERE
************************************************************************
      IF(K.GE.1.AND.K.LE.12) THEN
      CX=CX1
      CY=CY1
      ENDIF
      IF(K.GE.13.AND.K.LE.24) THEN
      CX=CX2
      CY=CY2
      ENDIF
      IF(K.GE.25.AND.K.LE.36) THEN
      CX=CX3
      CY=CY3
      ENDIF
*
*
      II=II+1
C     LAB PHI
      PHILL=ATAN((DRI(J,K)*SD(K)+DWS(J,K))/RM(J,K))+WW(J,K)
      IF(PHILL.LT.0.0)PHILL=PHILL+PI2
C     LAB R
      RR=SQRT(RM(J,K)**2+(DRI(J,K)*SD(K)+DWS(J,K))**2)
C     CORRECT FOR  DISPLACEMENT OF RADIAL
      X=RR*COS(PHILL)-CX
      Y=RR*SIN(PHILL)-CY
C     HELIX R
      XH=X-XVV
      YH=Y-YVV
      RRH=SQRT(XH**2+YH**2)
      YY(II)=RRH
      XX(II)=ZP(K)
      WP(II)=1.
*---------------------------------------------
C      PRINT1003,II,J,XX(II),YY(II),WP(II)
*---------------------------------------------
 120  CONTINUE
      IF(IPL.EQ.0)GOTO20
C     PLANARS
      J=IPP(K)
      IF(J.EQ.0)GOTO20
      IF(DRIW(J,K).EQ.900.)GOTO20
      PHI= RPCOS*ZPP(K)+ PHZ
*      AL=ATAN2(S(K),C(K))
C     1/11/90    VARIABLE ANGLE PLANARS
      AL=WWP(J,K)
      TH=PHI-AL
      AA=ABS(SIN(TH))
C     TO AVOID DIV. BY 0
      IF(AA.LT.0.1)GOTO20
      II=II+1
      WWW=DRIW(J,K)*SDP(K)+DW(J,K)
      WWW=WWW-YVV*C(K)+XVV*S(K)
      RR=ABS(WWW)/AA
      YY(II)=RR
      XX(II)=ZPP(K)
      WP(II)=AA/0.025
*---------------------------------------------
C      PRINT1003,II,J,XX(II),YY(II),WP(II)
 1003 FORMAT(' HELIX R',2I5,3F10.4)
*---------------------------------------------
 20   CONTINUE
*
      CALL FTLFTW(XX,YY,WP,II,0,2,RZS,RZII,ET,DRZS,DRZI,COVR)
C     RZS-SLOPE,RZII-INTERCEPT
C      WRITE(*,*)' RZS,RZII ',RZS,RZII
C      FOR STOREAGE OF HELIX R
       THET=RZS
       DTHET=DRZS
*
C     CALCULATE CHI**2 OF FIT TO STR LINE IN R  -Z
      CHIL=0.
      DO 131 K=1,II
      YYM=YY(K)
      YYP=XX(K)*RZS+RZII
      CHIL=CHIL+(YYP-YYM)**2*WP(K)**2
 131  CONTINUE
      NDF   = NDF + II
      IF(II.NE.2) THEN
         CHR=CHIL/FLOAT(II-2)
*        For an overall 'Chi-squared'...
         CHISQ = CHISQ + CHIL
      ELSE
         CHR=1000.
         CHISQ = CHISQ + 1000.
      ENDIF
*
*
*
*
*
C     CALCULATE PHI BASED ON FITTED R  - IN LAB
C      MAKE A FIT TO  HELIX PHI
      II=0
      DO30 K=1,NPLA
C     J IS POINT NO.     K=PLANE NO.
      J=IPA(K)
      IF(J.EQ.0)GOTO 30
      IF(DRI(J,K).GT.900.)GOTO 30
      II=II+1
C     WRITE(*,*)' FTFHPL J,K, DR RM ',II,J,K,DRI(J,K),RM(J,K)
      XX(II)=ZP(K)
*
*
************************************************************************
*     CORRECT FOR ERRORS IN POSITION OF RADIAL HERE
************************************************************************
      IF(K.GE.1.AND.K.LE.12) THEN
      CX=CX1
      CY=CY1
      ENDIF
      IF(K.GE.13.AND.K.LE.24) THEN
      CX=CX2
      CY=CY2
      ENDIF
      IF(K.GE.25.AND.K.LE.36) THEN
      CX=CX3
      CY=CY3
      ENDIF
C***********************************************************************
*
C     USE  HELIX R - THIS INCLUDES PLANARS IF IPL=1
C     CONVERT HELIX R TO LAB R
      RRH=RZS*ZP(K)+RZII
      PHI=RPCOS*ZP(K)+PHZ
      XL=RRH*COS(PHI)+XVV+CX
      YL=RRH*SIN(PHI)+YVV+CY
      RR=SQRT(XL**2+YL**2)
C***********************************************************************
*
C     PHI WITH FITTED R  - IN LAB - TO GET MORE ACCURACY IN PHI
C     ..................................................................
*
      IF(ABS((DRI(J,K)*SD(K)+DWS(J,K))/RR).GT.1.0)THEN
C     WRITE(*,*)' FHLX ERROR',(DRI(J,K)*SD(K)+WS(K)),RR
      YY(II)=0.
      II=II-1
      GOTO30
      ENDIF
C     LAB PHI WITH FITTED R
      PHI=ASIN((DRI(J,K)*SD(K)+DWS(J,K))/RR)+WW(J,K)
      IF(PHI.LT.0.0)PHI=PHI+PI2
C     TO HELIX COORDS
************************************************************************
*     CORRECT FOR ERRORS IN POSITION OF RADIAL HERE
*     EFFECTIVELY XVV, YVV ARE CHANGED
************************************************************************
*
      XT=RR*COS(PHI)-XVV -CX
      YT=RR*SIN(PHI)-YVV -CY
C     NEXT LINE IS PHI HELIX  CALCULATED WITH FITTED R
      YY(II)=ATAN2(YT,XT)
      IF(YY(II).LT.0.0)YY(II)=YY(II)+PI2
C     RECALCULATE  CORRECTIONS -  USE RESULT OF PREVIOUS FIT
      PHI=ZP(K)*RPCOS+PHZ
      CORR= 00.
      IF(ABS(PHI-YY(II)).LT.0.020)CORR=0.
      IF(ABS(PHI+PI2-YY(II)).LT.0.020)CORR=-PI2
      IF(ABS(PHI-PI2-YY(II)).LT.0.020)CORR=+PI2
      YY(II)=YY(II)+CORR
*
C     ------------------------------------------------------------
C     THE  ERROR SEEMS TO BE CALCULATED CORRECTLY ( ON AVERAGE )
C     FOR 3 AND 2 MODULES EVENTS WITH THE FOLLOWING WEIGHT
C     ( IT MUST OVERESTIMATE THE ERROR DUE TO DR HOWEVER)
      WWPP=SQRT((ERRP/RR)**2+
     1((DRI(J,K)*SD(K)+DWS(J,K))/RR**2)**2)
      WP(II)=1./WWPP
*------------------------------------------
C      PRINT1002,J,II,XX(II),YY(II),WP(II),RR
 1002 FORMAT(' PHI   ',2I5,5F10.4)
*------------------------------------------
 30   CONTINUE
*******
      IF(II .GT. 1)THEN
*     Try to repair Phi-discontinuites...
      DO 32 JJ=2,II
       DP =     YY(JJ)-YY(JJ-1)
       IF(DP .GT. 0) THEN
        IF(ABS(DP) .GT. ABS(DP-PI2))YY(JJ) = YY(JJ) - PI2
       ELSE
        IF(ABS(DP) .GT. ABS(DP+PI2))YY(JJ) = YY(JJ) + PI2
       ENDIF
 32   CONTINUE
      ENDIF
*******
C
      CALL FTLFTW(XX,YY,WP,II,0,2,RPCOS,PHZ,EL,DRPCOS,DPHZ,COVP)
C     RPCOS-SLOPE PHI-Z,PHZ-INTERCEPT  PHI AXIS
      IF(RPCOS.EQ.0.0.AND.PHZ.EQ.0.0)THEN
       CH=1000.
       CHISQ = CHISQ + 1000.
       NDF = NDF + II
       GO TO 500
      ENDIF
*
*------------------------------------------
CDEB  PRINT5000,RPCOS,PHZ,DRPCOS,DPHZ
 5000 FORMAT(' PHI-Z RPCOS,PHZ,EPC,EP ',4F10.5)
*------------------------------------------
*
C     GUARD AGAINST RPCOS<< ERROR
****  IF(ABS(RPCOS).LT.DRPCOS/10.)RPCOS=DRPCOS/10.
C
C
C     CALCULATE CHI**2 OF FIT TO STR LINE IN PHI-Z
      CHIL=0.
      DO 31 K=1,II
      YYM=YY(K)
      IF(YYM.EQ.0.)GOTO31
      YYP=XX(K)*RPCOS+PHZ
      CHIL=CHIL+(YYP-YYM)**2*WP(K)**2
 31   CONTINUE

      NDF   = NDF + II
      IF(II.GT.2)THEN
         CH=CHIL/FLOAT(II-2)
*        For an overall 'Chi-squared'...
         CHISQ = CHISQ + CHIL
      ELSE
         CH = 1000.
         CHISQ = CHISQ + 1000.
      ENDIF

 500  CONTINUE
      IF (NDF .NE. 4) THEN
         CHISQ = CHISQ / FLOAT(NDF-4)
      ENDIF

C     WRITE(*,*)' RPCOS,PHZ,CH ',RPCOS,PHZ,CH
*------------------------------------------
C     PRINT 1000,PP,DL,DM,DN,DRPCOS*100.,PCOS,PSIN,PHZ
 1000 FORMAT('FHLX,P,LMN,D(1/PCOST),PC,PS,PHZ',F8.2,3F8.4,2F10.2,2F8.3)
*------------------------------------------
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  7.02/11 12/10/95  13.11.19  by  Stephen Burke
*CMZU:  3.03/03 15/05/92  19.18.43  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Fits radial track segments to straight
*          lines in phi-z,r-z.
*          Checks for wrong drift-sign segments.
*          Joins segments that are split accross
*          the cathode plane.
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*
*
*HTMLO     : Describe the Output of the routine
*
*
* Radial track segments:
*          NTRAKS segments/module
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*          Chi**2 marks bad segs   :- CHSQ
*
*HTMLE     : Terminates the HTML documentation
*
*
      SUBROUTINE FTFIT
c     ftfit4.f on graphics
c     ftfit6.f on h1rec
c     see later version ftfit7.f for isolation flags
C     fit LINE SEGMENTS in phi-z,r-z
C     use mean r in phi calculation
c     modify to compare and join segments if
c     consistent in phi/r at centre of radial chamber.
c     objective: join segments that cross cell boundary.
c
c     add section to check if a better line segment can be obtained by
c     reversing drift sign and rejecting the worst point.
c
C     AUTHOR   I.O.SKILLICORN
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEND.
*
      DIMENSION IPA(36),SD(36)
      dimension xx(12),yy(12),zz(12),xxx(12),zzz(12)
      data istart/0/
*     segments to be joined agree in r within rcut
*     agree in phi within pcut / r ie within 0.5 cm
*     in drift. segments have no more than one z-plane in common
      if(istart.eq.0)then
      istart=1
      call stext(3040,4,'ftfit rms original')
      call bhs(3040,0,50,0.,0.1)
      call stext(3041,4,'ftfit rms point rejected')
      call bhs(3041,0,50,0.,0.1)
      call stext(3042,4,'ftfit rms reversed sign')
      call bhs(3042,0,50,0.,0.2)
      call stext(3043,4,'ftfit rms reversed sign pt rej')
      call bhs(3043,0,50,0.,0.2)
      call stext(3044,4,'ftfit rms rev. sign pt rej sel')
      call bhs(3044,0,50,0.,0.1)
      call stext(3045,4,'ftfit res max original ')
      call bhs(3045,0,50,0.,0.2)
      call stext(3046,4,'ftfit res max reversed sel')
      call bhs(3046,0,50,0.,0.2)
      call stext(3047,4,'ftfit delta phi*r - proj')
      call bhs(3047,0,50,-5.00,5.00)
      call stext(3048,4,'ftfit delta phi - proj')
      call bhs(3048,0,50,-0.25,0.25)
      endif
      rcut=20.
      pcut=1.0
c     write(*,*)' ftfit1 entered '
*
c     check for wrong drift-sign line segments
      do 100 ism=1,3
      do 110 j=1,ntraks(ism)
      ll=0
      nww=0
      do 120 k=1,12
      i=irpt(k,j,ism)
      if(i.eq.0)goto120
      ip=k+(ism-1)*12
      if(nww.eq.0)nww=nw(i,ip)
      if(nww.ne.nw(i,ip))goto110
c     same wire
      ll=ll+1
      xx(ll)=zp(ip)
      yy(ll)= sdrft(k,j,ism)*dri(i,ip)+dws(i,ip)
      zz(ll)=-sdrft(k,j,ism)*dri(i,ip)+dws(i,ip)
 120  continue
      if(ll.le.5)goto110
      call ftlft(xx,yy,ll,0,at,bt,ee)
      ee=sqrt(abs(ee))
      call shs(3040,0,ee)
c     if rms is good do not check
*     if(ee.lt.0.04)goto110
c
c     find worst point
c     remove and refit
c     this makes posible a direct comparison with
c     the reversed sign remove and refit
      dmax=0.
      do 130 l=1,ll
      diff=abs(yy(l)-(at*xx(l)+bt))
      if(diff.gt.dmax)then
      dmax=diff
      lmax=l
      endif
 130  continue
      call shs(3045,0,dmax)
      lll=0
      do 135 l=1,ll
      if(l.eq.lmax)goto135
      lll=lll+1
      xxx(lll)=xx(l)
      zzz(lll)=yy(l)
 135  continue
      call ftlft(xxx,zzz,lll,0,at1,bt1,ee1)
      ee1=sqrt(abs(ee1))
      call shs(3041,0,ee1)
c     if rms is good do not check
      if(ee1.lt.0.03)goto110
c
c     fit oposite sign
      call ftlft(xx,zz,ll,0,at2,bt2,ee2)
      ee2=sqrt(abs(ee2))
      call shs(3042,0,ee2)
c     find worst point
      dmax=0.
      do 140 l=1,ll
      diff=abs(zz(l)-(at2*xx(l)+bt2))
      if(diff.gt.dmax)then
      dmax=diff
      lmax=l
      endif
 140  continue
      lll=0
      do 150 l=1,ll
      if(l.eq.lmax)goto150
      lll=lll+1
      xxx(lll)=xx(l)
      zzz(lll)=zz(l)
 150  continue
      call ftlft(xxx,zzz,lll,0,at3,bt3,ee3)
c     drift sign may not be determined after point rejection
c     so add 0.0001 to counter rounding errors
      ee3=sqrt(abs(ee3)) + 0.0001
      call shs(3043,0,ee3)
      if(ee3.lt.ee1)then
      call shs(3044,0,ee3)
      call shs(3046,0,dmax)
c     write(*,*)' ftfit4: k j ism res',lmax,j,ism,ee,ee1,ee2
c    1 ,ee3
c     rejection of one point gives
c     improved residuals with reversed drift sign.
c     reset drift sign, remove this point
      ll=0
      do 160 k=1,12
      i=irpt(k,j,ism)
      if(i.eq.0)goto160
      ll=ll+1
      if(ll.eq.lmax)then
      irpt(k,j,ism)=0
      endif
      sdrft(k,j,ism)=-sdrft(k,j,ism)
 160  continue
      endif
 110  continue
 100  continue
c
c
c     end of section for correcting drift sign
c
c

      DO 1001 I=1,3
      FN=NTRAKS(I)
      DO 1002 J=1,NTRAKS(I)
      DO 1005 II=1,36
      SD(II)=0.
 1005 IPA(II)=0
      IF (I.EQ.1) THEN
      IFP=1
      ILP=12
      ELSE IF (I.EQ.2) THEN
      IFP=13
      ILP=24
      ELSE
      IFP=25
      ILP=36
      ENDIF
      IC=1
      DO 1003 K=IFP,ILP
      SD(K)=SDRFT(IC,J,I)
      IPA(K)=IRPT(IC,J,I)
      IC=IC+1
 1003 CONTINUE
*
*------------------------------------------
C      PRINT5000,I,J,IPA
 5000 FORMAT(2I5,3X,36I2 )
CDEB      PRINT 5001,SD
 5001 FORMAT(36F3.0)
*------------------------------------------
*
      ZVV=ZV
      NPLA=36
      C1=0.
      C2=0.
      C3=0.
      CALL FTFHQQ(NPLA,IPA,SD,ZVV,C1,C2,C3,
     1            PCOS,PSIN,PHZ,DPCOS,DPSIN,DPHZ,RI,CH,IT)
C     WRITE(*,*)PCOS,PSIN,PHZ,DPCOS,RI,R1
      PCOSL(J,I)=PCOS
      PSINL(J,I)=PSIN
      PHZL(J,I)=PHZ
      DPCOSL(J,I)=DPCOS
      DPSINL(J,I)=DPSIN
      DPHZL(J,I)=DPHZ
      RZI(J,I)=RI
C     STORE MEAN R OF LINE SEGMENT
      RFIT(J,I)=R1
      CHSQ(J,I)=CH
 1002 CONTINUE
      if(ntraks(i).le.1)goto1001
c     compare line segments and join if compatible
      if(i.eq.1)im=6
      if(i.eq.2)im=18
      if(i.eq.3)im=30
c     write(*,*)' module ,# segs',i,ntraks(i)
      do 10 j=1,ntraks(i)-1
      if(chsq(j,i).gt.1000.)goto10
      phi1=zp(im)*pcosl(j,i)+phzl(j,i)
      if(phi1.gt.6.28318)phi1=phi1-6.28318
      do 20 k=j+1,ntraks(i)
      if(chsq(k,i).gt.1000.)goto20
c     write(*,*)' rfit',rfit(j,i),rfit(k,i),k,j
      if(abs(rfit(j,i)-rfit(k,i)).gt.rcut)goto20
      phi2=zp(im)*pcosl(k,i)+phzl(k,i)
      if(phi2.gt.6.28318)phi2=phi2-6.28318
      rr=0.5*(rfit(j,i)+rfit(k,i))
      dphi12=amod((phi1-phi2),6.28318)
c     write(*,*)' phi ',phi1,phi2,dphi12,pcut/rr
      if(abs(dphi12).gt.5.*pcut/rr)goto20
c     similar r and phi
      ifw1=0
      ifw2=0
      do 30 l=1,12
      if(irpt(l,j,i).ne.0.and.ifw1.eq.0)ifw1=l
      if(irpt(l,k,i).ne.0.and.ifw2.eq.0)ifw2=l
      if(irpt(l,j,i).ne.0)ilw1=l
      if(irpt(l,k,i).ne.0)ilw2=l
 30   continue
c     write(*,*)' wires f,l 1,2',ifw1,ilw1,ifw2,ilw2
      jj=irpt(ifw1,j,i)
      kk=irpt(ifw2,k,i)
      jp=ifw1+(i-1)*12
      kp=ifw2+(i-1)*12
c     check adjacent wedges
c     write(*,*)' nw ',nw(jj,jp),nw(kk,kp)
      if(nw(jj,jp).eq.1.and.nw(kk,kp).eq.48)goto60
      if(nw(kk,kp).eq.1.and.nw(jj,jp).eq.48)goto60
      if(iabs(nw(jj,jp)-nw(kk,kp)).ne.1)goto20
 60   continue
      if(ilw1.le.ifw2.or.ilw2.le.ifw1)then
c     overlap by at most one hit
c     histogram here
      call shs(3047,0,dphi12*rr)
      call shs(3048,0,dphi12)
      if(abs(dphi12).gt.pcut/rr)goto20
      do40 ii=1,36
      sd(ii)=0.
 40   ipa(ii)=0
c     write(*,*)' JOIN '
c     print 3001,i,j,(irpt(ll,j,i),ll=1,12),chsq(j,i)
c     print 3001,i,k,(irpt(ll,k,i),ll=1,12),chsq(k,i)
 3001 format(' trk, irpt ',2i3,4x,12i2,f5.0)
      ic=1
      do 41 ii=12*(i-1)+1,12*i
      if(irpt(ic,j,i).ne.0)sd(ii)=sdrft(ic,j,i)
      if(irpt(ic,j,i).ne.0)ipa(ii)=irpt(ic,j,i)
      if(irpt(ic,k,i).ne.0)sd(ii)=sdrft(ic,k,i)
      if(irpt(ic,k,i).ne.0)ipa(ii)=irpt(ic,k,i)
      ic=ic+1
 41   continue
c     write(*,*)' module ',i
c     print 3000,ipa
 3000 format(' ipa ',36i2)
      ZVV=ZV
      NPLA=36
      C1=0.
      C2=0.
      C3=0.
      CALL FTFHQQ(NPLA,IPA,SD,ZVV,C1,C2,C3,
     1            PCOS,PSIN,PHZ,DPCOS,DPSIN,DPHZ,RI,CH,IT)
C     WRITE(*,*)PCOS,PSIN,PHZ,DPCOS,RI,R1
      PCOSL(J,I)=PCOS
      PSINL(J,I)=PSIN
      PHZL(J,I)=PHZ
      DPCOSL(J,I)=DPCOS
      DPSINL(J,I)=DPSIN
      DPHZL(J,I)=DPHZ
      RZI(J,I)=RI
C     STORE MEAN R OF LINE SEGMENT
      RFIT(J,I)=R1
      CHSQ(J,I)=CH
c     replace points
      do 42 l=1,12
      irpt(l,j,i) =ipa(l+12*(i-1))
      sdrft(l,j,i)=sd(l+12*(i-1))
      irpt(l,k,i)=0
 42   continue
c     remove joined line segment
      chsq(k,i)=5000.
c     print 3001,i,j,(irpt(ll,j,i),ll=1,12),chsq(j,i)
c     print 3001,i,k,(irpt(ll,k,i),ll=1,12),chsq(k,i)
      endif
 20   continue
 10   continue
 1001 CONTINUE
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  3.02/01 25/02/92  18.44.50  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Fit straight line.
*
*HTMLI     : Describe the Input variables to the routine
*
*          Coordinates.
*
*HTMLO     : Describe the Output of the routine
*
*          Slope,intercept of straight line.
*
*HTMLE     : Terminates the HTML documentation
*
*
*
*
      SUBROUTINE FTLFT(XS,YS,L,KEY,AS,BS,ES)

      DIMENSION XS(100),YS(100)
      DOUBLE PRECISION X(100), Y(100)
      DOUBLE PRECISION A, B, E
      DOUBLE PRECISION SUMX, SUMY, SUMXY, SUMXX, SUMYY, COUNT
      DOUBLE PRECISION XMED, YMED, SCARTX, SCARTY

      IF(L-2)25,1,1

   1  COUNT=0.0D0
      SUMX=0.0D0
      SUMY=0.0D0
      SUMXY=0.0D0
      SUMXX=0.0D0
      SUMYY=0.0D0
      DO10 J=1,L
      X(J) = DBLE(XS(J))
      Y(J) = DBLE(YS(J))
      IF(Y(J).EQ.0.0D0.AND.KEY.EQ.0)GOTO10
      SUMX=SUMX+X(J)
      SUMY=SUMY+Y(J)
      COUNT=COUNT+1.0D0
  10  CONTINUE
      IF(COUNT.LE.1.0D0)GOTO25
      YMED=SUMY/COUNT
      XMED=SUMX/COUNT
      DO 20 J=1,L
      IF(Y(J).EQ.0.0D0.AND.KEY.EQ.0)GOTO20
      SCARTX=X(J)-XMED
      SCARTY=Y(J)-YMED
      SUMXY=SUMXY+SCARTX*SCARTY
      SUMXX=SUMXX+SCARTX*SCARTX
      SUMYY=SUMYY+SCARTY*SCARTY
 20   CONTINUE
      IF(SUMXX.EQ.0.0D0)GOTO25
      A=SUMXY/SUMXX
      B=YMED-A*XMED
      IF(COUNT.LT.3.0D0)GOTO101
      E=(SUMYY-SUMXY*A)/(COUNT-2.0D0)
      GOTO100
 25   A=0.0D0
      B=0.0D0
 101  E=0.0D0
 100  CONTINUE
      AS = A
      BS = B
      ES = E
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZ :  3.01/10 25/02/92  10.46.33  by  Gregorio Bernardi
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Weighted least squares fit to straight line.
*
*HTMLI     : Describe the Input variables to the routine
*
*          Coordinates,weight.
*
*HTMLO     : Describe the Output of the routine
*
*          Slope, intercept.
*
*HTMLE     : Terminates the HTML documentation
*
*
*
*
      SUBROUTINE FTLFTW(XS,YS,WS,L,KEY,KK,AS,BS,ES,DAS,DBS,COVS)
C     MOD TO VECTORIZE
      DIMENSION XS(100),YS(100),WS(100)
      DOUBLE PRECISION X(100),Y(100),W(100)
      DOUBLE PRECISION W2, W2X, W2Y, W2XY, W2X2, W2Y2
      DOUBLE PRECISION A,B,D,E
      DOUBLE PRECISION DA, DB, COV

C     TO PERFORM A WEIGHTED STRAIGHT LINE FIT  Y=AX+B
C     CERN LIBRARY ROUTINE MOD TO INCLUDE FIT TO Y=AX
C     CALCULATE SUMS   WEIGHT =1./ERROR
      IF(L.LE.1)GOTO1
      W2=0.0D0
      W2X=0.0D0
      W2Y=0.0D0
      W2XY=0.0D0
      W2X2=0.0D0
      W2Y2=0.0D0
      ICNT=0
      DO 2 J=1,L
      W(J) = DBLE(WS(J))
      X(J) = DBLE(XS(J))
      Y(J) = DBLE(YS(J))
      W2=W2+W(J)*W(J)
      W2X=W2X+W(J)*W(J)*X(J)
      W2X2=W2X2+W(J)*W(J)*X(J)*X(J)
      W2XY=W2XY+W(J)*W(J)*X(J)*Y(J)
      W2Y=W2Y+W(J)*W(J)*Y(J)
      W2Y2=W2Y2+W(J)*W(J)*Y(J)*Y(J)
      ICNT=ICNT+1
 2    CONTINUE
C
C     FIT PARAMETERS
      IF(KK.EQ.2)THEN
      A=(W2XY-W2X*W2Y/W2)/(W2X2-W2X**2/W2)
      B=(W2Y-A*W2X)/W2
      D=W2X2*W2-W2X*W2X
C     ADDED 24/3/88
      IF(ABS(D).LT.1.0D-6)GOTO1
C
      COV=-W2X/D
      IF(ICNT.LE.2)GOTO3
      E=(W2Y2-W2Y**2/W2-(W2XY-W2X*W2Y/W2)**2/(W2X2-W2X**2/W2))
     1 /DFLOAT(ICNT-2)
      DA=DSQRT(W2/D)
      DB=DSQRT(W2X2/D)
      ELSE
      A=W2XY/W2X2
      DA=1./SQRT(W2X2)
      B=0.
      DB=0.
      E=(W2Y2-W2XY**2/W2X2)/FLOAT(ICNT-1)
      ENDIF
      GOTO4
C
C     INSUFFICIENT POINTS
 1    A=0.0D0
      B=0.0D0
      DA=0.0D0
      DB=0.0D0
 3    E=0.0D0
 4    CONTINUE
      AS = A
      BS = B
      ES = E
      DAS = DA
      DBS = DB
      COVS = COV
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  3.08/03 23/02/93  09.40.05  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Organise linking of radial line segments
*          to form radial-based tracks.
*
*HTMLI     : Describe the Input variables to the routine
*
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*
*HTMLO     : Describe the Output of the routine
*
*
* Radial-based tracks:
*          IG tracks
*          Segments                :- LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*HTMLE     : Terminates the HTML documentation
*
*
C new version imported from IOS fortran 6/6/91
*
      SUBROUTINE FTLINK
C     ORGANISE LINKING OF RADIAL MODULES
C     AUTHOR   I.O.SKILLICORN
C     21/5/91  REDUCE SIZE
*   SUNDRY ARRAY DIMENSIONS...
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEND.
*   VERTEX INFO...
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEND.
*
*
*     LOCAL ARRAYS...
      COMMON /FLINK3/LNK3(MAXTRK,3)
*************************************************************
C      COMMON/FTWSEG/NIG,NNPTS(MAXTRK),NIRADG(36,MAXTRK),
C     1SDRADN(36,MAXTRK)
*************************************************************
      DIMENSION ZI12(MAXTRK)
      DIMENSION ZI13(MAXTRK)
      DIMENSION ZI23(MAXTRK)
      DIMENSION ZI123(MAXTR3)
      DIMENSION TRI(MAXTRK),TPA(MAXTRK,3)
      DIMENSION TZA(MAXTRK,3),TCH(MAXTRK)
      DIMENSION CF(MAXTR3,3),IUSED(MAXTR3,3)
      DIMENSION INP(MAXTRK)
      DIMENSION RPC(MAXTRK),PH(MAXTRK),RPS(MAXTRK)
      DIMENSION NPTS(MAXTRK)
      DIMENSION LL12(MAXTRK,2),RPC12(MAXTRK),RPS12(MAXTRK)
      DIMENSION PH12(MAXTRK),CH12(MAXTRK)
C     DIMENSION IP12(36,MAXTRK),SD12(36,MAXTRK)
      DIMENSION LL13(MAXTRK,2),RPC13(MAXTRK)
      DIMENSION RPS13(MAXTRK),PH13(MAXTRK),CH13(MAXTRK)
C     DIMENSION IP13(36,MAXTRK),SD13(36,MAXTRK)
      DIMENSION LL23(MAXTRK,2),RPC23(MAXTRK)
      DIMENSION RPS23(MAXTRK),PH23(MAXTRK),CH23(MAXTRK)
C     DIMENSION IP23(36,MAXTRK),SD23(36,MAXTRK)
      DIMENSION LL123(MAXTR3,3),RPC123(MAXTR3)
      DIMENSION RPS123(MAXTR3),PH123(MAXTR3)
      DIMENSION CH123(MAXTR3)

      PI2=6.2831853
      IG=0
      N12=0
      N13=0
      N23=0
C     =1 FOR UNUSED SEGMENTS
      NUN=0
      DO 2010 I=1,MAXTR3
      DO 2010 J=1,3
      IUSED(I,J)=0
 2010 CONTINUE
      DO 2103 J=1,MAXTRK
      LNK3(J,1)=0
      LNK3(J,2)=0
      LNK3(J,3)=0
      GPA(J,1)=0.
      GZA(J,1)=0.
      NPTS(J)=0
C      NNPTS(J)=0
      DO 2102 I=1,36
      SDRADG(I,J)=0
      IRADG(I,J)=0
C      NIRADG(I,J)=0
 2102 CONTINUE
 2103 CONTINUE


C     JOIN  TRACK SEGMENTS
      CALL FTJN3(CF,IUSED,N123,LL123,RPC123,RPS123,PH123,
     1 CH123,            ZI123)

      CALL FTJN23(CF,IUSED,N23,LL23,RPC23,RPS23,PH23,
     1 CH23,          ZI23)
      CALL FTJN12(CF,IUSED,N12,LL12,RPC12,RPS12,PH12,
     1 CH12,          ZI12)
      CALL FTJN13(CF,IUSED,N13,LL13,RPC13,RPS13,PH13,
     1 CH13,          ZI13)



C     FILL BANK WITH TRACKS
      IG=0
      IF(N123.NE.0)THEN
      DO 100 I=1,N123
      IF(LL123(I,1).EQ.0)GOTO100
      IG=IG+1
      IF(IG.GT.MAXTRK) IG=MAXTRK
      RPCOSG(IG)=RPC123(I)
      RPSING(IG)=RPS123(I)
      PHZG(IG)=PH123(I)
      ZIG(IG)=ZI123(I)
      CHG(IG)=CH123(I)
      GZA(IG,1)=ZZA(I,1)
      GPA(IG,1)=PPA(I,1)
      GZA(IG,2)=ZZA(I,2)
      GPA(IG,2)=PPA(I,2)
      GZA(IG,3)=ZZA(I,3)
      GPA(IG,3)=PPA(I,3)
C     STORE LINK POINTERS
      LNK3(IG,1)=LL123(I,1)
      LNK3(IG,2)=LL123(I,2)
      LNK3(IG,3)=LL123(I,3)
C      WRITE(*,*)' 123 ',IG,RPCOSG(IG),RPSING(IG)
C     DO105 N=1,36
C     IF(IP123(N,I).GT.0)NPTS(IG)=NPTS(IG)+1
C     IRADG(N,IG)=IP123(N,I)
C     SDRADG(N,IG)=SD123(N,I)
C105  CONTINUE
 100  CONTINUE
      ENDIF

      IF(N23.NE.0)THEN
      DO 110 I=1,N23
      IF(LL23(I,1).EQ.0)GOTO110
      IG=IG+1
      IF(IG.GT.MAXTRK)IG=MAXTRK
      RPCOSG(IG)=RPC23(I)
      RPSING(IG)=RPS23(I)
      PHZG(IG)=PH23(I)
      ZIG(IG)=ZI23(I)
      CHG(IG)=CH23(I)
C     STORE LINK POINTERS
      LNK3(IG,1)=0
      LNK3(IG,2)=LL23(I,1)
      LNK3(IG,3)=LL23(I,2)
C      WRITE(*,*)'  23 ',IG,RPCOSG(IG),RPSING(IG)
C     DO115 N=1,36
C     IRADG(N,IG)=IP23(N,I)
C     IF(IP23(N,I).GT.0)NPTS(IG)=NPTS(IG)+1
C     SDRADG(N,IG)=SD23(N,I)
C115  CONTINUE
 110  CONTINUE
      ENDIF

      IF(N12.NE.0)THEN
      DO 120 I=1,N12
      IF(LL12(I,1).EQ.0)GOTO120
      IG=IG+1
      IF(IG.GT.MAXTRK)IG=MAXTRK
      RPCOSG(IG)=RPC12(I)
      RPSING(IG)=RPS12(I)
      PHZG(IG)=PH12(I)
      ZIG(IG)=ZI12(I)
      CHG(IG)=CH12(I)
C     STORE LINK POINTERS
      LNK3(IG,1)=LL12(I,1)
      LNK3(IG,2)=LL12(I,2)
      LNK3(IG,3)=0
C      WRITE(*,*)' 12  ',IG,RPCOSG(IG),RPSING(IG)
C     DO125 N=1,36
C     IRADG(N,IG)=IP12(N,I)
C     IF(IP12(N,I).GT.0)NPTS(IG)=NPTS(IG)+1
C     SDRADG(N,IG)=SD12(N,I)
C125  CONTINUE
 120  CONTINUE
      ENDIF

      IF(N13.NE.0)THEN
      DO 130 I=1,N13
      IF(LL13(I,1).EQ.0)GOTO130
      IG=IG+1
      IF(IG.GT.MAXTRK)IG=MAXTRK
      RPCOSG(IG)=RPC13(I)
      RPSING(IG)=RPS13(I)
      PHZG(IG)=PH13(I)
      ZIG(IG)=ZI13(I)
      CHG(IG)=CH13(I)
C     STORE LINK POINTERS
      LNK3(IG,1)=LL13(I,1)
      LNK3(IG,2)=0
      LNK3(IG,3)=LL13(I,2)
C      WRITE(*,*)' 1 3 ',IG,RPCOSG(IG),RPSING(IG)
C     DO135 N=1,36
C     IRADG(N,IG)=IP13(N,I)
C     IF(IP13(N,I).GT.0)NPTS(IG)=NPTS(IG)+1
C     SDRADG(N,IG)=SD13(N,I)
C135  CONTINUE
 130  CONTINUE
      ENDIF
      IF(NUN.NE.0)THEN
C     PICK UP UNUSED TRACK SEGMENTS
      NIG=0
      DO 200 II=1,3
      NT=NTRAKS(II)
      IF(NT.EQ.0)GOTO200
      IF(II.EQ.1)NS=0
      IF(II.EQ.2)NS=12
      IF(II.EQ.3)NS=24
C      DO 210 I=1,NT
C      IF(IUSED(I,II).EQ.1)GOTO210
C      NIG=NIG+1
C     IG=IG+1
C**********************************************************************
C     IF(NIG.GT.MAXTRK)THEN
C     NIG=MAXTRK
C     NNPTS(NIG)=0
C     ENDIF
C     IF(IG.GT.MAXTRK)THEN
C     IG=MAXTRK
C     NNPTS(IG)=0
C     ENDIF
C**************************************************12/10/87************
C      RPCOSG(IG)=PCOSL(I,II)
C      RPSING(IG)=PSINL(I,II)
C      PHZG(IG)=PHZL(I,II)
C      ZIG(IG)=RZI(I,II)
C     DO 215 N=1,12
C     NN=NS+N
C     NIRADG(NN,NIG)=IRPT(N,I,II)
C     IF(IRPT(N,I,II).GT.0)NNPTS(NIG)=NNPTS(NIG)+1
C     SDRADN(NN,NIG)=SDRFT(N,I,II)
C215  CONTINUE
C 210  CONTINUE
 200  CONTINUE
      ENDIF

*-----Debug--------------------------------------
*     WRITE(6,'('' ***FTLINK>> '',I5, ''  tracks found'')')IG
*     DO 170 I=1,IG
*         PRINT 2330,I,(IRADG(J,I),J=1,36)
*2330 FORMAT (' LINK ',1X,I3,1X,12I2,1X,12I2,1X,12I2,F6.2)
*170  CONTINUE
*GB   DO 175 I=1,NIG
*         PRINT 2330,I,(NIRADG(J,I),J=1,36)
*175  CONTINUE
*------------------------------------------------

      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.06  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  5.03/00 24/02/94  16.14.14  by  Stephen J. Maxfield
*CMZU:  4.00/08 15/10/93  15.16.47  by  Stephen J. Maxfield
*CMZU:  3.06/06 26/10/92  15.06.41  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield  / I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTREZ(KTRK)
*
*     Calculate residuals of Radial hits to PATREC tracks
*     and make lookagrams of them.
*
*D     Remove vertex shifts in segment residuals.
*
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEND.
*
      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)
      COMMON/CORRXY/CX1,CX2,CX3,CY1,CY2,CY3
      DIMENSION IRT(36),REZ(36),DRFT(12),ZEDW(12)
      DIMENSION RESID(12), RESR(12), RAD(12), DRFE(12), RMEAS(12)
      PARAMETER(PHII=0.130899693)
      PARAMETER(HPHII=PHII/2.)
      PARAMETER(PI2=6.2831853)

      IF(IREZ.GE.2) THEN

      DO 1 I = 1, 36

*     Offsets for radials...
      IF(I.GE.1.AND.I.LE.12) THEN
        CX=CX1
        CY=CY1
      ENDIF
      IF(I.GE.13.AND.I.LE.24) THEN
        CX=CX2
        CY=CY2
      ENDIF
      IF(I.GE.25.AND.I.LE.36) THEN
        CX=CX3
        CY=CY3
      ENDIF

      PHI=RPCOSG(KTRK)*ZP(I)+PHZG(KTRK)
      RR=RPSING(KTRK)*ZP(I)+ZIG(KTRK)
      IF(PHI.LT.0.0)PHI=PHI+PI2
      IF(PHI.GT.PI2)PHI=PHI-PI2

*     Jiggery-pokery to get right wedge number...
      XT=RR*COS(PHI)+XVV +CX
      YT=RR*SIN(PHI)+YVV +CY
      PHT=ATAN2(YT,XT)
      IF(PHT.LT.0.0)PHT=PHT+PI2
      IF(PHT.GT.PI2)PHT=PHT-PI2
      NNW=(PHT+HPHII -PHW(I))/PHII
      NNW=NNW+1


      NP=NDP(I)
      DMIN=1000.

      DO 120 J=1,NP

       IF(DRI(J,I).GT.900.)GOTO120
       IF(ABS(NW(J,I)-NNW).GT.1)GOTO120

*      Expected drift corrected for shifts...
       DRE=RR*SIN(PHI-WW(J,I))
     1  +(YVV+CY)*COS(WW(J,I))-(XVV+CX)*SIN(WW(J,I))

*      Measured drifts...
       DWW= DRI(J,I)+DWS(J,I)
       DTT=-DRI(J,I)+DWS(J,I)

       DDW=DWW-DRE
       DDT=DTT-DRE

       IF(ABS(DDW).LT.DMIN)THEN
        DMIN=ABS(DDW)
        DDD=DDW
        JMIN=J
       ENDIF

       IF(ABS(DDT).LT.DMIN)THEN
        DMIN=ABS(DDT)
        JMIN=J
        DDD=DDT
       ENDIF

 120  CONTINUE

      IRT(I)=0
      REZ(I)=10.
      IF(DMIN.LT.5.0)THEN
        IRT(I)=JMIN
        REZ(I)=DDD/0.0150
      ENDIF

      IF(I.GE.1.AND.I.LE.12.AND.IRT(I).NE.0)THEN
        L=L+1
        IF(ABS(REZ(I)).LT.5.0) THEN
          CALL SHS(116,0,REZ(I))
          CALL SHS(119,0,REZ(I))
        ENDIF
      ENDIF

      IF(I.GE.13.AND.I.LE.24.AND.IRT(I).NE.0)THEN
        LL=LL+1
        IF(ABS(REZ(I)).LT.5.0) THEN
          CALL SHS(117,0,REZ(I))
          CALL SHS(119,0,REZ(I))
        ENDIF
      ENDIF

      IF(I.GE.25.AND.I.LE.36.AND.IRT(I).NE.0)THEN
        LLL=LLL+1
        IF(ABS(REZ(I)).LT.5.0) THEN
          CALL SHS(118,0,REZ(I))
          CALL SHS(119,0,REZ(I))
        ENDIF
      ENDIF

 1    CONTINUE

      ENDIF

*     Now look at radial segment data...
      DO 1001 I=1,3
      DO 1002 J=1,NTRAKS(I)
      CH  = CHSQ(J,I)
      CALL SHS(241,0,CH)

      NWED = -1
      JCNT = 0
      DO 1003 K=1,12
        JWIR = 12*(I-1) + K
*       Track parameters for this track...
        PHI = PCOSL(J,I)*ZP(JWIR)+PHZL(J,I)
        RR  = PSINL(J,I)*ZP(JWIR)+RZI(J,I)
        IF(PHI.LT.0.0)PHI=PHI+PI2
        IF(PHI.GT.PI2)PHI=PHI-PI2

        JP    = IRPT(K,J,I)
        IF(JP .NE. 0) THEN
          IF(NWED.LT.0) THEN
            NWED = NW(JP,JWIR)
          ENDIF
          IF(NW(JP,JWIR) .NE. NWED) GOTO 1003
*         IF(IERRF(JP,JWIR) .GT. 1) GOTO 1003

          JCNT = JCNT + 1
*         Z of wire...
          ZEDW(JCNT) = ZP(JWIR)

          DS    = SDRFT(K,J,I)
*         Measured drift...
          DRFT(JCNT) = DS*DRI(JP,JWIR)+DWS(JP,JWIR)
*         ...and radius (this has been corrected for Lorenz angle).
          RMEAS(JCNT) = RM(JP,JWIR)

*         Expected drift corrected for shifts...
          DRFE(JCNT)   = RR*SIN(PHI-WW(JP,JWIR))
          RESID(JCNT)  = DRFT(JCNT) - DRFE(JCNT)

*         Expected radius corrected for shifts...
          RAD(JCNT)   = RR*COS(PHI-WW(JP,JWIR))
          RESR(JCNT)  = RMEAS(JCNT) - RAD(JCNT)

        ELSE
          CALL SHS(209,0,FLOAT(JWIR))
        ENDIF

 1003 CONTINUE
      IF(JCNT .GE.4) THEN
      DO 1009 KK=1,JCNT
          CALL SHS(232+I,0,RESID(KK))
          CALL SHS(236  ,0,RESID(KK))
          CALL SHD(242  ,0,DRFE(KK),RESID(KK))
          CALL SHS(236+I,0,RESR(KK))
          CALL SHS(240  ,0,RESR(KK))
          CALL SHD(250  ,0,RMEAS(KK),RESR(KK))
 1009 CONTINUE
      ENDIF

      IF(JCNT .GE. 6) THEN
*     Close to wire stuff...
      ENDIF

 1002 CONTINUE
 1001 CONTINUE

      RETURN
      END
*CMZ :  8.07/00 20/11/96  21.36.33  by  Stephen Burke
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.05/00 27/09/96  16.43.01  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.17  by  Stephen Burke
*CMZU:  7.02/11 31/10/95  14.04.33  by  Stephen Burke
*CMZU:  3.09/01 25/04/93  17.18.20  by  Stephen J. Maxfield
*-- Author :   I.O.Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Pick up planar line segments on radial-
*          based tracks.
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial-based tracks:
*          IG tracks
*          Hits/drift sign         :- IRN/SDN
*          Segments planars/radials:- LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*
*HTMLO     : Describe the Output of the routine
*
* Radial-based tracks:
*          IG tracks
*          Hits/drift sign         :- IRN/SDN IRP/SDP
*          Segments planars/radials:- ISGG LNK3
*          Used point flag         :- IUSEDP
*          Used segment flag       :- IUSEG
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPLPKS( IUSEDP, IUSEG)
*
*     Routine to pick up planar segments.
*     INPUT: IT ... Iteration number.
*            K..... Track number.
*            IUSEDP(Hit number, wire-plane) = 1 if hit already used
*                                           = 0 if free.
*     OUTPUT:IUSEDP(Hit number, wire-plane)  (up-dated)
*
*            ...and in common block FRH3FT:
*                 IRP(wire-plane, K) = number of hit on this plane
*                                      associated with the track K
*                 SDP(wire-plane, K) = +1.0, -1.0 for its drift sign
*
*     Searches for closest segment to track K in the R-Phi
*     direction which is sufficiently close in the radial direction.
*     Separation is Rmean*delta-phi, where Rmean is
*     mean of planar segment and radial predicted R's and delta-phi
*     is separation in Phi.
*
*
*     Fit parameters are in H1WORK:
*     RPCOSG(K) = Slope of Phi-z fit
*     RPSING(K) = Slope of R-z fit
*     PHZG(K)   = Intercept of Phi-z fit (at z=0)
*     ZIG(K)    = Intercept of R-z fit (at z=0)
*     Errors are in FTRERR:
*     COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR
*     Dxxxx = sigma (not squared) of parameter xxxx
*     COVP  = covariance of Phi-z fit parameters
*     COVR  = covariance of R  -z fit parameters

*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRH3FT.
*     Common for RETRAC results (SJM)
      COMMON/FRH3FT/ IRN(36,MAXTRK),SDN(36,MAXTRK),
     +              IRP(36,MAXTRK),SDP(36,MAXTRK),
     +              IG2,IGTTRK(MAXTRK),
     +              CHISQ(MAXTRK),NUMDF(MAXTRK),
     +              FITX(MAXTRK),FITY(MAXTRK),FITZ(MAXTRK),
     +              FITTH(MAXTRK),FITPH(MAXTRK),
     +              FITCU(MAXTRK),FTCOV(15,MAXTRK)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEEP,FPTPAR.
      COMMON/FPTPAR/PCUT1, PCUT2, PCUT3, CXP, CYP,
     +              DRPCT1, DRPCT2, DRPCT3,
     +              DRCUT1, DRCUT2, DRCUT3
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.

*     Common for track parameter errors...
      COMMON /FTRERR/ DSLPHI, DPHZER, COVP, DSLPR, DRZER, COVR


*     Common for segment numbers...
      COMMON /FPSEG1/ ISGG(3,MAXTRK)
      common/fpstsg/nstc(9),nfsseg(3),nftseg(3)
*     Local arrays...
      DIMENSION IUSEDP(MAXTRK,36), IUSEG( MAXSEG, 3)
      DIMENSION RSEG(4),PSEG(4)
      PARAMETER(PI2=6.2831853)
      data istart/0/

*     Establish cut values for this iteration...
*     single iteration in this code
      it=3
      IF    (IT .EQ. 1) THEN
       DRPCUT = DRPCT1
       DRCUT  = DRCUT1
      ELSEIF(IT .EQ. 2) THEN
       DRPCUT = DRPCT2
       DRCUT  = DRCUT2
      ELSEIF(IT .EQ. 3) THEN
       DRPCUT = DRPCT3
       DRCUT  = DRCUT3
      ELSE
       DRPCUT = DRPCT3
       DRCUT  = DRCUT3
      ENDIF
c     note  mm
      drpcut= 5.
      drcut=100.
c     rad/cm
      phicut=0.002
      if(istart.eq.0)then
      istart=1
      write(*,*)' fplpks cuts: hardwired '
      write(*,*)' drpcut =   5. mm '
      write(*,*)' drcut  = 100. mm '
      write(*,*)' phicut =   0.002 rad/cm '
      write(*,*)' single iteration '
      write(*,*)' primary only '
      endif
C
C---   Loop over supermodules
C

      DO 10 ISM = 1,3
c     number primary segments
      npris=nfseg(ism)-nfsseg(ism)-nftseg(ism)
C
C---  Calculate radial prediction for segment in this supermodule
C
      Z = ZPP( 6 + (ISM -1)*12 )
C
C---  RR and PHI calculated for this Z as predicted by radials
C
c     loop over all tracks
c     and all planar segments
 200  nadd=0
      ISMIN = 0
      kmin=0
      DRMIN = 1000000.0
      DRM   = 1000000.0
      do 100 k=1,ig
c     check if planar already linked	
      if(isgg(ism,k).ne.0)goto100

      RR  = RPSING(K)*Z + ZIG(K)
      RRAD= RR*10.
      PHI = RPCOSG(K)*Z + PHZG(K)
      PHI = AMOD(PHI,PI2)
      IF(PHI.LT.0.0) PHI = PHI + PI2
      ZMM     = Z*10.0
      zb=zpp(1+(ism-1)*12)
      ze=zpp(12*ism)
      zbmm=zb*10.
      zemm=ze*10.
C

      DO 20 IP = 1,NFSEG(ISM)
C
C---  search only unused segments
C
      IF( IUSEG(IP,ISM) .NE. 0 )GO TO 20
C
C---  search only the disconnected set
C
      IF( MASKSG(IP,ISM) .NE. 0 )GO TO 20
c
c---  primary only
c
      if(ip.gt.npris)goto20
C
C---  Extract planar segment and covariance matrix
C
      DO 30 I = 1,4
C---
      PSEG(I) = XYDXY(I,IP,ISM)
C---
   30 CONTINUE
C---

*     R and Phi for planar segment
*     note mm
      PSEG(1)  = PSEG(1)  +  ZMM * PSEG(3)
      PSEG(2)  = PSEG(2)  +  ZMM * PSEG(4)
      RPL = SQRT(PSEG(1)**2 + PSEG(2)**2)

      PHIPLA = ATAN2(PSEG(2), PSEG(1))
      PHIPLA = AMOD(PHIPLA,PI2)
      IF(PHIPLA.LT.0.0) PHIPLA = PHIPLA + PI2

*     Believe the radial segment prediction in the 'drift' direction
*     only. More-or-less ignore rad radius...
      RMEAN = RPL
      DELP  = PHIPLA - PHI
      IF(DELP .GT. (PI2/2.)) THEN
           DELP = DELP -PI2
      ELSEIF(DELP .LT. -(PI2/2.)) THEN
           DELP = DELP +PI2
      ENDIF
      DRPHI = RMEAN*(DELP)
      DR    = RPL - RRAD
      DRPHI = ABS(DRPHI)
      DR    = ABS(DR)
c     compare slope of planar in phi-z
c     with radial based track model

      x1=xydxy(1,ip,ism)+zbmm*xydxy(3,ip,ism)
      y1=xydxy(2,ip,ism)+zbmm*xydxy(4,ip,ism)
      x2=xydxy(1,ip,ism)+zemm*xydxy(3,ip,ism)
      y2=xydxy(2,ip,ism)+zemm*xydxy(4,ip,ism)
      p1=atan2(y1,x1)
      p1=amod(p1,pi2)
      if(p1.lt.0.)p1=p1+pi2
      p2=atan2(y2,x2)
      p2=amod(p2,pi2)
      if(p2.lt.0.)p2=p2+pi2
      dp=p2-p1
      if(dp.gt.6.0)dp=dp-pi2
      if(dp.lt.-6.0)dp=dp+pi2
      ps=dp/(ze-zb)
      dps=ps-rpcosg(k)
      dps=amod(dps,pi2)
      if(drphi.lt.drpcut)then
      if(dr.lt.drcut)then
      call shs(224+it,0,dps)
      endif
      endif
c
c     hardwired cut
c     slope of planar line segment differs
c     from track model
c
      if(abs(dps).gt.phicut)goto20


      IF(DRPHI .LT. DRMIN) THEN
      IF(DR    .LT. DRCUT) THEN
        DRMIN = DRPHI
        ISMIN = IP
        kmin  = k
        DRM   = DR
      ENDIF
      ENDIF
C
C---  End of loop over planars segments for supermodule
C
   20 CONTINUE
c     end of loop over tracks
 100  continue
c     loop over tracks and segments finished
c     best selected

      IF(IDOHIS .GE. 2) THEN
        if(ismin.ne.0)then
        CALL SHS(214+IT, 0, DRMIN)
        CALL SHS(217+IT, 0, DRM)
        endif
      ENDIF
C
C---  Build list of planar hits and mark segment and hits used
C
      IFR =  1+(ISM-1)*12
      ILS =  11+IFR


      IF(ISMIN .NE. 0) THEN
      IF(DRMIN .LT. DRPCUT) THEN
        IF(IT.EQ.NIT) THEN
         IUSEG(ISMIN, ISM) = 1
         ISGG(ISM,Kmin) = ISMIN
         nadd=1
         IF(IDOHIS .GE. 2) THEN
           CALL SHS(210,0,DRMIN)
           CALL SHS(211,0,DRM  )
           CALL SHD(212,0,DRMIN,DRM)
         ENDIF

        ENDIF
        II=0
        DO 50 IWIR= IFR, ILS
         II   = II+1
         IOSP = IDGISG(II,ISMIN,ISM)
         IF (IOSP.EQ.0) GOTO 50
         IRP(IWIR, Kmin) = IABS(IOSP)
         SDP(IWIR, Kmin) = SIGN(1.0, FLOAT(IOSP))
         IF(IT.EQ.NIT) THEN
         IF(IUSEDP(IABS(IOSP), IWIR).NE.0) THEN
c        check if point previously used,if yes,remove
         DO 51 ITRK = 1, IG
           IF(ITRK .EQ. Kmin) GOTO 51
           IF(IRP(IWIR, ITRK) .EQ. IABS(IOSP)) THEN
            IRP(IWIR, ITRK) = 0
           ENDIF
 51      CONTINUE
         ENDIF
c        mark point used
          IUSEDP(IABS(IOSP), IWIR)=1
         ENDIF
 50     CONTINUE

      ENDIF
      ENDIF
c     continue search for links if link found
c     otherwise go to next supermodule
      if(nadd.eq.1)goto 200
C
C---  End of loop over supermodules
C
   10 CONTINUE
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.42.19  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.18  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.55  by  Stephen Burke
*CMZU:  3.06/02 24/09/92  14.05.59  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Use radial  points to make
*          least squares fits in phi-z, r-z.
*
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial-based tracks:
*          Hits/drift sign         :- IRN/SDN
*
*
*HTMLO     : Describe the Output of the routine
*
*          Parameters(phi',phi0)   :- RPCOS,phz
*          Parameters(R',R0)       :- THET,RZII
*
*
*HTMLE     : Terminates the HTML documentation
*
*
*
      SUBROUTINE FTFHQQ(NPLA,IPA,SD,ZVV,C1,C2,C3,
     1            RPCOS,THET,PHZ,DRPCOS,DTHET,DPHZ,RZII,CH,IT)
**: FTFHQQ 40000 IS. New linking code.
**----------------------------------------------------------------------
C     LEAST SQUARES FIT IN R-Z, PHI-Z
C     FOR SINGLE LINE SEGMENT
C     AUTHOR   I.O.SKILLICORN
C     RECODED 13/6/93
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEND.
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FRWERR.
      COMMON /WERR/ERRVL,ERRV,ERRP,ERRRX
*KEND.
*
      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)
      DIMENSION XX(40),YY(40),WP(40)
      DIMENSION IPA(36),SD(36),CB(36)
      PI2=6.2831853
      II=0
      FF=0.
      RMN=0.
      DO 20 K=1,NPLA
C     J IS POINT NO.     K=PLANE NO.
      J=IPA(K)
      IF(J.EQ.0)GOTO20
      IF(DRI(J,K).GT.900.)GOTO20
      II=II+1
      YY(II)=RM(J,K)
      XX(II)=ZP(K)
      WP(II)=1./ERRRM(J,K)
      RMN=RMN+YY(II)*WP(II)
      FF=FF+WP(II)
C      PRINT1003,II,J,XX(II),YY(II),WP(II)
 1003 FORMAT(' HELIX R',2I5,3F10.4)
 20   CONTINUE

      CALL FTLFTW(XX,YY,WP,II,0,2,RZS,RZII,ET,DRZS,DRZI,COV)
      THET=RZS
      DTHET=DRZS
C     WEIGHTED MEAN R
      R1=RMN/FF
C
C     CALCULATE PHI BASED ON FITTED R
      II=0
      DO30 K=1,NPLA
C     J IS POINT NO.     K=PLANE NO.
      J=IPA(K)
      IF(J.EQ.0)GOTO30
      IF(DRI(J,K).GT.900.)GOTO30
      II=II+1
      XX(II)=ZP(K)
C     USE RESULTS OF STR LINE FIT IN R-Z
      RR=RZS*ZP(K)+RZII
C     LAB PHI WITH FITTED R
C     TRY MEAN R INSTEAD OF RR  - R1
      PHI=ATAN((DRI(J,K)*SD(K)+DWS(J,K))/R1)+WW(J,K)
      IF(PHI.LT.0.0)PHI=PHI+PI2
      YY(II)=PHI
C     TAKE ERROR IN PHI PROPORTIONAL TO 1./RR
      WP(II)=R1
C     PRINT1002,J,II,XX(II),YY(II),WP(II),RR
 1002 FORMAT(' PHI   ',2I5,4F10.4)
 30   CONTINUE
      IF(II.GE.2)THEN
      DO 32 JK=2,II
      DP=YY(JK)-YY(JK-1)
      IF(DP.GT.0.0)THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JK)=YY(JK)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JK)=YY(JK)+PI2
      ENDIF
 32   CONTINUE
      ENDIF
C
      CALL FTLFTW(XX,YY,WP,II,0,2,RPCOS,PHZ,EL,DRPCOS,DPHZ,COV)
C     RPCOS-SLOPE PHI-Z,PHZ-INTERCEPT  PHI AXIS
      CH=0.
C     ERROR IN RPCOS IS UNKNOWN DUE TO R-MEASUREMENT PROBLEMS
      DRPCOS=1.0
      DPHZ=1.0
      DTHET=1.0
      IF(RPCOS.EQ.0.0.AND.PHZ.EQ.0.0)THEN
      CH=2000.
      RETURN
      ENDIF

CDEB  PRINT5000,RPCOS,PHZ,DRPCOS,DPHZ
 5000 FORMAT(' PHI-Z RPCOS,PHZ,EPC,EP ',4F10.5)
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.18  by  Stephen Burke
*CMZU:  5.03/00 30/09/94  09.23.46  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.56  by  Stephen Burke
*CMZU:  3.08/03 21/02/93  18.20.54  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Link radial line segments: modules 1 and 2
*
*HTMLI     : Describe the Input variables to the routine
*
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*
*HTMLO     : Describe the Output of the routine
*
*
* Radial-based tracks:
*          IG tracks
*          Segments                :- LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTJN12(CF,IU,LLL,LL,RPC,RPS,PH,CH,       ZI)
**: FTJN12 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FTJN12 40000 SM. Fix selection of best link.
**----------------------------------------------------------------------
C     JOIN       MODULES  1 AND 2
C     AUTHOR    I.O.SKILLICORN
C     21/5/91  REDUCE SIZE
C new version imported from IOS fortran 6/6/91
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FJNPAR.
      COMMON/FJNPAR/
     +      CHT3, CHT12, CHT23, CHT13,
     +      PCT3, PCT12, PCT23, PCT13,
     +      PSC3, PSC12, PSC23, PSC13,
     +      RCT3, RCT12, RCT23, RCT13
*KEND.
*
      COMMON/PARA/PA1,PA2,PA3,ZA1,ZA2,ZA3
*
*     LOCAL ARRAYS...
      DIMENSION CF(MAXTR3,3),IU(MAXTR3,3),LL(MAXTRK,2)
      DIMENSION RPC(MAXTRK),RPS(MAXTRK)
      DIMENSION PH(MAXTRK),CH(MAXTRK),CX(3)
C     DIMENSION IP(36),SD(36),IPP(36,MAXTRK),SDD(36,MAXTRK)
      DIMENSION IP(36),SD(36)
      DIMENSION ZI(MAXTRK)
      DIMENSION XX(36),YY(36),ZZ(36),WT(36),IMM(36)
      DIMENSION XXX(36),YYY(36),ZZZ(36),WWT(36)

C     'Centre' points of radial modules
      PARAMETER(IZM1=6)
      PARAMETER(IZM2=18)
      PARAMETER(IZM3=30)
*
      ZM12 = 0.5*(ZP(IZM1) + ZP(IZM2))
      ZM23 = 0.5*(ZP(IZM2) + ZP(IZM3))
      ZM13 = 0.5*(ZP(IZM1) + ZP(IZM3))
      Z1=ZP(06)
      Z2=ZP(18)
      Z3=ZP(30)
*
C     TO JOIN TWO  MODULES
C     STANDARD DEVIATIONS ** 2
      PI2=6.2831853


C     CUTS CHANGED FOR FAST FILTER - SECOND LINE FOR FAST FILTER
C     SELECT TRACKS STR LINE PHI-Z ONLY
C     IE THOSE FROM Z-AXIS


C     REPLACEMENT VALUES H1SIM  ****************************
      CHT   = CHT12
      PCUT  = PCT12
      PSCUT = PSC12
      RCUT  = RCT12
C
C     ****************************************************
*************************NEW CUTS******94 DATA**************
*     CHT   =100.
*     RCUT  =20.
*     PCUT  =0.04
*     PSCUT =0.002
************************************************************
C
      LLL=0
      ZVV=ZV
      N1=NTRAKS(1)
      N2=NTRAKS(2)
      N3=NTRAKS(3)
C     =0 USE MANY TIMES  =1  USE ONCE
      ICHK=1
C     IU SET IN  FTJN3
C     *******************************
      DO 10 I=1,N1
      IF(CHSQ(I,1).GT.1000.)GOTO10
      IF(ICHK.EQ.1.AND.IU(I,1).EQ.1)GOTO10
      DO 20 J=1,N2

      IF(CHSQ(J,2).GT.1000.)GOTO20
      IF(ICHK.EQ.1.AND.IU(J,2).EQ.1)GOTO20

      RTEST=(RFIT(I,1)-RFIT(J,2)*Z1/Z2)
      IF(ABS(RTEST).GT.RCUT)GOTO20

C     REFIT PHI-Z WITH R-VALUES OF SEGMENTS
C     FILL POINTS/DRIFT SIGN
C     RECALCULATE PHI-Z SLOPE AND INTERCEPT
      DO 200 KK=1,24
      IF(KK.LE.12)THEN
      IP(KK)=IRPT(KK,I,1)
      SD(KK)=SDRFT(KK,I,1)
      ELSE
      IP(KK)=IRPT(KK-12,J,2)
      SD(KK)=SDRFT(KK-12,J,2)
      ENDIF
 200  CONTINUE
      L=0
      DO 210 KK=1,24
      IF(IP(KK).EQ.0)GOTO210
      JJ=IP(KK)
      L=L+1
      IF(KK.LE.12)IMM(L)=1
      IF(KK.GT.12)IMM(L)=2
C     R : ASSUMES LINEAR TO VERTEX
      RR=(RFIT(I,1)+RFIT(J,2))/(Z1+Z2)*ZP(KK)
      XX(L)=ZP(KK)
      YY(L)=ATAN((DRI(JJ,KK)*SD(KK)+DWS(JJ,KK))/RR) +WW(JJ,KK)
      IF(YY(L).LT.0.0)YY(L)=YY(L)+PI2
      WT(L)=1.0
 210  CONTINUE
C     PHI CONTINUOUS
      IF(L .GT. 1)THEN
      DO220 JJ=2,L
       DP = YY(JJ)-YY(JJ-1)
       IF(DP.GT.0.) THEN
       IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
       ELSE
       IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
       ENDIF
 220  CONTINUE
      ENDIF
      IC=0
      DO 230 KK=1,L
      IF(IMM(KK).EQ.1)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 230  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS1,PZ1,D1,D2,D3,COV)
      IC=0
      DO 240 KK=1,L
      IF(IMM(KK).EQ.2)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 240  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS2,PZ2,D1,D2,D3,COV)
C     CHECK RECALCULATED PHI CONTINUOUS
      PP1=PS1*ZM12+PZ1
      PP2=PS2*ZM12+PZ2

      IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2000,0,PP1-PP2)
*
      IF(ABS(PP1-PP2).GT.PCUT)GOTO20
      IF(ABS(PS1-PS2).GT.PSCUT)GOTO20
*
      CALL FTCHKH(PCOS, PHZ, PSIN, RI, I, J, 0, CHI)
      IF(CHI.GT.CHT)GOTO50
*------------------------------------------

C     GOOD LINK
      LLL=LLL+1
C******************************************12/10/88********************
      IF(LLL.GT.MAXTRK)LLL=MAXTRK
      LL(LLL,1)=I
      LL(LLL,2)=J
C      LL(LLL,3)=K
      RPC(LLL)=PCOS
      RPS(LLL)=PSIN
      PH(LLL)=PHZ
      CH(LLL)=CHI
      ZI(LLL)=RI

 50   CONTINUE
 20   CONTINUE
 10   CONTINUE
      DO 100 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 110 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 110
      IF(LL(K,1).EQ.0)GOTO110
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 110  CONTINUE
      IF(KB.EQ.0)GOTO199
C     COMPARE BEST WITH REMAINDER
      DO 120 K=1,LLL
      IF(K.EQ.KB)GOTO120
      IF(LL(K,1).EQ.0)GOTO120
      IF(LL(K,1).EQ.LL(KB,1))GOTO130
      IF(LL(K,2).EQ.LL(KB,2))GOTO130
CCCCC IF(LL(K,3).EQ.LL(KB,3))GOTO130
      GOTO 120
C     REMOVE LINK
 130  LL(K,1)=0
      LL(K,2)=0
 120  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 100  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 199  DO 140 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 140  CONTINUE
C
C
C
C     SET USED FLAGS
      NLLL=0
      DO 300 I=1,LLL
      IF(LL(I,1)*LL(I,2).EQ.0)GOTO300
      IU(LL(I,1),1)=1
      IU(LL(I,2),2)=1
      NLLL=NLLL+1
CCCCCC      IU(LL(I,3),3)=1
      CALL SHS(2040,0,4.)
      CALL SHS(2040,0,10.)
      CALL SHS(2046,0,CH(I))

*------------------------------------------
C     PRINT1000,LL(I,1),LL(I,2),LL(I,3)
 1000 FORMAT('  T1,T2,T3 ',5I3)
*------------------------------------------

 300  CONTINUE
      IF(NLLL.NE.0)CALL SHS(2042,0,FLOAT(LLL)/FLOAT(NLLL))

      RETURN
C
      END
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.18  by  Stephen Burke
*CMZU:  5.03/00 04/10/94  17.12.17  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.56  by  Stephen Burke
*CMZU:  3.06/06 09/10/92  10.09.53  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*
*          Link radial line segments: modules 1 and 3
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*
*
*HTMLO     : Describe the Output of the routine
*
*
* Radial-based tracks:
*          IG tracks
*          Segments                :- LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*HTMLE     : Terminates the HTML documentation
*
*
*
C new version imported from IOS fortran 6/6/91
*
      SUBROUTINE FTJN13(CF,IU,LLL,LL,RPC,RPS,PH,CH,    ZI)
**: FTJN13 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FTJN13 40000 SM. Fix selection of best link.
**----------------------------------------------------------------------
C     AUTHOR    I.O.SKILLICORN
C      JOIN MODULES 1 AND 3
C     21/5/91  REDUCE SIZE
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FJNPAR.
      COMMON/FJNPAR/
     +      CHT3, CHT12, CHT23, CHT13,
     +      PCT3, PCT12, PCT23, PCT13,
     +      PSC3, PSC12, PSC23, PSC13,
     +      RCT3, RCT12, RCT23, RCT13
*KEND.
*
      COMMON/PARA/PA1,PA2,PA3,ZA1,ZA2,ZA3
*
*     LOCAL ARRAYS...
      DIMENSION CF(MAXTR3,3),IU(MAXTR3,3),LL(MAXTRK,2)
      DIMENSION RPC(MAXTRK),RPS(MAXTRK)
      DIMENSION PH(MAXTRK),CH(MAXTRK),CX(3)
C     DIMENSION IP(36),SD(36),IPP(36,MAXTRK),SDD(36,MAXTRK)
      DIMENSION IP(36),SD(36)
      DIMENSION ZI(MAXTRK)
      DIMENSION XX(36),YY(36),ZZ(36),WT(36),IMM(36)
      DIMENSION XXX(36),YYY(36),ZZZ(36),WWT(36)

C     'Centre' points of radial modules
      PARAMETER(IZM1=6)
      PARAMETER(IZM2=18)
      PARAMETER(IZM3=30)
*
      ZM12 = 0.5*(ZP(IZM1) + ZP(IZM2))
      ZM23 = 0.5*(ZP(IZM2) + ZP(IZM3))
      ZM13 = 0.5*(ZP(IZM1) + ZP(IZM3))
      Z1=ZP(06)
      Z2=ZP(18)
      Z3=ZP(30)
*
C     TO JOIN TWO  MODULES
C     STANDARD DEVIATIONS ** 2
      PI2=6.2831853


C     CUTS CHANGED FOR FAST FILTER - SECOND LINE FOR FAST FILTER
C     SELECT TRACKS STR LINE PHI-Z ONLY
C     IE THOSE FROM Z-AXIS


C     REPLACEMENT VALUES H1SIM  ****************************
      CHT   = CHT13
      PCUT  = PCT13
      PSCUT = PSC13
      RCUT  = RCT13
C
C     ****************************************************
*************************NEW CUTS******94 DATA**************
*     CHT=100.
*     RCUT=20.
*     PCUT=0.04
*     PSCUT=0.002
************************************************************
C
      LLL=0
      ZVV=ZV
      N1=NTRAKS(1)
      N2=NTRAKS(2)
      N3=NTRAKS(3)
C     =0 USE MANY TIMES  =1  USE ONCE
      ICHK=1
C     IU SET IN  FTJN3
C     *******************************
      DO 10 I=1,N1
      IF(CHSQ(I,1).GT.1000.)GOTO10
      IF(ICHK.EQ.1.AND.IU(I,1).EQ.1)GOTO10
      DO 20 J=1,N3

      IF(CHSQ(J,3).GT.1000.)GOTO20
      IF(ICHK.EQ.1.AND.IU(J,3).EQ.1)GOTO20
      RTEST=(RFIT(I,1)-RFIT(J,3)*Z1/Z3)
      IF(ABS(RTEST).GT.RCUT)GOTO20

C     REFIT PHI-Z WITH R-VALUES OF SEGMENTS
C     FILL POINTS/DRIFT SIGN
C     RECALCULATE PHI-Z SLOPE AND INTERCEPT
      DO 200 KK=1,36
      IF(KK.LE.12)THEN
      IP(KK)=IRPT(KK,I,1)
      SD(KK)=SDRFT(KK,I,1)
      ENDIF
      IF(KK.GT.24)THEN
      IP(KK)=IRPT(KK-24,J,3)
      SD(KK)=SDRFT(KK-24,J,3)
      ENDIF
      IF(KK.GT.12.AND.KK.LE.24)IP(KK)=0
 200  CONTINUE
      L=0
      DO 210 KK=1,36
      IF(IP(KK).EQ.0)GOTO210
      JJ=IP(KK)
      L=L+1
      IF(KK.LE.12)IMM(L)=1
      IF(KK.GT.24)IMM(L)=2
C     R : ASSUMES LINEAR TO VERTEX
      RR=(RFIT(I,1)+RFIT(J,3))/(Z1+Z3)*ZP(KK)
      XX(L)=ZP(KK)
      YY(L)=ATAN((DRI(JJ,KK)*SD(KK)+DWS(JJ,KK))/RR) +WW(JJ,KK)
      IF(YY(L).LT.0.0)YY(L)=YY(L)+PI2
      WT(L)=1.0
 210  CONTINUE
C     PHI CONTINUOUS
      IF(L .GT. 1)THEN
      DO220 JJ=2,L
       DP = YY(JJ)-YY(JJ-1)
       IF(DP.GT.0.) THEN
       IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
       ELSE
       IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
       ENDIF
 220  CONTINUE
      ENDIF
      IC=0
      DO 230 KK=1,L
      IF(IMM(KK).EQ.1)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 230  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS1,PZ1,D1,D2,D3,COV)
      IC=0
      DO 240 KK=1,L
      IF(IMM(KK).EQ.2)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 240  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS2,PZ2,D1,D2,D3,COV)
C     CHECK RECALCULATED PHI CONTINUOUS
      PP1=PS1*ZM13+PZ1
      PP2=PS2*ZM13+PZ2

      IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2002,0,PP1-PP2)
*
      IF(ABS(PP1-PP2).GT.PCUT)GOTO20
      IF(ABS(PS1-PS2).GT.PSCUT)GOTO20
*
      CALL FTCHKH(PCOS, PHZ, PSIN, RI, I, 0, J, CHI)
      IF(CHI.GT.CHT)GOTO50



C     GOOD LINK
      LLL=LLL+1
C******************************************12/10/88********************
      IF(LLL.GT.MAXTRK)LLL=MAXTRK
      LL(LLL,1)=I
      LL(LLL,2)=J
C      LL(LLL,3)=K
      RPC(LLL)=PCOS
      RPS(LLL)=PSIN
      PH(LLL)=PHZ
      CH(LLL)=CHI
      ZI(LLL)=RI
*------------------------------------------
CDEB      PRINT 1010,LLL,(IPP(NNN,LLL),NNN=1,36)
1010  FORMAT(' JOIN2 ',I3,1X,12I2,1X,12I2,1X,12I2,F8.2)
*------------------------------------------

 50   CONTINUE
 20   CONTINUE
 10   CONTINUE
      DO 100 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 110 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 110
      IF(LL(K,1).EQ.0)GOTO110
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 110  CONTINUE
      IF(KB.EQ.0)GOTO199
C     COMPARE BEST WITH REMAINDER
      DO 120 K=1,LLL
      IF(K.EQ.KB)GOTO120
      IF(LL(K,1).EQ.0)GOTO120
      IF(LL(K,1).EQ.LL(KB,1))GOTO130
      IF(LL(K,2).EQ.LL(KB,2))GOTO130
CCCCC IF(LL(K,3).EQ.LL(KB,3))GOTO130
      GOTO 120
C     REMOVE LINK
 130  LL(K,1)=0
      LL(K,2)=0
 120  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 100  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 199  DO 140 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 140  CONTINUE
C
C
C
C     SET USED FLAGS
      NLLL=0
      DO 300 I=1,LLL
      IF(LL(I,1)*LL(I,2).EQ.0)GOTO300
      NLLL=NLLL+1
      IU(LL(I,1),1)=1
      IU(LL(I,2),3)=1
CCCCCC      IU(LL(I,3),3)=1
      CALL SHS(2040,0,8.)
      CALL SHS(2040,0,10.)

*------------------------------------------
C     PRINT1000,LL(I,1),LL(I,2),LL(I,3)
 1000 FORMAT('  T1,T2,T3 ',5I3)
*------------------------------------------

 300  CONTINUE

      IF(NLLL.NE.0)CALL SHS(2044,0,FLOAT(LLL)/FLOAT(NLLL))
      RETURN
C
      END
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.18  by  Stephen Burke
*CMZU:  7.01/00 19/06/95  14.05.21  by  Stephen Burke
*CMZU:  5.03/00 30/09/94  09.25.03  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.56  by  Stephen Burke
*CMZU:  3.06/06 09/10/92  10.09.02  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*     : Describe the Purpose of the routine
*
*
*          Link radial line segments: modules 2 and 3
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*
*
*HTMLO     : Describe the Output of the routine
*
* Radial-based tracks:
*          IG tracks
*          Segments                :- LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*
*HTMLE     : Terminates the HTML documentation
*
*
C new version imported from IOS fortran 6/6/91
*
      SUBROUTINE FTJN23(CF,IU,LLL,LL,RPC,RPS,PH,CH,        ZI)
**: FTJN23 40000 IS. New linking code.
**----------------------------------------------------------------------
**: FTJN23 40000 SM. Fix selection of best link.
**----------------------------------------------------------------------
C     JOIN       MODULES
C     AUTHOR    I.O.SKILLICORN
C     21/5/91  REDUCE SIZE
C       JOIN MODULES 2 AND 3
C
C
C
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FJNPAR.
      COMMON/FJNPAR/
     +      CHT3, CHT12, CHT23, CHT13,
     +      PCT3, PCT12, PCT23, PCT13,
     +      PSC3, PSC12, PSC23, PSC13,
     +      RCT3, RCT12, RCT23, RCT13
*KEND.
*
      COMMON/PARA/PA1,PA2,PA3,ZA1,ZA2,ZA3
*
*     LOCAL ARRAYS...
      DIMENSION CF(MAXTR3,3),IU(MAXTR3,3),LL(MAXTRK,2)
      DIMENSION RPC(MAXTRK),RPS(MAXTRK)
      DIMENSION PH(MAXTRK),CH(MAXTRK),CX(3)
C     DIMENSION IP(36),SD(36),IPP(36,MAXTRK),SDD(36,MAXTRK)
      DIMENSION IP(36),SD(36)
      DIMENSION ZI(MAXTRK)
      DIMENSION XX(36),YY(36),ZZ(36),WT(36),IMM(36)
      DIMENSION XXX(36),YYY(36),ZZZ(36),WWT(36)

C     'Centre' points of radial modules
      PARAMETER(IZM1=6)
      PARAMETER(IZM2=18)
      PARAMETER(IZM3=30)
*
      ZM12 = 0.5*(ZP(IZM1) + ZP(IZM2))
      ZM23 = 0.5*(ZP(IZM2) + ZP(IZM3))
      ZM13 = 0.5*(ZP(IZM1) + ZP(IZM3))
      Z1=ZP(06)
      Z2=ZP(18)
      Z3=ZP(30)
*
C     TO JOIN TWO  MODULES
C     STANDARD DEVIATIONS ** 2
      PI2=6.2831853


C     CUTS CHANGED FOR FAST FILTER - SECOND LINE FOR FAST FILTER
C     SELECT TRACKS STR LINE PHI-Z ONLY
C     IE THOSE FROM Z-AXIS


C     REPLACEMENT VALUES H1SIM  ****************************
      CHT   = CHT23
      PCUT  = PCT23
      PSCUT = PSC23
      RCUT  = RCT23
C
C
*************************NEW CUTS******94 DATA**************
*     CHT   = 100.0
*     RCUT=20.
*     PCUT=0.04
*     PSCUT=0.002
************************************************************
C
      LLL=0
      ZVV=ZV
      N1=NTRAKS(1)
      N2=NTRAKS(2)
      N3=NTRAKS(3)
C     =0 USE MANY TIMES  =1  USE ONCE
      ICHK=1
C     IU SET IN  FTJN3
C     *******************************
      DO 10 I=1,N2
      IF(CHSQ(I,2).GT.1000.)GOTO10
      IF(ICHK.EQ.1.AND.IU(I,2).EQ.1)GOTO10
      DO 20 J=1,N3

      IF(CHSQ(J,3).GT.1000.)GOTO20
      IF(ICHK.EQ.1.AND.IU(J,3).EQ.1)GOTO20
      RTEST=(RFIT(I,2)-RFIT(J,3)*Z2/Z3)
      IF(ABS(RTEST).GT.RCUT)GOTO20

C     REFIT PHI-Z WITH R-VALUES OF SEGMENTS
C     FILL POINTS/DRIFT SIGN
C     RECALCULATE PHI-Z SLOPE AND INTERCEPT
      DO 200 KK=13,36
      IF(KK.LE.24)THEN
      IP(KK)=IRPT(KK-12,I,2)
      SD(KK)=SDRFT(KK-12,I,2)
      ELSE
      IP(KK)=IRPT(KK-24,J,3)
      SD(KK)=SDRFT(KK-24,J,3)
      ENDIF
 200  CONTINUE
      L=0
      DO 210 KK=13,36
      IF(IP(KK).EQ.0)GOTO210
      JJ=IP(KK)
      L=L+1
      IF(KK.LE.24)IMM(L)=1
      IF(KK.GT.24)IMM(L)=2
C     R : ASSUMES LINEAR TO VERTEX
      RR=(RFIT(I,2)+RFIT(J,3))/(Z2+Z3)*ZP(KK)
      XX(L)=ZP(KK)
      YY(L)=ATAN((DRI(JJ,KK)*SD(KK)+DWS(JJ,KK))/RR) +WW(JJ,KK)
      IF(YY(L).LT.0.0)YY(L)=YY(L)+PI2
      WT(L)=1.0
 210  CONTINUE
C     PHI CONTINUOUS
      IF(L .GT. 1)THEN
      DO220 JJ=2,L
       DP = YY(JJ)-YY(JJ-1)
       IF(DP.GT.0.) THEN
       IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
       ELSE
       IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
       ENDIF
 220  CONTINUE
      ENDIF
      IC=0
      DO 230 KK=1,L
      IF(IMM(KK).EQ.1)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 230  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS1,PZ1,D1,D2,D3,COV)
      IC=0
      DO 240 KK=1,L
      IF(IMM(KK).EQ.2)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 240  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS2,PZ2,D1,D2,D3,COV)
C     CHECK RECALCULATED PHI CONTINUOUS
      PP1=PS1*ZM23+PZ1
      PP2=PS2*ZM23+PZ2
      IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2001,0,PP1-PP2)
*
      IF(ABS(PP1-PP2).GT.PCUT)GOTO20
      IF(ABS(PS1-PS2).GT.PSCUT)GOTO20
*

      CALL FTCHKH(PCOS, PHZ, PSIN, RI, 0, I, J, CHI)
      IF(CHI.GT.CHT)GOTO50




C     GOOD LINK
      LLL=LLL+1
C******************************************12/10/88********************
      IF(LLL.GT.MAXTRK)LLL=MAXTRK
      LL(LLL,1)=I
      LL(LLL,2)=J
C      LL(LLL,3)=K
      RPC(LLL)=PCOS
      RPS(LLL)=PSIN
      PH(LLL)=PHZ
      CH(LLL)=CHI
      ZI(LLL)=RI

 50   CONTINUE
 20   CONTINUE
 10   CONTINUE

      DO 100 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 110 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 110
      IF(LL(K,1).EQ.0)GOTO110
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 110  CONTINUE
      IF(KB.EQ.0)GOTO199
C     COMPARE BEST WITH REMAINDER
      DO 120 K=1,LLL
      IF(K.EQ.KB)GOTO120
      IF(LL(K,1).EQ.0)GOTO120
      IF(LL(K,1).EQ.LL(KB,1))GOTO130
      IF(LL(K,2).EQ.LL(KB,2))GOTO130
CCCCC IF(LL(K,3).EQ.LL(KB,3))GOTO130
      GOTO 120
C     REMOVE LINK
 130  LL(K,1)=0
      LL(K,2)=0
 120  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 100  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 199  DO 140 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 140  CONTINUE
C
C
C
C     SET USED FLAGS
      NLLL=0
      DO 300 I=1,LLL
      IF(LL(I,1)*LL(I,2).EQ.0)GOTO300
      IU(LL(I,1),2)=1
      IU(LL(I,2),3)=1
      NLLL=NLLL+1
CCCCCC      IU(LL(I,3),3)=1
      CALL SHS(2040,0,6.)
      CALL SHS(2040,0,10.)
      CALL SHS(2047,0,CH(I))

*------------------------------------------
C     PRINT1000,LL(I,1),LL(I,2),LL(I,3)
 1000 FORMAT('  T1,T2,T3 ',5I3)
*------------------------------------------

 300  CONTINUE

      IF(NLLL.NE.0)CALL SHS(2043,0,FLOAT(LLL)/FLOAT(NLLL))
      RETURN
C
      END
*CMZ :  8.07/00 20/11/96  21.43.54  by  Stephen Burke
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.18  by  Stephen Burke
*CMZU:  5.03/00 30/09/94  09.27.22  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.56  by  Stephen Burke
*CMZU:  3.06/06 09/10/92  16.14.58  by  Stephen J. Maxfield
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Link three radial line-segments
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*          Parameters(phi',phi0)   :- PCOSL,phzl
*          Parameters(R',R0)       :- PSINL,RZI
*
*
*HTMLO     : Describe the Output of the routine
*
* Radial-based tracks:
*          IG tracks
*          Segments                :- LNK3
*          Parameters(phi',phi0)   :- RPCOSG,phzg
*          Parameters(R',R0)       :- RPSING,ZIG
*
*
*HTMLE     : Terminates the HTML documentation
*
*
*
* NEW CODE 11/7/94
*
*
*   LINK THREE RADIAL MODULES
*
      SUBROUTINE FTJN3(CF,IU,LLL,LL,RPC,RPS,PH,CH,        ZI)
**: FTJN3 40000 IS.  New linking code.
**----------------------------------------------------------------------
**: FTJN3 40000 .SM. Fix selection of best link.
**----------------------------------------------------------------------
C     JOIN THREE MODULES
C     AUTHOR    I.O.SKILLICORN
C     21/5/91  REDUCE SIZE
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FJNPAR.
      COMMON/FJNPAR/
     +      CHT3, CHT12, CHT23, CHT13,
     +      PCT3, PCT12, PCT23, PCT13,
     +      PSC3, PSC12, PSC23, PSC13,
     +      RCT3, RCT12, RCT23, RCT13
*KEND.
*
      COMMON/FVFLAG/IVERTX
      COMMON/PARA/PA1,PA2,PA3,ZA1,ZA2,ZA3
*
*     LOCAL ARRAYS...
      DIMENSION CF(MAXTR3,3),IU(MAXTR3,3),LL(MAXTR3,3)
      DIMENSION RPC(MAXTR3),RPS(MAXTR3)
      DIMENSION PH(MAXTR3),CH(MAXTR3),CX(3)
C     DIMENSION IP(36),SD(36),IPP(36,MAXTR3),SDD(36,MAXTR3)
      DIMENSION IP(36),SD(36)
      DIMENSION ZI(MAXTR3)
      DIMENSION XX(36),YY(36),ZZ(36),WT(36),IMM(36)
      DIMENSION XXX(36),YYY(36),ZZZ(36),WWT(36)

C     'Centre' points of radial modules
      PARAMETER(IZM1=6)
      PARAMETER(IZM2=18)
      PARAMETER(IZM3=30)
      DATA ISTART/0/
      IF(ISTART.EQ.0)THEN
      ISTART=1
      CALL STEXT(2016,4,' PHI CONT - M12 R12 PSCUT ALL')
      CALL BHS(2016,0,40,-.10,.10)
      CALL STEXT(2017,4,' PHI CONT - M23 R23 PSCUT 3M AFTER M12 SEL ')
      CALL BHS(2017,0,40,-.10,.10)
      ENDIF
*
      ZM12 = 0.5*(ZP(IZM1) + ZP(IZM2))
      ZM23 = 0.5*(ZP(IZM2) + ZP(IZM3))
      ZM13 = 0.5*(ZP(IZM1) + ZP(IZM3))
*
C     TO JOIN THREE MODULES
      PI2=6.2831853

      CONS=-2./(12.*0.0002998)


      CHT   = CHT3
      PCUT  = PCT3
      PSCUT = PSC3
      RCUT  = RCT3

*************************NEW CUTS******94 DATA**************
*     RCUT=20.
*     PCUT=0.04
*     PSCUT=0.002
*     CHT=100
************************************************************
      Z1=ZP(IZM1)
      Z2=ZP(IZM2)
      Z3=ZP(IZM3)

C
C
C
      LLL=0
      ZVV=ZV
      N1=NTRAKS(1)
      N2=NTRAKS(2)
      N3=NTRAKS(3)
C     =0 USE MANY TIMES  =1  USE ONCE
      ICHK=1
C     *******************************
      DO 10 I=1,N1
C     CYCLE LINE SEGMENTS M0
      IF(CHSQ(I,1).GT.1000.)GOTO10
      IF(ICHK.EQ.1.AND.IU(I,1).EQ.1)GOTO10
      DO 20 J=1,N2
C     CYCLE LINE SEGMENTS M1
      IF(CHSQ(J,2).GT.1000.)GOTO20
      IF(ICHK.EQ.1.AND.IU(J,2).EQ.1)GOTO20
      RTEST=(RFIT(I,1)-RFIT(J,2)*Z1/Z2)
C     CHECK LINE SEGMENTS POINT TO Z-AXIS
      IF(ABS(RTEST).GT.RCUT)GOTO20
C     FILL POINTS/DRIFT SIGN
C     REFIT PHI-Z WITH R-VALUES OF SEGMENTS
C     RECALCULATE PHI-Z SLOPE AND INTERCEPT
      DO 100 KK=1,24
      IF(KK.LE.12)THEN
      IP(KK)=IRPT(KK,I,1)
      SD(KK)=SDRFT(KK,I,1)
      ELSE
      IP(KK)=IRPT(KK-12,J,2)
      SD(KK)=SDRFT(KK-12,J,2)
      ENDIF
 100  CONTINUE
      L=0
      DO 110 KK=1,24
      IF(IP(KK).EQ.0)GOTO110
      JJ=IP(KK)
      L=L+1
      IF(KK.LE.12)IMM(L)=1
      IF(KK.GT.12)IMM(L)=2
C     R : ASSUMES LINEAR TO VERTEX
      RRS=(RFIT(I,1)+RFIT(J,2))/(Z1+Z2)
      RR=RRS*ZP(KK)
      XX(L)=ZP(KK)
      YY(L)=ATAN((DRI(JJ,KK)*SD(KK)+DWS(JJ,KK))/RR) +WW(JJ,KK)
      IF(YY(L).LT.0.0)YY(L)=YY(L)+PI2
      WT(L)=1.0
 110  CONTINUE
C     PHI CONTINUOUS
      IF(L .GT. 1)THEN
      DO120 JJ=2,L
      DP = YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.) THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 120  CONTINUE
      ENDIF
      IC=0
      DO 130 KK=1,L
      IF(IMM(KK).EQ.1)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 130  CONTINUE
C     FIT LINESEG IN M0
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS1,PZ1,D1,D2,D3,COV)
      IC=0
      DO 140 KK=1,L
      IF(IMM(KK).EQ.2)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 140  CONTINUE
C     FIT LINESEG IN M1
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS2,PZ2,D1,D2,D3,COV)
C     CHECK RECALCULATED PHI CONTINUOUS AT MID-PLANE
      PP1=PS1*ZM12+PZ1
      PP2=PS2*ZM12+PZ2
      IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2016,0,PP1-PP2)



*     CHECK PHI CONTINUOUS
*     CHECK PHI' SIMILAR FOR EACH SEGMENT
      IF(ABS(PP1-PP2).GT.PCUT)GOTO20
      IF(ABS(PS1-PS2).GT.PSCUT)GOTO20
C     HERE HAVE 0-1 LINK . CYCLE LINKS IN M2
      DO 50 K=1,N3
      IF(CHSQ(K,3).GT.1000.)GOTO50
      IF(ICHK.EQ.1.AND.IU(K,3).EQ.1)GOTO50
C     CHECK 1-2 POINTS TO Z AXIS IN R
      RTEST=(RFIT(J,2)-RFIT(K,3)*Z2/Z3)
      IF(ABS(RTEST).GT.RCUT)GOTO50

C     FILL POINTS/DRIFT SIGN
C     REFIT PHI-Z WITH R-VALUES OF SEGMENTS
C     RECALCULATE PHI-Z SLOPE AND INTERCEPT
      DO 200 KK=1,36
      IF(KK.LE.12)THEN
      IP(KK)=IRPT(KK,I,1)
      SD(KK)=SDRFT(KK,I,1)
      ENDIF
      IF(KK.GE.13.AND.KK.LE.24)THEN
      IP(KK)=IRPT(KK-12,J,2)
      SD(KK)=SDRFT(KK-12,J,2)
      ENDIF
      IF(KK.GE.25)THEN
      IP(KK)=IRPT(KK-24,K,3)
      SD(KK)=SDRFT(KK-24,K,3)
      ENDIF
 200  CONTINUE
      L=0
      DO 210 KK=1,36
      IF(IP(KK).EQ.0)GOTO210
      JJ=IP(KK)
      L=L+1
      IF(KK.LE.12)IMM(L)=1
      IF(KK.GE.13.AND.KK.LT.25)IMM(L)=2
      IF(KK.GT.24)IMM(L)=3
C     R : ASSUMES LINEAR TO VERTEX
      RRS=(RFIT(J,2)+RFIT(K,3))/(Z2+Z3)
      RR=RRS*ZP(KK)
      XX(L)=ZP(KK)
      YY(L)=ATAN((DRI(JJ,KK)*SD(KK)+DWS(JJ,KK))/RR) +WW(JJ,KK)
      IF(YY(L).LT.0.0)YY(L)=YY(L)+PI2
      WT(L)=1.0
 210  CONTINUE
C     PHI CONTINUOUS
      IF(L .GT. 1)THEN
      DO220 JJ=2,L
      DP = YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.) THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 220  CONTINUE
      ENDIF
      IC=0
      DO 230 KK=1,L
      IF(IMM(KK).EQ.2)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 230  CONTINUE
C     REFIT M1 M2 WITH COMMON R
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS1,PZ1,D1,D2,D3,COV)
      IC=0
      DO 240 KK=1,L
      IF(IMM(KK).EQ.3)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 240  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS2,PZ2,D1,D2,D3,COV)
C     CHECK RECALCULATED PHI CONTINUOUS M2 M3
      PP1=PS1*ZM23+PZ1
      PP2=PS2*ZM23+PZ2
      IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2017,0,PP1-PP2)
C     CHECK M1, M2 CONTINUOUS AT MID PLANE
C     CHECK PHI' SIMILAR
      IF(ABS(PP1-PP2).GT.PCUT)GOTO50
      IF(ABS(PS1-PS2).GT.PSCUT)GOTO50
C     THREE MODULES LINK WITHIN TOLERANCE
C     CHECK STRAIGHT LINE IN PHI-Z
C     R-Z FROM THREE MODULES
      L=0
      DO 310 KK=1,36
      IF(IP(KK).EQ.0)GOTO310
      JJ=IP(KK)
      L=L+1
      IF(KK.LE.12)IMM(L)=1
      IF(KK.GE.13.AND.KK.LT.25)IMM(L)=2
      IF(KK.GT.24)IMM(L)=3
C     R : ASSUMES LINEAR TO VERTEX
      RRS=(RFIT(I,1)+RFIT(J,2)+RFIT(K,3))/(Z1+Z2+Z3)
      RR=RRS*ZP(KK)
      XX(L)=ZP(KK)
      YY(L)=ATAN((DRI(JJ,KK)*SD(KK)+DWS(JJ,KK))/RR) +WW(JJ,KK)
      IF(YY(L).LT.0.0)YY(L)=YY(L)+PI2
      WT(L)=1.0
 310  CONTINUE
C     PHI CONTINUOUS
      IF(L .GT. 1)THEN
      DO320 JJ=2,L
      DP = YY(JJ)-YY(JJ-1)
      IF(DP.GT.0.) THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JJ)=YY(JJ)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JJ)=YY(JJ)+PI2
      ENDIF
 320  CONTINUE
      ENDIF
      IC=0
      DO 330 KK=1,L
      IF(IMM(KK).EQ.2)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 330  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS2,PZ2,D1,D2,D3,COV)
      IC=0
      DO 340 KK=1,L
      IF(IMM(KK).EQ.3)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 340  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS3,PZ3,D1,D2,D3,COV)
      IC=0
      DO 250 KK=1,L
      IF(IMM(KK).EQ.1)THEN
      IC=IC+1
      XXX(IC)=XX(KK)
      YYY(IC)=YY(KK)
      WWT(IC)=WT(KK)
      ENDIF
 250  CONTINUE
      CALL FTLFTW(XXX,YYY,WWT,IC,0,2,PS1,PZ1,D1,D2,D3,COV)
C     COMPARE PHI VALUES AT  MODULE CENTRE
      P1=PS1*Z1+PZ1
      P2=PS2*Z2+PZ2
      P3=PS3*Z3+PZ3
C     NO CUT ON THIS PARAMETER
C     GOOD LINK:  GET CHI , BEST TRACK PARAMETERS
      CALL FTCHKH(PCOS,PHZ,PSIN,RI,I,J,K,CHI)
C     LOOSE CUT ON CHI.
C     USE CHI TO SELECT BEST CANDIDATE IF AMBIGUITIES
      IF(CHI.GT.CHT)GOTO50
C
      LLL=LLL+1
C******************************************12/10/88********************
      IF(LLL.GT.MAXTR3)LLL=MAXTR3
      LL(LLL,1)=I
      LL(LLL,2)=J
      LL(LLL,3)=K
      RPC(LLL)=PCOS
      RPS(LLL)=PSIN
      PH(LLL)=PHZ
      CH(LLL)=CHI
      ZI(LLL)=RI
      PPA(LLL,1)=PA1
      PPA(LLL,2)=PA2
      PPA(LLL,3)=PA3
      ZZA(LLL,1)=ZA1
      ZZA(LLL,2)=ZA2
      ZZA(LLL,3)=ZA3

 50   CONTINUE
 20   CONTINUE
 10   CONTINUE
C     NEW COMPARE SECTION
C     NEW COMPARE SECTION
C     NEW COMPARE SECTION
C     NEW COMPARE SECTION
      DO 400 LOOP=1,LLL
      CHB=100000.
      KB=0
C     SELECT BEST
      DO 410 K=1,LLL
      IF(CH(K).LT.0.0)GOTO 410
      IF(LL(K,1).EQ.0)GOTO410
C     WRITE(*,*)' K ,CHI  ',K,CH(K),LL(K,1),LL(K,2),LL(K,3)
      IF(CH(K).LT.CHB)THEN
      CHB=CH(K)
      KB=K
      ENDIF
 410  CONTINUE
C     WRITE(*,*)' KB,CHIB ',KB,CHB
      IF(KB.EQ.0)GOTO499
C     COMPARE BEST WITH REMAINDER
      DO 420 K=1,LLL
      IF(K.EQ.KB)GOTO420
      IF(LL(K,1).EQ.0)GOTO420
      IF(LL(K,1).EQ.LL(KB,1))GOTO430
      IF(LL(K,2).EQ.LL(KB,2))GOTO430
      IF(LL(K,3).EQ.LL(KB,3))GOTO430
      GOTO 420
C     REMOVE LINK
 430  LL(K,1)=0
      LL(K,2)=0
C     WRITE(*,*)' REMOVE ',K
 420  CONTINUE
C     COMPARE FINISHED , MARK BEST SEGMENT USED
      CH(KB)=-CH(KB)
 400  CONTINUE
C     RESET CHI WHEN COMPARE FINISHED
 499  DO 440 LOOP=1,LLL
      IF(CH(LOOP).LT.0.0)CH(LOOP)=-CH(LOOP)
 440  CONTINUE
C
C
C
C     SET USED FLAGS
      NLLL=0
      DO 500 I=1,LLL
      IF(LL(I,1)*LL(I,2).EQ.0)GOTO500
      NLLL=NLLL+1
      IU(LL(I,1),1)=1
      IU(LL(I,2),2)=1
      IU(LL(I,3),3)=1
*------------------------------------------
C     PRINT1000,LL(I,1),LL(I,2),LL(I,3)
 1000 FORMAT('  T1,T2,T3 ',5I3)
*------------------------------------------

 500  CONTINUE
      RETURN
      END
*CMZ :  8.07/00 20/11/96  21.29.21  by  Stephen Burke
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.18  by  Stephen Burke
*CMZU:  5.03/00 24/02/94  11.50.07  by  Stephen J. Maxfield
*CMZU:  4.00/08 19/11/93  15.30.00  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.57  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.30  by  Stephen Burke
*-- Author : I.O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Organise radial line-segment finding.
*          Diagnostic histograms;
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial data:
*               points/plane :- NDP
*               drift        :- DRI
*               radius       :- RM
*               wire angle   :- WW
*               wire number  :- NW
*               wire stagger :- DWS
*
*
*HTMLO     : Describe the Output of the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTLSEG(NSS,IM)
**: FTLSEG 40000 SM. New monitoring histos.
**----------------------------------------------------------------------
C     AUTHOR:      I.O.SKILLICORN
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FSGPAR.
      COMMON/FSGPAR/DMINX, PHIT, TSCUT, SLCUT, RCUT, TSLPC,
     +              MINHTS, MINPTS, MAXCLU, LSCUT, NWIRES, IPLOT
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEND.

      COMMON /FRPAR/  DFCUT,RRCUT,CUT3,CUT4,CUT5
*    LOCAL ARRAYS
*
      DIMENSION XX(12),YY(12),YN(12)
      DIMENSION LNOS(12,MAXTRK),IUSED(MAXHTS,36),NPTS(MAXTRK)
      DIMENSION SD(12,MAXTRK),PHI(12,MAXTRK),LPRS(12,MAXTRK)
      DIMENSION PHI2(12,MAXTRK),GRAD(MAXTRK)
      DIMENSION X1(MAXTRK),Y1(MAXTRK),X2(MAXTRK),Y2(MAXTRK)
      DIMENSION XNS(MAXTRK),XNSS(MAXTRK)
      DIMENSION NPS(MAXTRK),LX1(MAXTRK),LX2(MAXTRK),NPTSP(MAXTRK)
      DIMENSION IL(MAXTRK),IFL(MAXTRK)
      DIMENSION ITRACK(12,MAXTRK),NUMPTS(MAXTRK)
      DIMENSION SDS(12,MAXTRK),FDS(12,MAXTRK)
      DIMENSION D(3,2),ISS(3)
      DIMENSION SSCHI(MAXTRK)
C     MODS 13/5/91 FOLLOW TO SAVE SPACE   VVVVVVVVVVVVVVVVVVVVVVVVV
      DIMENSION RS(12,MAXTRK,11)
      EQUIVALENCE (RS(1,1,1),PCOSL(1,1))
      EQUIVALENCE (  LNOS(1,1),RS(1,1, 1))
      EQUIVALENCE (    SD(1,1),RS(1,1, 2))
      EQUIVALENCE (   PHI(1,1),RS(1,1, 3))
      EQUIVALENCE (  LPRS(1,1),RS(1,1, 4))
      EQUIVALENCE (  PHI2(1,1),RS(1,1, 5))
      EQUIVALENCE (ITRACK(1,1),RS(1,1, 6))
      EQUIVALENCE (   SDS(1,1),RS(1,1, 7))
      EQUIVALENCE (   FDS(1,1),RS(1,1, 8))
      EQUIVALENCE ( IUSED(1,1),RS(1,1, 9))
C     ADD
      DIMENSION RSS(MAXTRK,15)
      EQUIVALENCE (RSS(1,1),R1)
      EQUIVALENCE (  NPTS(1),RSS(1, 1))
      EQUIVALENCE (  GRAD(1),RSS(1, 2))
      EQUIVALENCE (    X1(1),RSS(1, 3))
      EQUIVALENCE (    X2(1),RSS(1, 4))
      EQUIVALENCE (    Y1(1),RSS(1, 5))
      EQUIVALENCE (    Y2(1),RSS(1, 7))
      EQUIVALENCE (   XNS(1),RSS(1, 8))
      EQUIVALENCE (  XNSS(1),RSS(1, 9))
      EQUIVALENCE (   NPS(1),RSS(1,10))
      EQUIVALENCE (   LX1(1),RSS(1,11))
      EQUIVALENCE ( NPTSP(1),RSS(1,12))
      EQUIVALENCE (    IL(1),RSS(1,13))
      EQUIVALENCE (   IFL(1),RSS(1,14))
      EQUIVALENCE (NUMPTS(1),RSS(1,15))
C
CEND ADDITION  ********************************************
      DATA ISTART/0/

      PARAMETER (KN=50)
      DIMENSION IRN(KN,48),IPN(KN,48),IWC(48)
      DIMENSION SDD(12,100),NNPTS(100),CHI(100)
      DIMENSION IFP(100),ILP(100),JDD(12,100),DDD(12,100)
      DIMENSION IKILL(MAXHTS,36)
      DIMENSION LTRI(12,MAXTRK)
      DIMENSION SGTRI(12,MAXTRK)
      DIMENSION ZTRI(MAXTRK)
      DIMENSION DTRI(MAXTRK),RTRI(MAXTRK)
      DIMENSION SLTRI(MAXTRK)
      DIMENSION NL(MAXTRK)
      DIMENSION YT(12),YS(12),NY(12)
*
*     >  Chard
*     Hard-wired cuts if wanted, else take from COMMON/FSGPAR/ filled
*     by FPTINT from the FRCP bank.
*
C     MINIMUM SIZE OF CLUSTER FOR STARTING TRIPLE       FINDING
Chard MINHTS=3
C     MINIMUM NUMBER OF POINTS/TRACK SEGMENT
Chard MINPTS=4
*     but keep this to avoid array size problems!!
C     MAX SIZE OF CLUSTER FOR ANALYSIS
      MAXCLU=KN
C
Chard NWIRES= 8
C
      NT=0
      NTRAKS(IM)=0
C
C
C***********************************************************************
C     IPLOT=0 FOR NO DIAGNOSTIC T0, RMS TO LINE SEG,  PLOTS: MAX SPEED
Chard IPLOT=0
      IPLOT=1
C***********************************************************************
      DO 199 I=1,MAXHTS
      DO 199 J=1,36
      IUSED(I,J)=0
 199  IKILL(I,J)=0
C
      DO 200 I=1,48
      DO 201 J=1,KN
      IRN(J,I)=0
      IPN(J,I)=0
 201  CONTINUE
 200  CONTINUE
      DO 203 I=1,12
      DO 203 J=1,100
      JDD(I,J)=0
      DDD(I,J)=1000.
 203  SDD(I,J)=0.
      DO 204 I=1,12
      DO 204 J=1,MAXTRK
      IRPT(I,J,IM)=0
      SDRFT(I,J,IM)=0.
 204  CONTINUE
C     WRITE(*,*)' NDP ',NDP
C     DO 4999 IP=1,36
C     DO 5000 I=1,NDP(IP)
C     WRITE(*,*)' DRI,RM,NW',DRI(I,IP),RM(I,IP),NW(I,IP),I,IP
C000  CONTINUE
C999  CONTINUE


C     ENSURE ONLY 1 HIT/WIRE - TAKE MIN DRIFT HIT
      IONE=0
      IF(IONE.EQ.1)THEN
      DO 205 I=NSS,NSS+NWIRES-1
      NN=NDP(I)
      IF(NN.LE.1)GOTO205
      NNN=NN-1
      DO 206 J1=1,NNN
      J3=J1+1
      IF(DRI(J1,I).GT.900.)GOTO206
      DO 207 J2=J3,NN
      IF(DRI(J2,I).GT.900.)GOTO 207
      IF(NW(J1,I).NE.NW(J2,I))GOTO 207
C     SAME WIRE - KILL LONGER  DRIFT
      IF(DRI(J1,I).LT.DRI(J2,I))THEN
      IKILL(J2,I)=-1
      ELSE
      IKILL(J1,I)=-1
      ENDIF
 207  CONTINUE
 206  CONTINUE
 205  CONTINUE
      DO 208 I=NSS,NSS+NWIRES-1
      NN=NDP(I)
      IF(NN.LE.1)GOTO208
      DO 209 J=1,NN
      IF(IKILL(I,J).LT.0)THEN
      DRI(I,J)=DRI(I,J)+1000.
      ENDIF
 209  CONTINUE
 208  CONTINUE
      ENDIF
C
C     SUM WIRE HITS - ALL PLANES IN Z
      DO 10 I=1,48
C     CLUSTER SIZE
      IWC(I)=0
 10   CONTINUE
      DO 20 IP=NSS,NSS+NWIRES-1
      NN=NDP(IP)
      IF(NN.EQ.0)GOTO20
      DO 30 J=1,NN
      IF(DRI(J,IP).GT.900.)GOTO30
C     I=NW(J,IP)+1
C     CHANGE 9/12/92
      I=NW(J,IP)
      IF(I.LT.1)I=1
      IF(I.GT.48)I=48
      IWC(I)=IWC(I)+1
      IF(IWC(I).GT.KN)IWC(I)=KN
      IRN(IWC(I),I)=J
      IPN(IWC(I),I)=IP
 30   CONTINUE
 20   CONTINUE
C     NOW HAVE STARTING CLUSTERS
C     IWC= # HITS/WIRE
C     WRITE(*,*)' CLUSTERS '
C     PRINT 1000,IWC
 1000 FORMAT((' ',24I3))
      DO 40 I=1,48
      IF(IWC(I).EQ.0)GOTO40
      KK=IWC(I)
C     CALL HFILL(70001,FLOAT(KK)+0.1,0.,1.)
C     IRN = HIT #
CDEB  PRINT 1001,IM,I,(IRN(K,I),K=1,KK)
C     IPN = PLANE #
C      PRINT 1002,IM,I,(IPN(K,I),K=1,KK)
 1001 FORMAT(' CLUS IRN ',2I5,(2X,48I2))
 1002 FORMAT(' CLUS IPN ',2I5,(2X,48I2))
 40   CONTINUE
C     SEARCH FOR LARGEST CLUSTER
 500  CONTINUE
      MAXC=0
      IC=0
      DO 50 I=1,48
      IF(IWC(I).GT.MAXC)THEN
      MAXC=IWC(I)
      IC=I
      ENDIF
 50   CONTINUE
C     IF(IC.NE.0)CALL HFILL(70002,FLOAT(MAXC)+0.1,0.,1.)
C     WRITE(*,*)' CLUSTER FOUND  IC,MAXC ',IC,MAXC
C     CHECK FOR SUFFICIENT POINTS FOR LARGEST CLUSTER
      IF(MAXC.LT.MINHTS)THEN
C     FINISHED FOR THIS MODULE
      GOTO999
      ENDIF

CDEB  WRITE(*,*)' ANALYSE FOUND CLUSTER IC,MAXC ',IC,MAXC
C     CHECK MAX SIZE OF CLUSTER
      IF(MAXC.GT.MAXCLU)THEN
      IWC(IC)=-IWC(IC)
      GO TO 500
      ENDIF
*
*
*     DIAGNOSTIC PLOTS FOR LOW MULTIPLICITY CLUSTERS ONLY
      IDIAG=0
      IF(MAXC.LE.20)IDIAG=1
C
      CALL FTLISA(IRN(1,1),IPN(1,1),IWC(1),IC,MAXC,NSS,IM,IDIAG)
C
      GOTO500
*
*
 999  CONTINUE


*     Make Tzero, Resolution and twin-peaks checksums.
      IF(NTRAKS(IM).EQ.0)RETURN
      IF(IPLOT.EQ.0)RETURN

      DO 9000 I=1,NTRAKS(IM)
      LL=0
      FLL=0.
      NCR=0
      NWS=0
      FNN=0.

      DO 9100 J=1,12
C     PLANE #
      IP=J+NSS-1
C     POINT #
      NP=IRPT(J,I,IM)
      YT(J)=0.
      YS(J)=0.
      NY(J)=0.
      IF(NP.EQ.0)GOTO9100
      FNN=FNN+1.                                                               C
      SGN=SDRFT(J,I,IM)
      YT(J)=DRI(NP,IP)
      YS(J)=SGN
      NY(J)=NW(NP,IP)
      IF(NWS.EQ.0)THEN
C     STORE FIRST WIRE NUMBER AND DRIFT SIGN
      NWS=NW(NP,IP)
      SGNS=SDRFT(J,I,IM)
      ENDIF
      IF(NW(NP,IP).NE.NWS)GOTO9100
C     KEEP TO SAME WIRE FOR DRIFT RESIDUAL
      LL=LL+1
      XX(LL)=ZP(IP)
      YY(LL)=SGN*DRI(NP,IP)+DWS(NP,IP)
      YN(LL)=RM(NP,IP)
      IF(SGN.NE.SGNS)THEN
C     SIGN CHANGE - STORE WIRE # AT FIRST CROSS
      IF(NCR.EQ.0)WCROSS=FLOAT(J)+0.01
      NCR=NCR+1
      ENDIF
 9100 CONTINUE


C     T0 DETERMINATION - 8 WIRES
C     CHECK 4 WIRES
      DO 9010 K=0,4
C     +++- AND ---+
      IF(YS(K+1).EQ.0.)GOTO 9010
      IF(YS(K+2).EQ.0.)GOTO 9010
      IF(YS(K+3).EQ.0.)GOTO 9010
      IF(YS(K+4).EQ.0.)GOTO 9010

C     SAME WIRE
         IF(NY(K+1).EQ.NY(K+2).AND.
     1      NY(K+1).EQ.NY(K+3).AND.
     1      NY(K+1).EQ.NY(K+4))THEN

      IF(YS(K+1).EQ.YS(K+2).AND.
     1   YS(K+1).EQ.YS(K+3).AND.
     1  -YS(K+4).EQ.YS(K+1))THEN
       TZ=0.5*(YT(K+2)+YT(K+3)+YT(K+4)-YT(K+1))
*      T-zero...
      ENDIF
C     +--- AND -+++
      IF(YS(K+2).EQ.YS(K+3).AND.
     1   YS(K+2).EQ.YS(K+4).AND.
     1  -YS(K+1).EQ.YS(K+2))THEN
       TZ=0.5*(YT(K+1)+YT(K+2)+YT(K+3)-YT(K+4))
*      T-zero...
      ENDIF

C     ++-- AND --++
      IF(YS(K+1).EQ.YS(K+2).AND.
     1   YS(K+3).EQ.YS(K+4).AND.
     1  -YS(K+1).EQ.YS(K+3))THEN
      TZV=0.25*(3.*(YT(K+2)+YT(K+3))-YT(K+1)-YT(K+4))
C     CALL HFILL(90005,TZV,0.,1.)
C     IF(TZV.GT.0.0)CALL HFILL(90015,TZV,0.,1.)

      ENDIF

C     ++++ AND ----
*
      IF(YS(K+1).EQ.YS(K+2).AND.
     1   YS(K+3).EQ.YS(K+4).AND.
     1   YS(K+1).EQ.YS(K+3))THEN

*      Twin peaks...
       TZV=0.25*(3.*(YT(K+2)-YT(K+3))-YT(K+1)+YT(K+4))

*      Resolution...
       TZV=0.5*( (YT(K+4)+YT(K+1))-(YT(K+3)+YT(K+2)) )

      ENDIF

           ENDIF
 9010 CONTINUE

C     T0 DETERMINATION - 8 WIRES
C     CHECK 5 WIRES TO ENSURE SAFE SIGN CHANGE 13/8/91
      DO 9011 K=0,3
      IF(YS(K+1).EQ.0.)GOTO 9011
      IF(YS(K+5).EQ.0.)GOTO 9011
C     +++-- AND ---++
C     SAME WIRE
         IF(NY(K+1).EQ.NY(K+2).AND.
     1      NY(K+1).EQ.NY(K+3).AND.
     1      NY(K+1).EQ.NY(K+4).AND.
     1      NY(K+1).EQ.NY(K+5))THEN
      IF(YS(K+1).EQ.YS(K+2).AND.
     1   YS(K+1).EQ.YS(K+3).AND.
     1  -YS(K+4).EQ.YS(K+1).AND.
     1  -YS(K+5).EQ.YS(K+1))THEN
      TZ=0.5*(YT(K+2)+YT(K+3)+YT(K+4)-YT(K+1))
C     CALL HFILL(90004,TZ,0.,1.)


      ENDIF
C     ++--- AND --+++
      IF(YS(K+3).EQ.YS(K+4).AND.
     1   YS(K+3).EQ.YS(K+5).AND.
     1  -YS(K+2).EQ.YS(K+3).AND.
     1  -YS(K+1).EQ.YS(K+3))THEN
      TZ=0.5*(YT(K+2)+YT(K+3)+YT(K+4)-YT(K+5))
C     CALL HFILL(90004,TZ,0.,1.)


      ENDIF
           ENDIF
 9011 CONTINUE
C     NO SIGN CHANGE
C     IF(LL.GE.4.AND.NCR.EQ.0)CALLHFILL(90002,0.01,0.,1.)
C     SIGN CHANGE
C     IF(LL.GE.4.AND.NCR.NE.0)CALLHFILL(90002,WCROSS,0.,1.)
      FLL=LL
C     FIT STR. LINE TO SEGMENT IF 4 OR MORE POINTS
      IF(LL.LT.4)GOTO9000
      CALL FTLFT(XX,YY,LL,0,AT,BT,EE)
      CALL FTLFT(XX,YN,LL,0,AR,BR,ER)
C      WRITE(*,*)' EE,ER',EE,ER
      EE=SQRT(ABS(EE))
      ER=SQRT(ABS(ER))
C     RESIDUAL PLOT 18/7/92
      DO 9200 LLL=1,LL
      RESS=YY(LLL)-AT*XX(LLL)-BT
 9200 CONTINUE
C     CALL HFILL(90000,EE,0.,1.)
C     CALL HFILL(90001,ER,0.,1.)
C     RMS      TO LINE SEGMENT  DRIFT,RADIUS


C      WRITE(*,*)' AT,XX(LL/2),BT',AT,XX(LL/2),BT,EE,ER
       DA=AT*XX(LL/2)+BT
C     DRIFT AT CENTRE OF LINE SEG


 9000 CONTINUE

 9009 CONTINUE
      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.18  by  Stephen Burke
*CMZU:  4.00/08 19/11/93  15.16.38  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.57  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.30  by  Stephen Burke
*-- Author :    I. O. Skillicorn
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Find radial line-segments
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial data:
*               points/plane :- NDP
*               drift        :- DRI
*               radius       :- RM
*               wire angle   :- WW
*               wire number  :- NW
*               wire stagger :- DWS
*
*
*HTMLO     : Describe the Output of the routine
*
* Radial track segments:
*          NTRAKS segments/module
*          Hits/drift sign         :- IRPT/SDRFT
*
*
*HTMLE     : Terminates the HTML documentation
*
*
*   Small farm mod by ?
*   add SEQ BOSMDL so above might work
*   initialise RR (else DDMIN*RR test might fail?
*
C   21/01/93 301211908  MEMBER NAME  FTLISAA  (FILE46)      FVS
C   06/01/93 301081132  MEMBER NAME  FTLISA5  (FILE46)      FVS
C   08/12/92 301061503  MEMBER NAME  FTLISA2  (FILE46)      FVS
C   06/12/92 212081044  MEMBER NAME  FTLISA   (GRAPHICS)    FVS
C   04/12/92 212061354  MEMBER NAME  LISALIB  (FILE46)      FVS
C   28/11/92 212011534  MEMBER NAME  FTLISA   (FILE46)      FVS
C   28/11/92 211281327  MEMBER NAME  FTLISA   (GRAPHICS)    FVS
C   13/11/92 211281108  MEMBER NAME  FTLSEGO  (GRAPHICS)    FVS
C   13/11/92            MEMBER NAME  FTLSEGO  (FILE46)      FVS
C   04/12/91            MEMBER NAME  NEWSEG   (FILE46)      FVS
C   FROM FILE46(GRFTRAC2)
C
C   13/11/92
C   ADD SLOPE CHECK ON TRIPLES - SELECT MINIMUM SLOPE
C   REMOVE EXTRAPOLATION IN PHI
C   RCUT --->  20 CMS
C   SLCUT--->  0.1
C   TSCUT--->  0.08 (WAS 0.1)
C   DMINX--->  0.15 (WAS 0.2)
C
C   PROJECTION CUT WITH DMINX
C     VERSION FOR TRACK FINDING IN CLUSTER BY TRIPLES
      SUBROUTINE FTLISA(IRN,IPN,IWC,IC,MAXC,NSS,IM,IDIAG)
**: FTLISA 40000 SM. Initialise RR (else DDMIN*RR test might fail?).
**: FTLISA 40000 SM. Add SEQ BOSMDL so farm change might work.
**----------------------------------------------------------------------
**: FTLISA 30907 RP. Farm changes.
**----------------------------------------------------------------------
C
C     PROCEDURE:-
C  1  FORM CLUSTERS BASED ON WIRE HITS
C  2  SELECT LARGEST CLUSTER . END IF TOO FEW  HITS
C     OR ALL CLUSTERS HAVE BEEN EXAMINED.
C  3  SEARCH FOR  TRIPLES IN CLUSTER  (UNUSED POINTS ONLY)
C     IF NO TRIPLES GOTO2
C  4  JOIN TRIPLES TO FORM LINE SEGMENTS
C  5  SELECT LONGEST LINE SEGMENT
C  6  EXTEND THIS LINE SEGMENT BY STRAIGHT LINE PROJECTION
C     IN DRIFT (AND R )  WITHIN CLUSTER. MARK USED POINTS.
C  7  EXTEND FURTHER BY PROJECTION IN PHI INTO NEIGHBOURING
C     CLUSTERS . MARK USED POINTS .
C  8  REEXAMINE LARGEST CLUSTER . IF INSUFFICIENT POINTS
C     ELIMINATE CLUSTER AND  GOTO 2 . OTHERWISE GOTO 3.
C
C
C     AUTHOR:      I.O.SKILLICORN
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEEP,FSGPAR.
      COMMON/FSGPAR/DMINX, PHIT, TSCUT, SLCUT, RCUT, TSLPC,
     +              MINHTS, MINPTS, MAXCLU, LSCUT, NWIRES, IPLOT
*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.

      COMMON /FRPAR/  DFCUT,RRCUT,CUT3,CUT4,CUT5
*    LOCAL ARRAYS
*
      DIMENSION XX(12),YY(12),YN(12)
      DIMENSION LNOS(12,MAXTRK),IUSED(MAXHTS,36),NPTS(MAXTRK)
      DIMENSION SD(12,MAXTRK),PHI(12,MAXTRK),LPRS(12,MAXTRK)
      DIMENSION PHI2(12,MAXTRK),GRAD(MAXTRK)
      DIMENSION X1(MAXTRK),Y1(MAXTRK),X2(MAXTRK),Y2(MAXTRK)
      DIMENSION XNS(MAXTRK),XNSS(MAXTRK)
      DIMENSION NPS(MAXTRK),LX1(MAXTRK),LX2(MAXTRK),NPTSP(MAXTRK)
      DIMENSION IL(MAXTRK),IFL(MAXTRK)
      DIMENSION ITRACK(12,MAXTRK),NUMPTS(MAXTRK)
      DIMENSION SDS(12,MAXTRK),FDS(12,MAXTRK)
      DIMENSION D(3,2),ISS(3)
      DIMENSION SSCHI(MAXTRK)
C     MODS 13/5/91 FOLLOW TO SAVE SPACE   VVVVVVVVVVVVVVVVVVVVVVVVV
      DIMENSION RS(12,MAXTRK,11)
      EQUIVALENCE (RS(1,1,1),PCOSL(1,1))
      EQUIVALENCE (  LNOS(1,1),RS(1,1, 1))
      EQUIVALENCE (    SD(1,1),RS(1,1, 2))
      EQUIVALENCE (   PHI(1,1),RS(1,1, 3))
      EQUIVALENCE (  LPRS(1,1),RS(1,1, 4))
      EQUIVALENCE (  PHI2(1,1),RS(1,1, 5))
      EQUIVALENCE (ITRACK(1,1),RS(1,1, 6))
      EQUIVALENCE (   SDS(1,1),RS(1,1, 7))
      EQUIVALENCE (   FDS(1,1),RS(1,1, 8))
      EQUIVALENCE ( IUSED(1,1),RS(1,1, 9))
C     ADD
      DIMENSION RSS(MAXTRK,15)
      EQUIVALENCE (RSS(1,1),R1)
      EQUIVALENCE (  NPTS(1),RSS(1, 1))
      EQUIVALENCE (  GRAD(1),RSS(1, 2))
      EQUIVALENCE (    X1(1),RSS(1, 3))
      EQUIVALENCE (    X2(1),RSS(1, 4))
      EQUIVALENCE (    Y1(1),RSS(1, 5))
      EQUIVALENCE (    Y2(1),RSS(1, 7))
      EQUIVALENCE (   XNS(1),RSS(1, 8))
      EQUIVALENCE (  XNSS(1),RSS(1, 9))
      EQUIVALENCE (   NPS(1),RSS(1,10))
      EQUIVALENCE (   LX1(1),RSS(1,11))
      EQUIVALENCE ( NPTSP(1),RSS(1,12))
      EQUIVALENCE (    IL(1),RSS(1,13))
      EQUIVALENCE (   IFL(1),RSS(1,14))
      EQUIVALENCE (NUMPTS(1),RSS(1,15))
C
CEND ADDITION  ********************************************
      DATA ISTART/0/

      PARAMETER (KN=50)
      DIMENSION IRN(KN,48),IPN(KN,48),IWC(48)
      DIMENSION SDD(12,100),NNPTS(100),CHI(100)
      DIMENSION IFP(100),ILP(100),JDD(12,100),DDD(12,100)
      DIMENSION IKILL(MAXHTS,36)
      DIMENSION LTRI(12,MAXTRK)
      DIMENSION SGTRI(12,MAXTRK)
      DIMENSION ZTRI(MAXTRK)
      DIMENSION DTRI(MAXTRK),RTRI(MAXTRK)
      DIMENSION SLTRI(MAXTRK)
      DIMENSION NL(MAXTRK)
      DIMENSION YT(12),YS(12),NY(12)
      PI2=6.283185307
C
C     NO DIAGNOSTIC HISTOGRAMS  IDIAG=0
      IDIAG=0
C
*
*     >  Chard
*     Hard-wired cuts if wanted, else take from COMMON/FSGPAR/ filled
*     by FPTINT from the FRCP bank.
*
C     CUTS
C     MAXIMUM  DISTANCE ( IN DRIFT) FOR DIGITISING
C     TO BE ASSOCIATED WITH TRIPLE(S)
C     IE ROAD WIDTH IS 2.*DMINX  (CMS.)
C     SHOULD BE LESS THAN TWO-TRACK RESOLUTION  0.2 CMS
C     AND LESS THAN 4*STAGGER
Chard DMINX=0.1
C
Chard PROJ=0.0
      PROJ=1.0
C     DMINX=DFCUT
C     MAXIMUM  DISTANCE ( IN PHI  ) FOR DIGITISING
C     TO BE ASSOCIATED WITH CLUSTER = PROJ*DMINX/R
C
C     MINIMUM SIZE OF CLUSTER FOR STARTING TRIPLE       FINDING
Chard MINHTS=3
C
C     MINIMUM NUMBER OF POINTS/TRACK SEGMENT
Chard MINPTS=4
C
C     MAX SIZE OF CLUSTER FOR ANALYSIS
      MAXCLU=KN
C
C     ABS((D1+D3)/2 -D2 ).LT.TSCUT FOR TRIPLE(OPEN FROM 0.08)
Chard TSCUT=0.10
C     IN JOINING TRIPLES ALL POINTS MUST LIE WITHIN +- TSCUT
C     OF FIRST AND LAST POINTS OF TRIPLES TO BE JOINED
C
C
C     MAX TRIPLE SLOPE- CORRESPONDS TO 0.25 GEV(OPEN FROM 0.25)
Chard TSLPC=0.5

C     SLOPE CUT FOR JOINING TRIPLES
Chard SLCUT=0.15
C
C     MIN LENGTH OF SEGMENT BEFORE EXTENSION BY PROJECTION
Chard LSCUT=3
C
C     CUT IN R FOR TRIPLE AND PROJECTION(OPEN FROM 20.)
Chard RCUT=50.
C
C     RCUT=RRCUT
      IF(ISTART.EQ.0)THEN
      ISTART=1
      Write(*,*)'    '
      Write(*,*)'         FTREC Pattern recognition'
      Write(*,*)'         Using ftlisa '
      Write(*,*)'         Dminx  = ',DMINX
      Write(*,*)'         Proj   = ',PROJ
      Write(*,*)'         Tscut  = ',TSCUT
      Write(*,*)'         Tslpc  = ',TSLPC
      Write(*,*)'         Slcut  = ',SLCUT
      Write(*,*)'         Rcut   = ',RCUT
      Write(*,*)'    '
C     DIAGNOSTIC HISTOGRAMS
      IF(IDIAG.NE.0) THEN
      CALL STEXT(9000,4,' TRIPLE DISTANCE DEFINE -TSCUT ')
      CALL BHS(9000,0,50,-0.5,0.5 )
      CALL STEXT(9001,4,' TRIPLE SLOPE -TSLPC         ')
      CALL BHS(9001,0,50,-1.0,1.0 )
      CALL STEXT(9002,4,' TRIPLE DISTANCE JOIN 1-TSCUT         ')
      CALL BHS(9002,0,50,-0.5,0.5 )
      CALL STEXT(9003,4,' TRIPLE DISTANCE JOIN 2-TSCUT         ')
      CALL BHS(9003,0,50,-0.5,0.5 )
      CALL STEXT(9004,4,' PROJECT- DMINX        ')
      CALL BHS(9004,0,50,-0.51,0.49 )
      CALL STEXT(9005,4,' PROJECT IN PHI - DMINX*PROJ   ')
      CALL BHS(9005,0,50,-1.0,1.0 )
      CALL STEXT(9006,4,' TRIPLE SLOPE CUT - SLCUT     ')
      CALL BHS(9006,0,50,-0.5,0.5 )
      CALL STEXT(9007,4,' PROJECT- DMINX DURING SELECTION       ')
      CALL BHS(9007,0,50,0.00,1.00 )
      CALL STEXT(9008,4,' PROJECT- DMINX FINAL      ')
      CALL BHS(9008,0,50,0.00,0.20 )
      CALL STEXT(9009,4,' RESIDUALS TO FINAL SEGMENT')
      CALL BHS(9009,0,50,-0.10,0.10 )
      CALL STEXT(9010,4,' RESIDUALS TO FINAL SEGMENT')
      CALL BHS(9010,0,50, 0.0,0.20 )
      CALL STEXT(9011,4,' RMS OF FIT ')
      CALL BHS(9011,0,50, 0.0,0.10 )
      ENDIF
      ENDIF

C
C     OPEN EXTRAPOLATION FOR CLEAN WEDGES
C
      SDMINX=DMINX
      IF(MAXC.LT.15)DMINX=DMINX*2.
C
      NT=0
      NTIN=NTRAKS(IM)
C
Chard NWIRES= 12
C

C     SEARCH FOR TRIPLES IN CLUSTER
 500  CONTINUE
      DO 203 I=1,12
      DO 203 J=1,100
      JDD(I,J)=0
      DDD(I,J)=1000.
 203  SDD(I,J)=0.






      NTRI=0
      DDMIN=1000.
      DO 110 K1=1,MAXC-2
      LJ1=IRN(K1,IC)
      LP1=IPN(K1,IC)
C     WRITE(*,*)' LJ1 LP1',LJ1,LP1
      IF(DRI(LJ1,LP1).GT.900.)GOTO110
      IF(IUSED(LJ1,LP1).GT.0)GOTO110
      KK1=K1+1
      DO 120 K2=KK1,MAXC-1
      LP2=IPN(K2,IC)
      IF(LP2.NE.LP1+1)GOTO120
      LJ2=IRN(K2,IC)
      IF(DRI(LJ2,LP2).GT.900.)GOTO120
      IF(IUSED(LJ2,LP2).GT.0)GOTO120
      KK2=K2+1
C     WRITE(*,*)' LJ2 LP2',LJ2,LP2
      IF(IUSED(LJ2,LP2).GT.0)GOTO120
      DO 130 K3=KK2,MAXC
      LP3=IPN(K3,IC)
      IF(LP3.NE.LP1+2)GOTO130
      LJ3=IRN(K3,IC)
      IF(DRI(LJ3,LP3).GT.900.)GOTO130
      IF(IUSED(LJ3,LP3).GT.0)GOTO130
C     WRITE(*,*)' LJ3 LP3',LJ3,LP3
C     NOW HAVE POSSIBLE TRIPLE - LOOP OVER SIGNS
      DO 140 IS1=1,2
      S1=1.
      IF(IS1.EQ.2)S1=-1.
      D1=S1*DRI(LJ1,LP1)+DWS(LJ1,LP1)
      R1=RM(LJ1,LP1)
      DO 141 IS2=1,2
      S2=1.
      IF(IS2.EQ.2)S2=-1.
      D2=S2*DRI(LJ2,LP2)+DWS(LJ2,LP2)
      R2=RM(LJ2,LP2)
C     MAX TRIPLE SLOPE
      IF(ABS(D1-D2).GT.TSLPC)GOTO141
      DO 142 IS3=1,2
      S3=1.
      IF(IS3.EQ.2)S3=-1.
      D3=S3*DRI(LJ3,LP3)+DWS(LJ3,LP3)
      R3=RM(LJ3,LP3)
      DD=   ((D1+D3)*0.5-D2)
      IF(IDIAG.EQ.1)CALL SHS(9000,0,DD)
      IF(IDIAG.EQ.1)CALL SHS(9001,0,(D3-D1)*0.5)
      DD=ABS(DD)
      DR=ABS((R1+R3)*0.5-R2)
      DS=ABS(D3-D1)
C     MAX SLOPE OF TRIPLE
      IF(DS.GT.2.*TSLPC)GOTO142
C     DDA=  (D1+D3)*0.5-D2
      IF(DD.LT.TSCUT.AND.DR.LT.RCUT)THEN
      SS1=S1
      SS2=S2
      SS3=S3
      II=K1
      JJ=K2
      KK=K3
      RRS=(R1+R2+R3)*0.33333333
C     CALL HFILL(70004,DDAS,0.,1.)
      NTRI=NTRI+1
      IF(NTRI.GT.MAXTRK)NTRI=MAXTRK
C     POINTERS TO CLUSTER
      LTRI(1,NTRI)=II
      LTRI(2,NTRI)=JJ
      LTRI(3,NTRI)=KK
C     WRITE(*,*)' TRI ',NTRI,II,JJ,KK

C     NUMBER POINTERS
      NL(NTRI)=3
C     DRIFT SIGN
      SGTRI(1,NTRI)=SS1
      SGTRI(2,NTRI)=SS2
      SGTRI(3,NTRI)=SS3
C     Z OF CENTRE OF LAST TRIPLE
      KPP=IPN(JJ,IC)
      ZTRI(NTRI)=ZP(KPP)
      D1=SS1*DRI(IRN(II,IC),IPN(II,IC))+DWS(IRN(II,IC),IPN(II,IC))
      D2=SS2*DRI(IRN(JJ,IC),IPN(JJ,IC))+DWS(IRN(JJ,IC),IPN(JJ,IC))
      D3=SS3*DRI(IRN(KK,IC),IPN(KK,IC))+DWS(IRN(KK,IC),IPN(KK,IC))
      RZ=1./(ZP(LP3)-ZP(LP1))
      DSS=(D1+D2+D3)*0.33333333
      SLPS=(D3-D1)*RZ
C     SLOPE OF TRIPLE
      SLTRI(NTRI)=SLPS
C     MEAN DRIFT
      DTRI(NTRI)=DSS
C     MEAN R
      RTRI(NTRI)=RRS
      ENDIF
 142  CONTINUE
 141  CONTINUE
 140  CONTINUE
 130  CONTINUE
 120  CONTINUE
 110  CONTINUE
C     WRITE(*,*)' FTLISA  NTRI ',NTRI
      IF(NTRI.EQ.0)THEN
      IWC(IC)=-IWC(IC)
      GOTO999
      ENDIF
*
*
*
*
*
*
C     COMBINE TRIPLES TO FORM TRACK
      IF(NTRI.GE.2)THEN
      DO 300 I=1,NTRI-1
      IF(ZTRI(I).LT.0.)GOTO300
      K=I+1
      DO 310 J=K,NTRI
      IF(ZTRI(J).LT.0.)GOTO310
      IF(ABS(RTRI(I)-RTRI(J)).GT.RCUT)GOTO310
C     CHECK FOR TWO POINTS IN COMMON WITH SAME DRIFT SIGNS
C     EXTEND TRIPLE BY ONE POINT
      IF(LTRI(NL(I)-1,I).EQ.LTRI(1,J).AND.
     1 LTRI(NL(I),I).EQ.LTRI(2,J))THEN
      IF(SGTRI(NL(I)-1,I).EQ.SGTRI(1,J).AND.
     1 SGTRI(NL(I),I).EQ.SGTRI(2,J))THEN
C     TWO POINTS AGREE,ADD FINAL POINT AFTER CHECKING
C     THAT ALL POINTS ARE WITHIN TOLERANCE OF LINE
C     CONNECTED TO FIRST AND LAST POINTS OF POTENTIAL
C     JOINED SEGMENTS
C     FIRST POINT FIRST TRIPLE
      II=LTRI(1,I)
C     LAST POINT SECOND TRIPLE
      KK=LTRI(NL(J),J)
C     POINTS
      I1=IRN(II,IC)
      K1=IRN(KK,IC)
C     PLANES
      IP=IPN(II,IC)
      KP=IPN(KK,IC)
C     DRIFT SIGNS
      S1=SGTRI(1,I)
      S3=SGTRI(NL(J),J)
      D1=S1*DRI(I1,IP)+DWS(I1,IP)
      D3=S3*DRI(K1,KP)+DWS(K1,KP)
      Z1=ZP(IP)
      Z3=ZP(KP)
      SLP=(D3-D1)/(Z3-Z1)

C     CHECK POINTS AGREE - FIRST TRIPLE
      DO 320 N1=2,NL(I)
      II1=LTRI(N1,I)
      I1=IRN(II1,IC)
      IP1=IPN(II1,IC)
      S11=SGTRI(N1,I)
C     MEASURED
      D11=S11*DRI(I1,IP1)+DWS(I1,IP1)
      ZZ=ZP(IP1)
C     PREDICTED
      DP=D1+(ZZ-Z1)*SLP
      IF(IDIAG.EQ.1)CALL SHS(9002,0,DP-D11)
C     WRITE(*,*)' T-J 1 ',N1,ABS(DP-D11),DMINX
      IF(ABS(DP-D11).GT.TSCUT)GOTO310
  320 CONTINUE


C     CHECK POINTS AGREE - SECOND TRIPLE
      DO 330 N1=1,NL(J)-1
      II1=LTRI(N1,J)
      I1=IRN(II1,IC)
      IP1=IPN(II1,IC)
      S11=SGTRI(N1,J)
      D11=S11*DRI(I1,IP1)+DWS(I1,IP1)
      ZZ=ZP(IP1)
      DP=D1+(ZZ-Z1)*SLP
      IF(IDIAG.EQ.1)CALL SHS(9002,0,DP-D11)
C     WRITE(*,*)' T-J 2 ',N1,ABS(DP-D11),DMINX
      IF(ABS(DP-D11).GT.TSCUT)GOTO310
  330 CONTINUE
C     WRITE(*,*)' ADD I,J ',I,J
C     PRINT1100, I,(LTRI(III, I),III=1,NL( I))
C     PRINT1100, J,(LTRI(III, J),III=1,NL( J))
      NL(I)=NL(I)+1
      IF(NL(I).GT.12)NL(I)=12
      LTRI(NL(I),I)=LTRI(3,J)
      SGTRI(NL(I),I)=SGTRI(3,J)
CDEB  PRINT1100, I,(LTRI(III, I),III=1,NL( I))
C     REPLACE Z,SLOPE,MEAN DRIFT
      ZTRI(I)=ZTRI(J)
      SLTRI(I)=SLTRI(J)
      DTRI(I)=DTRI(J)
      RTRI(I)=RTRI(J)
C     MARK J AS USED
      ZTRI(J)=-100.
      GOTO310
      ENDIF
      ENDIF
      NOMISS=1
      IF(NOMISS.EQ.1)THEN
C     ALLOW FOR ONE MISSING DIGITIZING, JOIN ACROSS GAP
      IF(ZTRI(J)-ZTRI(I).LT.4.5.AND.
     1   ZTRI(J)-ZTRI(I).GT.3.5)THEN
C     CALL HFILL(70003,(SLTRI(I)-SLTRI(J)),0.,1.)
      IF(IDIAG.EQ.1)CALL SHS(9006,0,SLTRI(I)-SLTRI(J))
      IF(ABS(SLTRI(I)-SLTRI(J)).GT.SLCUT)GOTO310
      IF(ABS( (DTRI(I)-DTRI(J))/(ZTRI(I)-ZTRI(J)) -SLTRI(I)).GT.
     1 SLCUT)GOTO310
      IF(ABS( (DTRI(I)-DTRI(J))/(ZTRI(I)-ZTRI(J)) -SLTRI(J)).GT.
     1 SLCUT)GOTO310
      IF(ABS(RTRI(I)-RTRI(J)).GT.RCUT)GOTO310
C     THEN
C     CHECK THAT ALL POINTS ARE WITHIN TOLERANCE OF LINE
C     CONNECTED TO FIRST AND LAST POINTS OF POTENTIAL
C     JOINED SEGMENTS
C     FIRST POINT FIRST TRIPLE
      II=LTRI(1,I)
C     LAST POINT SECOND TRIPLE
      KK=LTRI(NL(J),J)
C     POINTS
      I1=IRN(II,IC)
      K1=IRN(KK,IC)
C     PLANES
      IP=IPN(II,IC)
      KP=IPN(KK,IC)
C     DRIFT SIGNS
      S1=SGTRI(1,I)
      S3=SGTRI(NL(J),J)
      D1=S1*DRI(I1,IP)+DWS(I1,IP)
      D3=S3*DRI(K1,KP)+DWS(K1,KP)
      Z1=ZP(IP)
      Z3=ZP(KP)
      SLP=(D3-D1)/(Z3-Z1)

C     CHECK POINTS AGREE - FIRST TRIPLE
      DO 340 N1=2,NL(I)
      II1=LTRI(N1,I)
      I1=IRN(II1,IC)
      IP1=IPN(II1,IC)
      S11=SGTRI(N1,I)
C     MEASURED
      D11=S11*DRI(I1,IP1)+DWS(I1,IP1)
      ZZ=ZP(IP1)
C     PREDICTED
      DP=D1+(ZZ-Z1)*SLP
      IF(IDIAG.EQ.1)CALL SHS(9003,0,DP-D11)
C     WRITE(*,*)' T-J 1 ',N1,ABS(DP-D11),DMINX
      IF(ABS(DP-D11).GT.TSCUT)GOTO310
  340 CONTINUE


C     CHECK POINTS AGREE - SECOND TRIPLE
      DO 350 N1=1,NL(J)-1
      II1=LTRI(N1,J)
      I1=IRN(II1,IC)
      IP1=IPN(II1,IC)
      S11=SGTRI(N1,J)
      D11=S11*DRI(I1,IP1)+DWS(I1,IP1)
      ZZ=ZP(IP1)
      DP=D1+(ZZ-Z1)*SLP
      IF(IDIAG.EQ.1)CALL SHS(9003,0,DP-D11)
C     WRITE(*,*)' T-J 2 ',N1,ABS(DP-D11),DMINX
      IF(ABS(DP-D11).GT.TSCUT)GOTO310
  350 CONTINUE





C     JOIN
      DO 315 L=1,NL(J)
      NL(I)=NL(I)+1
      LTRI(NL(I),I)=LTRI(L,J)
      SGTRI(NL(I),I)=SGTRI(L,J)
 315  CONTINUE
      ZTRI(I)=ZTRI(J)
      SLTRI(I)=SLTRI(J)
      DTRI(I)=DTRI(J)
C     FLAG TRIPLE AS JOINED
      ZTRI(J)=-100.
      ENDIF
      ENDIF
 310  CONTINUE
 300  CONTINUE
      ENDIF
*
*     NOW HAVE JOINED TRIPLES - FIT
*
      DO 62 KD=1,100
      NNPTS(KD)=0
      CHI(KD)=0.
      DO 62 J1=1,12
      JDD(J1,KD)=0
      DDD(J1,KD)=1000.
 62   SDD(J1,KD)=0.
      KCC=0

C     WRITE(*,*)' NTRI TOT BEFORE DO 100 LOOP ',NTRI
      DO 100 KC=1,NTRI
      IF(ZTRI(KC).LT.0.0)GOTO100
C     PICK UP POINTS IN EXTENDED TRIPLE AND FIT STR LINE
      LL=0
C     WRITE(*,*)' FTLISA JOINED TRIPLES -NL ',KC,NL(KC)
      DO 400 II=1,NL(KC)
      JJ=LTRI(II,KC)
      I=IRN(JJ,IC)
      IP=IPN(JJ,IC)
      SGN=SGTRI(II,KC)
      DR=SGN*DRI(I,IP)+DWS(I,IP)
      LL=LL+1
      XX(LL)=ZP(IP)
      YY(LL)=DR
  400 CONTINUE
      CALLFTLFT(XX,YY,LL,0,TS,TI,EE)
*
*
*
C
C
      KCC=KCC+1
C     WRITE(*,*)' KCC ',KCC
      IF(KCC.GT.99)THEN
C     WRITE(*,*)' KCC AT LIMIT - FTLISA '
      KCC=100
      GOTO100
      ENDIF
      DO 410 II=1,NL(KC)
      JJ=LTRI(II,KC)
      I=IRN(JJ,IC)
      IP=IPN(JJ,IC)
      SGN=SGTRI(II,KC)
      DIFF=ABS(YY(II)-TS*XX(II)-TI)
      JPP=IP-NSS+1
      SDD(JPP,KCC)=SGN
      JDD(JPP,KCC)=I
      DDD(JPP,KCC)=DIFF
 410  CONTINUE
C     NOW LOOK FOR OTHER POINTS IN CLUSTER TO FILL
C     GAPS IN SEGMENT
      DO 60 II=1,MAXC
      I=IRN(II,IC)
      J=I
      IP=IPN(II,IC)
      IF(IUSED(I,IP).GT.0)GOTO60
      JPP=IP-NSS+1
C     IF POINT ON PLANE EXISTS IN TRIPLE GOTO60
      IF(JDD(JPP,KCC).NE.0)GOTO60
C     CHECK POINT IN R
      DR=ABS(RM(I,IP)-RTRI(KC))
      IF(DR.GT.RCUT)GOTO60
      ZZ=ZP(IP)
C     PREDICT DRIFT AT THIS Z
      DP=TS*ZZ+TI
      YN(1)= DRI(I,IP)+DWS(I,IP)
      YN(2)=-DRI(I,IP)+DWS(I,IP)
      DDMIN=1000.
      DO 61 IS=1,2
      IF(IDIAG.EQ.1)CALL SHS(9004,0,YN(IS)-DP)
      DD=ABS(YN(IS)-DP)
      DDA=(YN(IS)-DP)
      IF(DD.LT.DDMIN)THEN
      DDMIN=DD
      DDAS=DDA
      ISN=IS
      ENDIF
 61   CONTINUE
      IF(IDIAG.EQ.1)CALL SHS(9007,0,DDMIN)
C     IF(ABS(DDAS).GT.0.00001)CALL HFILL(70005,DDAS,0.,1.)
      IF(DDMIN.LT.DMINX)THEN
C     GOOD POINT
                       IF(DDMIN.LT.DDD(JPP,KCC))THEN
C      CLOSER TO LINE THAN PREVIOUS GOOD POINT - STORE
C
C
         IF(ISN.EQ.1)THEN
         SDD(JPP,KCC)=1.0
         JDD(JPP,KCC)=J
         DDD(JPP,KCC)=DDMIN
         ELSE
         SDD(JPP,KCC)=-1.0
         JDD(JPP,KCC)=J
         DDD(JPP,KCC)=DDMIN
         ENDIF
C
                       ENDIF
      ENDIF
C     WRITE(*,*)' I1,KCC,JPP,SDD ',I1,KCC,JPP,SDD(JPP,KCC)
 60   CONTINUE
      NNPTS(KCC)=0
      CHI(KCC)=0.
      DO 63 KKK=1,12
      IF(SDD(KKK,KCC).NE.0.)NNPTS(KCC)=NNPTS(KCC)+1
      IF(SDD(KKK,KCC).NE.0.)CHI(KCC)=CHI(KCC)+DDD(KKK,KCC)**2/.004
      IF(SDD(KKK,KCC).EQ.0.)GOTO63
      IF(IDIAG.EQ.1)CALL SHS(9008,0,DDD(KKK,KCC))
 63   CONTINUE

      IF(NNPTS(KCC).NE.0)CHI(KCC)=CHI(KCC)/FLOAT(NNPTS(KCC))
C      PRINT 1003,KCC,NNPTS(KCC),CHI(KCC),(JDD(I2,KCC),I2=1,12)
C     PRINT 1103,KCC,NNPTS(KCC),CHI(KCC),(SDD(I2,KCC),I2=1,12)
 1003 FORMAT(' JDD',2I3,1X,F5.3,12I3  )
 1103 FORMAT(' SDD',2I3,2X,F5.3,12F3.0)
 100  CONTINUE
C     WRITE(*,*)' AFTER DO 100 LOOP KCC',KCC

C     SELECT BEST LINE - LONGEST OR BEST CHI
C     WEIGHT=#POINTS
      WTMAX=0.
      IIG=0
      DO 70 I=1,KCC
      WT=FLOAT(NNPTS(I))
       IF((WT-WTMAX).GT.0)THEN
C     ONE OR MORE POINTS EXCESS - SELECT ON POINTS
      WTMAX=WT
      IIG=I
      ELSEIF((WT.EQ.WTMAX).AND.IIG.NE.0)THEN
C     SAME NUMBER POINTS     - SELECT ON CHI
        IF(CHI(I).LT.CHI(IIG))THEN
        WTMAX=WT
        IIG=I
        ENDIF
      ENDIF
 70   CONTINUE

      IF(IIG.EQ.0.OR.NNPTS(IIG).LT.MINPTS)THEN
C     BAD CLUSTER - LT    MINPTS POINTS
      IWC(IC)=-IWC(IC)
C     WRITE(*,*)' BAD CLUSTER LT MINPTS'
      GOTO999
      ENDIF
C     AT THIS POINT WE HAVE A GOOD SEGMENT
C     FILL OUTPUT BANK FOR FOUND SEGMENT
      NTRAKS(IM)=NTRAKS(IM)+1
      IF(NTRAKS(IM).GT.MAXTRK)NTRAKS(IM)=MAXTRK
      NT=NTRAKS(IM)
C     WRITE(*,*)' NTRAKS(IM) ',NT
      JPPMIN=1000
      JPPMAX=0

      RMEAN=0.
      FNN=0.

      DO 80 I=1,12
      JP=I+NSS-1
CDEB  WRITE(*,*)' I,JP,IIG ',I,JP,IIG,SDD(I,IIG)
      IF(SDD(I  ,IIG).EQ.0.)GOTO80
      IF(I  .LT.JPPMIN)THEN
      JPPMIN=I
      JMIN=JDD(I,IIG)
      ENDIF
      IF(I.GT.JPPMAX)THEN
      JPPMAX=I
      JMAX=JDD(I,IIG)
      ENDIF
      J=JDD(I,IIG)
      IRPT(I  ,NT,IM)=JDD(I  ,IIG)
      SDRFT(I  ,NT,IM)=SDD(I  ,IIG)
      IUSED(J,JP)=1

      RMEAN=RMEAN+RM(J,JP)
      FNN=FNN+1.

 80   CONTINUE
      IF(JPPMAX.EQ.0.OR.JPPMIN.EQ.1000)THEN
C      WRITE(*,*)' JPPMAX=0 OR JPPMIN=1000 '
      NTRAKS(IM)=NTRAKS(IM)-1
      GOTO999
      ENDIF

      RMEAN=RMEAN/FNN

C      WRITE(*,*)' OUTPUT BANK  BEFORE PROJECTION'
C      PRINT 1014,IM,NT,(IRPT(I1,NT,IM),I1=1,12)
 1004 FORMAT(' IRPT ',I5,1X,12I3)
CDEB  PRINT 1015,IM,NT,(SDRFT(I1,NT,IM),I1=1,12)
 1005 FORMAT(' SDRFT',I5,2X,12F3.0)
C     LOOK FOR CLUSTER ON NEARBY WIRES
C     CALCULATE PARAMETERS FOR PROJECTION IN PHI
C     UNLESS FULL LINE SEGMENT
      IF(JPPMIN.EQ.1.AND.JPPMAX.EQ.NWIRES)GOTO998
      JMIN=JDD(JPPMIN,IIG)
      JP=JPPMIN+NSS-1
      D1=SDD(JPPMIN,IIG)*DRI(JMIN,JP)+DWS(JMIN,JP)

      PHI1=ATAN(D1/RMEAN      )+WW(JMIN,JP)

      Z1=ZP(JP)
C
      JMAX=JDD(JPPMAX,IIG)
      JP=JPPMAX+NSS-1
      D2=SDD(JPPMAX,IIG)*DRI(JMAX,JP)+DWS(JMAX,JP)

      PHI3=ATAN(D2/RMEAN      )+WW(JMAX,JP)

      Z2=ZP(JP)
      SLP=(PHI3-PHI1)/(Z2-Z1)
C     CHECK ADJACENT WIRE - LOWER NUMBER- SAVE IC
      ICS=IC
C     IF IC=1 EXAMINE 48 AS LOWER NUMBER
C     IF(IC.EQ.1)IC=49
      IF((IC-1).GT.0)THEN
C     NOTE IABS BECAUSE THERE COULD BE USEFUL POINTS THAT DO NOT FORM TR
      IF(IABS(IWC(IC-1)).GT.0)THEN
      DO 85 I=1,IABS(IWC(IC-1))
      J=IRN(I,IC-1)
      JPP=IPN(I,IC-1)-NSS+1
      IF(JPP.LT.JPPMIN.OR.JPP.GT.JPPMAX)THEN
C     CHECK PHI CONTINUITY
      JP=IPN(I,IC-1)
      IF(IUSED(J,JP).GT.0)GOTO85
      ZZ=ZP(JP)
C     PREDICT PHI
      PHIP=PHI1+(ZZ-Z1)*SLP
      D1= DRI(J,JP)+DWS(J,JP)
      D2=-DRI(J,JP)+DWS(J,JP)

      YN(1)=ATAN(D1/RMEAN   )+WW(J,JP)
      YN(2)=ATAN(D2/RMEAN   )+WW(J,JP)

CDEB  WRITE(*,*)' LOW CLUSTER PHI ',PHIP,YN(1),YN(2)
      DDMIN=1000.
      DO 851 IS=1,2
      DD =ABS(YN(IS)-PHIP)
C     DD2=ABS(YN(IS)-PHIP+PI2)
C     DD2=ABS(YN(IS)-PHIP-PI2)
C     DD=AMIN1(DD1,DD2,DD3)
      DDA=(YN(IS)-PHIP)
      IF(DD.LT.DDMIN)THEN
      DDMIN=DD
      DDAS=DDA

      RR=RMEAN

      ISN=IS
      ENDIF
 851  CONTINUE
      IF(IDIAG.EQ.1)CALL SHS(9005,0,(YN(ISN)-PHIP)*RM(J,JP))
C     CALL HFILL(70006,DDAS,0.,1.)
      IF(DDMIN*RR.GT.DMINX*PROJ)GOTO85
C     GOOD POINT - CONT. IN PHI
      IF(ISN.EQ.1)SDRFT(JPP,NT,IM)=1.
      IF(ISN.EQ.2)SDRFT(JPP,NT,IM)=-1.
      IRPT(JPP,NT,IM)=J
      IUSED(J,JP)=1
      ENDIF
 85   CONTINUE
CDEB  WRITE(*,*)' OUTPUT BANK AFTER ADDING LOWER CLUSTER'
CDEB  PRINT 1004,NT,(IRPT(I1,NT,IM),I1=1,12)
C1004 FORMAT(' IRPT ',I5,1X,12I3)
CDEB  PRINT 1005,NT,(SDRFT(I1,NT,IM),I1=1,12)
C1005 FORMAT(' SDRFT',I5,1X,12F3.0)
      ENDIF
      ENDIF
C     RESET IC IN CASE CHANGED
      IC=ICS
C     CHECK ADJACENT WIRE - HIGHER NUMBER
C     IF IC=48 EXAMINE IC=1 AS HIGHER NUMBER
C     IF(IC.EQ.48)IC=0
      IF((IC+1).LE.48)THEN
      IF(IABS(IWC(IC+1)).GT.0)THEN
      DO 86 I=1,IABS(IWC(IC+1))
      J=IRN(I,IC+1)
      JPP=IPN(I,IC+1)-NSS+1
      IF(JPP.LT.JPPMIN.OR.JPP.GT.JPPMAX)THEN
C     CHECK PHI CONTINUITY
      JP=IPN(I,IC+1)
      IF(IUSED(J,JP).GT.0)GOTO86
      ZZ=ZP(JP)
C     PREDICT PHI
      PHIP=PHI1+(ZZ-Z1)*SLP
      D1= DRI(J,JP)+DWS(J,JP)
      D2=-DRI(J,JP)+DWS(J,JP)

      YN(1)=ATAN(D1/RMEAN   )+WW(J,JP)
      YN(2)=ATAN(D2/RMEAN   )+WW(J,JP)

CDEB  WRITE(*,*)' HIGH CLUSTER PHI ',PHIP,YN(1),YN(2)
      DDMIN=1000.
      DO 861 IS=1,2
      DD =ABS(YN(IS)-PHIP)
C     DD2=ABS(YN(IS)-PHIP+PI2)
C     DD2=ABS(YN(IS)-PHIP-PI2)
C     DD=AMIN1(DD1,DD2,DD3)
      DDA= (YN(IS)-PHIP)
      IF(DD.LT.DDMIN)THEN
      DDMIN=DD
      DDAS=DDA
      RR=RMEAN
      ISN=IS
      ENDIF
 861  CONTINUE
      IF(IDIAG.EQ.1)CALL SHS(9005,0,(YN(ISN)-PHIP)*RM(J,JP))
C     CALL HFILL(70006,DDAS,0.,1.)
      IF(DDMIN*RR.GT.DMINX*PROJ)GOTO86
C     GOOD POINT - CONT. IN PHI
      IF(ISN.EQ.1)SDRFT(JPP,NT,IM)=1.
      IF(ISN.EQ.2)SDRFT(JPP,NT,IM)=-1.
      IRPT(JPP,NT,IM)=J
      IUSED(J,JP)=1
      ENDIF
 86   CONTINUE
CDEB  WRITE(*,*)' OUTPUT BANK AFTER ADDING HIGHER CLUSTER'
CDEB  PRINT 1004,NT,(IRPT(I1,NT,IM),I1=1,12)
C1004 FORMAT(' IRPT ',I5,1X,12I3)
CDEB  PRINT 1005,NT,(SDRFT(I1,NT,IM),I1=1,12)
C1005 FORMAT(' SDRFT',I5,1X,12F3.0)
      ENDIF
      ENDIF
C     RESET IC IN CASE CHANGED
      IC=ICS
 998  CONTINUE
C     WRITE(*,*)' NTIN,NTRAKS(IM) ',NTIN,NTRAKS(IM)
C     WRITE(*,*)' FTLISA OUT ',NTRAKS(IM)
C     PRINT 1014,IM,NT,(IRPT(I1,NT,IM),I1=1,12)
 1014 FORMAT(' IRPT ',2I5,2X,12I3,I8)
C     PRINT 1015,IM,NT,(SDRFT(I1,NT,IM),I1=1,12)
 1015 FORMAT(' SDRFT',2I5,3X,12F3.0)
C     REEXAMINE CLUSTER
C      IF(IWC(IC).GT.0)THEN
C      WRITE(*,*)' GT 500 REEXAMINE CLUSTER IWC',IWC(IC),IC
C      DO 3000 I=1,10
C      PRINT 4000,I,(IUSED(I,II),II=1,36)
C 4000 FORMAT(' IUSED ',I5,3X,12I1,1X,12I1,1X,12I1)
C 3000 CONTINUE
C      ENDIF
      IF(IWC(IC).GT.0) GO TO 500
 999  CONTINUE

C     RESET DMINX
      DMINX=SDMINX


      IF(NTRAKS(IM).EQ.NTIN)RETURN
C
C     CORRECT R FOR LORENTZ ANGLE FOR
C     FOUND TRACK SEGMENTS


      DO 9000 I=NTIN+1,NTRAKS(IM)
      LL=0
      DO 9100 J=1,12
C     PLANE #
      IP=J+NSS-1
C     POINT #
      NP=IRPT(J,I,IM)
      IF(NP.EQ.0)GOTO9100
C     DRIFT SIGN
      SGN=SDRFT(J,I,IM)
      RM(NP,IP)=RM(NP,IP)
     1 +FLOREN(RM(NP,IP),DRI(NP,IP),SGN)
      IF(IDIAG.EQ.0)GOTO9100
      LL=LL+1
      DRIFF=DRI(NP,IP)*SGN+DWS(NP,IP)
      YY(LL)=DRIFF
      XX(LL)=ZP(IP)
 9100 CONTINUE
      IF(IDIAG.EQ.1)CALL FTLFT(XX,YY,LL,0,TS,TI,EE)
      DO 9101 II=1,LL
      DIFF=YY(II)-TS*XX(II)-TI
      IF(IDIAG.EQ.1)CALL SHS(9009,0,DIFF)
      IF(IDIAG.EQ.1)CALL SHS(9010,0,ABS(DIFF))
      IF(IDIAG.EQ.1)CALL SHS(9011,0,SQRT(ABS(EE)))
 9101 CONTINUE
C
C     PRINT 1014,IM, I,(IRPT(I1, I,IM),I1=1,12)
C     PRINT 1015,IM, I,(SDRFT(I1, I,IM),I1=1,12)
 9000 CONTINUE

      RETURN
      END
*CMZU:  8.06/00 04/11/96  12.31.07  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZU:  5.03/00 28/09/94  10.26.00  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.57.57  by  Stephen Burke
*-- Author :    I.O. Skillicorn   18/08/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*          Fit radial-based tracks to straight lines
*          in phi-z, r-z. Determine chi**2 of fit.
*          For chi**2 use a parabola for 3-module
*          tracks. Otherwise use a straight line
*          in the helix frame.
*
*HTMLI     : Describe the Input variables to the routine
*
* Radial track segments:
*          Hits/drift sign         :- IRPT/SDRFT
*
*
*HTMLO     : Describe the Output of the routine
*
*          Parameters(phi',phi0)   :- PS,PI
*          Parameters(R',R0)       :- RS,RI
*          Chi**2 drift            :- CHID
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTCHKH(PS,PI,RS,RI,II,JJ,KK,CHID)
**: FTCHKH 40000 IS. New linking routine.
**----------------------------------------------------------------------
*
*
C     CALCULATES PS,PI,RS,RI ,CHID
C     PARABOLA PHI-Z R-Z FOR THREE MODULE TRACKS
C     HELIX PHI-Z R-Z FOR TWO MODULE TRACKS
C     ADDITIONAL PLOTS ARE MADE WRT STR LINES IN PHI-S R-Z.
C     WITH THESE WE CAN OPTIMISE PARAMETERS FOR TRACK
C     ORIGINATING  FROM THE IP
C
      SAVE ISTART
*KEEP,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.
*
      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)
      COMMON/PARA/PA1,PA2,PA3,ZA1,ZA2,ZA3
      DIMENSION LT(3),XX(40),YY(40),ZZ(40),WP(40),SL(3),DM(3)
      DIMENSION WPR(40),IMM(40),RA(3),PHA(3),ZA(3),FN(3),DIF(40)
      DATA ISTART/0/
*******************************************************************
C     OPTION TO USE LINEAR TRACK MODEL:-
C     IF USED, TRACKS ORIGINATING FROM IP WILL BE SELECTED
C     PREFERENTIALLY
      LINCHK=0

      IF(ISTART.EQ.0)THEN
      ISTART=1
       CALL STEXT(1201,4,' FTCHKH: CHI DRIFT RAD 123' )
       CALL BHS(1201,0,50, 0.00,25.0)
       CALL STEXT(1202,4,' FTCHKH: CHI DRIFT RAD 12 ')
       CALL BHS(1202,0,50, 0.00,25.0)
       CALL STEXT(1203,4,' FTCHKH: CHI DRIFT RAD 13 ')
       CALL BHS(1203,0,50, 0.00,25.0)
       CALL STEXT(1204,4,' FTCHKH: CHI DRIFT RAD 23 ')
       CALL BHS(1204,0,50, 0.00,25.0)
       CALL STEXT(1205,4,' FTCHKH: RESIDUAL 3RAD M1 ')
       CALL BHS(1205,0,50, -.50,0.50)
       CALL STEXT(1206,4,' FTCHKH: RESIDUAL 3RAD M2 ')
       CALL BHS(1206,0,50, -.50,0.50)
       CALL STEXT(1207,4,' FTCHKH: RESIDUAL 3RAD M3 ')
       CALL BHS(1207,0,50, -.50,0.50)
       CALL STEXT(1208,4,' FTCHKH: RESIDUAL 2RAD M1 ')
       CALL BHS(1208,0,50, -.50,0.50)
       CALL STEXT(1209,4,' FTCHKH: RESIDUAL 2RAD M2 ')
       CALL BHS(1209,0,50, -.50,0.50)
       CALL STEXT(1210,4,' FTCHKH: RESIDUAL 2RAD M3 ')
       CALL BHS(1210,0,50, -.50,0.50)
      ENDIF
*******************************************************************
      PI2=6.2831853
      LT(1)=II
      LT(2)=JJ
      LT(3)=KK
C     FIT R  -Z IN LAB   FRAME
      IC=0
      RA(1)=0.
      RA(2)=0.
      RA(3)=0.
      ZA(1)=0.
      ZA(2)=0.
      ZA(3)=0.
      FN(1)=0.
      FN(2)=0.
      FN(3)=0.
      PHA(1)=0.
      PHA(2)=0.
      PHA(3)=0.
      DO 50 JPL=1,36
      IM=(JPL-1)/12+1
      IF(LT(IM).EQ.0)GOTO50
      NT=LT(IM)
      IPL=JPL-(IM-1)*12
      J=IRPT(IPL,NT,IM)
      IF(J.EQ.0)GOTO50
      IC=IC+1
      XX(IC)=ZP(JPL)
      ZZ(IC)=RM(J,JPL)
      WPR(IC)=1./ERRRM(J,JPL)
      IF(II*JJ*KK.EQ.0)GOTO50
      ZA(IM)=ZA(IM)+ZP(JPL)
      RA(IM)=RA(IM)+RM(J,JPL)
      FN(IM)=FN(IM)+1.
 50   CONTINUE
C     FIT R  -Z IN LAB   FRAME
      CALL FTLFTW(XX,ZZ,WPR,IC,0,2,RS,RI,D1,D2,D3,D4)
C     FIT PHI-Z LAB FRAME USING FITTED R
      IC=0
      DO 60 JPL=1,36
      IM=(JPL-1)/12+1
      IF(LT(IM).EQ.0)GOTO60
      NT=LT(IM)
      IPL=JPL-(IM-1)*12
      J=IRPT(IPL,NT,IM)
      IF(J.EQ.0)GOTO60
      IC=IC+1
      RR=RS*ZP(JPL)+RI
C     PRINT 1001,IM,NT,IPL,JPL,J
      PHI=ATAN((DRI(J,JPL)*SDRFT(IPL,NT,IM)+DWS(J,JPL))/RR)+WW(J,JPL)
      YY(IC)=PHI
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
      WP(IC)=RR
      IMM(IC)=IM
 60   CONTINUE
      IF(IC.GE.2)THEN
      DO 62 JK=2,IC
      DP=YY(JK)-YY(JK-1)
      IF(DP.GT.0.0)THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JK)=YY(JK)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JK)=YY(JK)+PI2
      ENDIF
 62   CONTINUE
      ENDIF

      IF(II*JJ*KK.NE.0)THEN
      DO 63 JK=1,IC
      PHA(IMM(JK))=PHA(IMM(JK))+YY(JK)
 63   CONTINUE
      ENDIF

C     FIT PHI-Z IN LAB   FRAME
      CALL FTLFTW(XX,YY,WP,IC,0,2,PS,PI,D1,D2,D3,D4)
C     WRITE(*,*)' FTCHKH LT ',LT
C     FIND VERTEX - FIRST POINT , FIRST SEGMENT
      DO 10 IM=1,3
      NT=LT(IM)
      IF(NT.EQ.0)GOTO 10
C     PRINT 1000,IM,NT,(IRPT(JKL,NT,IM),JKL=1,12)
      JPL=(IM-1)*12+1
      PHI=PS*ZP(JPL)+PI
      RR =RS*ZP(JPL)+RI
      XFFF=RR*COS(PHI)
      YFFF=RR*SIN(PHI)
      ZFFF=ZP(JPL)
      GOTO 11
 10   CONTINUE
 11   CONTINUE
C     WRITE(*,*)XFFF,YFFF,ZFFF
C     WRITE(*,*)PS,PI,RS,RI
C     FIT PHI-Z , R-Z  IN HELIX FRAME
      IC=0
      DO 20 JPL=1,36
      IM=(JPL-1)/12+1
      IF(LT(IM).EQ.0)GOTO20
      NT=LT(IM)
      IPL=JPL-(IM-1)*12
      J=IRPT(IPL,NT,IM)
      IF(J.EQ.0)GOTO20
      IC=IC+1
      RR=RS*ZP(JPL)+RI
C     PRINT 1001,IM,NT,IPL,JPL,J
 1001 FORMAT(' IM,NT,IPL,JPL,J ',6I3)
      PHI=ATAN((DRI(J,JPL)*SDRFT(IPL,NT,IM)+DWS(J,JPL))/RR)+WW(J,JPL)
      XF=RR*COS(PHI)
      YF=RR*SIN(PHI)
      XH=XF-XFFF
      YH=YF-YFFF
      RH=SQRT(XH**2+YH**2)
      ZZ(IC)=RH
      WPR(IC)=1./ERRRM(J,JPL)
      IF(RH.NE.0.0)THEN
      XX(IC)=ZP(JPL)
      YY(IC)=ATAN2(YH/RH,XH/RH)
      IF(YY(IC).LT.0.0)YY(IC)=YY(IC)+PI2
C     ERROR IN PHI DEPENDS ON 1/RH
      WP(IC)=RH
      ELSE
      XX(IC)=ZP(JPL)
      YY(IC)=0.0001
      WP(IC)=0.0
      ENDIF
 20   CONTINUE
      IF(IC.GE.2)THEN
      DO 22 JK=2,IC
      IF(WP(JK-1).EQ.0.0)GOTO22
      DP=YY(JK)-YY(JK-1)
      IF(DP.GT.0.0)THEN
      IF(ABS(DP).GT.ABS(DP-PI2))YY(JK)=YY(JK)-PI2
      ELSE
      IF(ABS(DP).GT.ABS(DP+PI2))YY(JK)=YY(JK)+PI2
      ENDIF
 22   CONTINUE
      ENDIF
C     FIT PHI-Z IN HELIX FRAME
      CALL FTLFTW(XX,YY,WP,IC,0,2,PSH,PIH,D1,D2,D3,D4)
C     WRITE(*,*)' IC PSH PIH ',IC,PSH,PIH
C     FIT R  -Z IN HELIX FRAME
      CALL FTLFTW(XX,ZZ,WPR,IC,0,2,RSH,RIH,D1,D2,D3,D4)
C     WRITE(*,*)' IC RSH RIH ',IC,RSH,RIH
C     GET CHI**2 WRT TO HELIX PHI-Z ,R-Z
      IF(II*JJ*KK.NE.0)THEN
      DO 23 IM=1,3
      RA(IM)=RA(IM)/FN(IM)
      ZA(IM)=ZA(IM)/FN(IM)
      PHA(IM)=PHA(IM)/FN(IM)
 23   CONTINUE
      PA1=PHA(1)
      PA2=PHA(2)
      PA3=PHA(3)
      ZA1=ZA(1)
      ZA2=ZA(2)
      ZA3=ZA(3)
      ENDIF
C     CHI FOR PARABOLAE - THREE MODULE TRACKS
C     CHI FOR PHI-Z,R-Z HELIX FRAME - TWO MODULE TRACKS
      CHID=0.
      LL=0
      DO 100 IM =1,3
      NT=LT(IM)
      IF(NT.EQ.0)GOTO100
      DO 110 IPL=1,12
      JPL=IPL+(IM-1)*12
      J=IRPT(IPL,NT,IM)
      IF(J.EQ.0)GOTO110
      LL=LL+1
      IMM(LL)=IM
      RRH=RSH*ZP(JPL)+RIH
      PHIH=PSH*ZP(JPL)+PIH
      IF(PHIH.LT.0.0)PHIH=PHIH+PI2
C     MEASURED DRIFT
      DRM=SDRFT(IPL,NT,IM)*DRI(J,JPL)+DWS(J,JPL)
C     PREDICTED DRIFT
      THETA=WW(J,JPL)
      DEH=RRH*SIN(PHIH-THETA)+YFFF*COS(THETA)-XFFF*SIN(THETA)
C     WRITE(*,*)' DRIFTS ',LL,DRM,DEH
      IF(II*JJ*KK.NE.0)THEN
C     PARABOLA FOR CHI AND RESIDUALS
      ZED=ZP(JPL)
      PHIP=FPARAB(ZED,PHA(1),PHA(2),PHA(3),
     1                ZA(1), ZA(2), ZA(3))
      RRP =FPARAB(ZED, RA(1), RA(2), RA(3),
     1                ZA(1), ZA(2),ZA(3))
      DEH=RRP*SIN(PHIP-THETA)
      CHID=CHID+(DRM-DEH )**2/(0.04)**2
      DIF(LL)=DRM-DEH
      ELSE
C     PHI-Z HELIX FRAME
      CHID=CHID+(DRM-DEH)**2/(0.03)**2
      DIF(LL)=DRM-DEH
      ENDIF
 110  CONTINUE
 100  CONTINUE
      CHID=CHID/FLOAT(LL)
C     PCHID=PROB(CHID*FLOAT(LL),LL)
C     WRITE(*,*)' CHID ',CHID

       IF(II*JJ*KK.NE.0)CALL SHS(1201,0, CHID)
       IF(II*JJ.NE.0.AND.KK.EQ.0)CALL SHS(1202,0, CHID)
       IF(II*KK.NE.0.AND.JJ.EQ.0)CALL SHS(1203,0, CHID)
       IF(JJ*KK.NE.0.AND.II.EQ.0)CALL SHS(1204,0, CHID)
       IF(CHID.LT.5.0)THEN
       DO 130 JK=1,LL
       IM=IMM(JK)
       IF(II*JJ*KK.NE.0)THEN
C      PARABOLA FOR CHI AND RESIDUALS
       IF(IM.EQ.1)CALL SHS(1205,0,DIF(JK))
       IF(IM.EQ.2)CALL SHS(1206,0,DIF(JK))
       IF(IM.EQ.3)CALL SHS(1207,0,DIF(JK))
       ELSE
C      PHI-Z HELIX FRAME
       IF(IM.EQ.1)CALL SHS(1208,0,DIF(JK))
       IF(IM.EQ.2)CALL SHS(1209,0,DIF(JK))
       IF(IM.EQ.3)CALL SHS(1210,0,DIF(JK))
       ENDIF
 130   CONTINUE
       ENDIF
      RETURN
      END

*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZ :  3.03/01 01/05/92  11.52.43  by  Gregorio Bernardi
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
**: FPCFIT.......SM. Bug fix. Protect against small Chisq for PROB.
**----------------------------------------------------------------------
C-------------------------------------------------------------
C
C---  Fit four points y(i) with weights w(i) at positions z(i)
C---  Returns SLOPE (dy/dz) ZERO (y(0))
C---          COVSLZ(2,2) their correlation matrix
C---  and     CHISQ and probability from chisquare pbchi
C
C-------------------------------------------------------------
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
      DOUBLE PRECISION Y(4),Z(4)
      REAL W(4),COVSLZ(2,2)
C
C---  Section of code varies with w(i)
C
      Z(1) = 0.0
      Z(2) = ZPLAN( IP + 1) - ZPLAN( IP )
      Z(3) = ZPLAN( IP + 2) - ZPLAN( IP )
      Z(4) = ZPLAN( IP + 3) - ZPLAN( IP )
      ZSUM = 0.0
      ZSUM2 = 0.0
      WSUM = 0.0
      DO 20 I=1,4
      ZSUM = ZSUM + Z(I)*W(I)
      ZSUM2 = ZSUM2 + Z(I)*Z(I)*W(I)
      WSUM = WSUM + W(I)
   20 CONTINUE
      DET = WSUM * ZSUM2  - (ZSUM * ZSUM)
C
C---  return slope and constant unphysical if det is 0
C
      IF( DET .EQ. 0.0 )THEN
         SLOPE = 0.0
         CONST = 2000.0
      RETURN
      ENDIF
C
C---  calculate error matrix
C
      COVSLZ(1,1) = WSUM/DET
      COVSLZ(2,2) = ZSUM2/DET
      COVSLZ(1,2) = -ZSUM/DET
      COVSLZ(2,1) = COVSLZ(1,2)
C
C---  Initialization per fit
C
      SLOPE = 0.0
      CONST = 0.0
      YSUM = 0.0
      YZSUM = 0.0
C
C---  Calculate required sums
C
      NDF = 0
      DO 25 I=1,4
      IF(W(I) .NE. 0.0) NDF = NDF + 1
      YSUM = YSUM + Y(I) * W(I)
      YZSUM = YZSUM + Y(I) * Z(I) * W(I)
   25 CONTINUE
C
C---  Calculate slopes and data zeros
C
      SLOPE = ( WSUM * YZSUM  -  ZSUM * YSUM ) /DET
      ZERO  = ( ZSUM2 * YSUM - ZSUM * YZSUM )  /DET
C
C---  Calculate chisquare
C
      CHISQ = 0.0
      DO 23 I=1,4
      CHISQ =   CHISQ   +
     1         ( Y(I)   -
     2           SLOPE*Z(I) - ZERO )**2   *  W(I)
   23 CONTINUE
C
C---  Calculate probability from chisquare
C
      NDF = NDF - 2
*     Fix for v. small Chisq...
      IF(CHISQ .LT. 0.001) THEN
       PBCHI = 0.9999999
      ELSE
       PBCHI = PROB( ABS(CHISQ),NDF )
      ENDIF
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZ :  3.03/01 01/05/92  11.52.43  by  Gregorio Bernardi
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPCPLN
C-------------------------------------------------------------
C
C---  routine calculates plane normal and constant
C---  for each cluster found by FPDIG4
C
C-------------------------------------------------------------
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
C
C---  Calculate the normals to the planes formed by the tracks
C---  and four wires in the same orientation for each cluster in each
C---  plane
C
      DO 10 IPLANE = 1,9
      DO 20 ITC    = 1,NTC(IPLANE)
C
C---  calculate normals
C
      TPNORM(1,IPLANE,ITC) =
     1         (   PLANE(3,IPLANE) * TC(2,IPLANE,ITC)
     2           - PLANE(2,IPLANE) * TC(3,IPLANE,ITC) )
      TPNORM(2,IPLANE,ITC) =
     1       - (   PLANE(3,IPLANE) * TC(1,IPLANE,ITC)
     2           - PLANE(1,IPLANE) * TC(3,IPLANE,ITC) )
      TPNORM(3,IPLANE,ITC) =
     1         (   PLANE(2,IPLANE) * TC(1,IPLANE,ITC)
     2           - PLANE(1,IPLANE) * TC(2,IPLANE,ITC) )
C
C---  Normalize TPNORM
C
          ALEN = SQRT ( TPNORM(1,IPLANE,ITC)**2 +
     1                  TPNORM(2,IPLANE,ITC)**2 +
     2                  TPNORM(3,IPLANE,ITC)**2 )
          DO 60 I=1,3
          TPNORM(I,IPLANE,ITC) = TPNORM (I,IPLANE,ITC) / ALEN
   60     CONTINUE
C
C---  Calculate the characteristic constant for this plane
C
          PCONST(IPLANE,ITC) =
     1                   TOC(1,IPLANE,ITC) * TPNORM(1,IPLANE,ITC)
     2                 + TOC(2,IPLANE,ITC) * TPNORM(2,IPLANE,ITC)
     3                 + TOC(3,IPLANE,ITC) * TPNORM(3,IPLANE,ITC)
   20 CONTINUE
   10 CONTINUE
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  5.03/00 02/11/94  18.53.01  by  Stephen Burke
*CMZU:  3.03/03 15/05/92  18.47.24  by  Stephen J. Maxfield
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFSEG(NSMLS)
**: FPFSEG.......SM. Add diagnostic histograms
C-------------------------------------------------------------
C---
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
C---
      DOUBLE PRECISION PARSEG(4),ERRSEG(4,4),
     1                 PARSGN(4),ERRSGN(4,4)
      DIMENSION ID(3,2)
      DIMENSION XFV(LIMSTO),IOXFV(LIMSTO)
      DIMENSION XSOL(2),YSOL(2),ZSOL(2)
C      DIMENSION IUCLU(50,9)
C---
      INTEGER NSMLS(3)
      REAL X(2),Y(2),Z(2)
C
C---  Set segment finding resolution cut
C
      ACUTSQ = ACUT**2
C
C---  loop over all combinations of planes formed by clusters
C---  in each orientation per supermodule and
C---  find any three which are coincident to within an
C---  arbitary tolerance acut
C
C
C---  Loop on supermodules
C
      DO 5 ISM = 1,3
C
C---  Zero number of segments found
C
      NFSEG(ISM) = 0
C
C---  skip if less than three present
C
      IF ( NSMLS(ISM) .LT. 3 ) GO TO 5
C
C---  sort the segments according to their front face x values
C
      DO 250 IS   = 1       , NSMLS(ISM)
      XFV(IS) = SMLS(1,1,IS,ISM)
  250 CONTINUE
C
C---  call cern library routine to return sorted list
C---  their ascending order is stored in ioxfv
C
      IF( NSMLS(ISM) .NE. 0)
     1     CALL SORTZV(XFV , IOXFV , NSMLS(ISM) , 1 , 0 , 0)
C
C---  Loop on tracks
C
      DO 10 ISEG1 = 1       , NSMLS(ISM)-2
C
C---  Second Plane
C
      DO 20 ISEG2 = ISEG1+1 , NSMLS(ISM)-1
C
C---  Test 1/2 front x and then y and rear x then y projections
C
      DFX1 = SMLS(1,1,IOXFV(ISEG1),ISM) - SMLS(1,1,IOXFV(ISEG2),ISM)
*     Call Hfill(403, DFX1, 0., 1.)
      IF (abs( DFX1) .GT. ACUT ) GO TO 10
      DFY1 = SMLS(2,1,IOXFV(ISEG1),ISM) - SMLS(2,1,IOXFV(ISEG2),ISM)
*     Call Hfill(403, DFY1, 0., 1.)
      IF (abs( DFY1) .GT. ACUT ) GO TO 20
      DRX1 = SMLS(1,2,IOXFV(ISEG1),ISM) - SMLS(1,2,IOXFV(ISEG2),ISM)
*     Call Hfill(403, DRX1, 0., 1.)
      IF (abs( DRX1) .GT. ACUT ) GO TO 20
      DRY1 = SMLS(2,2,IOXFV(ISEG1),ISM) - SMLS(2,2,IOXFV(ISEG2),ISM)
*     Call Hfill(403, DRY1, 0., 1.)
      IF (abs( DRY1) .GT. ACUT ) GO TO 20
C
C---  third plane
C
      DO 30 ISEG3 = ISEG2+1 , NSMLS(ISM)
C
C---  Now test 1/3 x projection combinations
C
      DFX2 = SMLS(1,1,IOXFV(ISEG1),ISM) - SMLS(1,1,IOXFV(ISEG3),ISM)
*     Call Hfill(403, DFX2, 0., 1.)
      IF (abs( DFX2) .GT. ACUT ) GO TO 20
C
C---  In an ordered sequence this next tests adds nothing
C
       DFX3 = SMLS(1,1,IOXFV(ISEG2),ISM) - SMLS(1,1,IOXFV(ISEG3),ISM)
*      Call Hfill(403, DFX1, 0., 1.)
C      if (ABS( dfx3) .gt. acut ) go to 20
C
C---  Now test front 1/3 and 2/3 y projection combinations
C
      DFY2 = SMLS(2,1,IOXFV(ISEG1),ISM) - SMLS(2,1,IOXFV(ISEG3),ISM)
*     Call Hfill(403, DFY2, 0., 1.)
      IF (abs( DFY2) .GT. ACUT ) GO TO 30
      DFY3 = SMLS(2,1,IOXFV(ISEG2),ISM) - SMLS(2,1,IOXFV(ISEG3),ISM)
*     Call Hfill(403, DFY3, 0., 1.)
      IF (abs( DFY3) .GT. ACUT ) GO TO 30
C
C---  Now test the rear 1/3 combinations
C
      DRX2 = SMLS(1,2,IOXFV(ISEG1),ISM) - SMLS(1,2,IOXFV(ISEG3),ISM)
*     Call Hfill(403, DRX2, 0., 1.)
      IF (abs( DRX2) .GT. ACUT ) GO TO 30
      DRY2 = SMLS(2,2,IOXFV(ISEG1),ISM) - SMLS(2,2,IOXFV(ISEG3),ISM)
*     Call Hfill(403, DRY2, 0., 1.)
      IF (abs( DRY2) .GT. ACUT ) GO TO 30
C
C---  Now test the rear 2/3 combination
C
      DRX3 = SMLS(1,2,IOXFV(ISEG2),ISM) - SMLS(1,2,IOXFV(ISEG3),ISM)
*     Call Hfill(403, DRX3, 0., 1.)
      IF (abs( DRX3) .GT. ACUT ) GO TO 30
      DRY3 = SMLS(2,2,IOXFV(ISEG2),ISM) - SMLS(2,2,IOXFV(ISEG3),ISM)
*     Call Hfill(403, DRY3, 0., 1.)
      IF (abs( DRY3) .GT. ACUT ) GO TO 30
C
C---  ensure that candiate segments have track/plane in common
C
      ID(1,1) = SMLS(4,1,IOXFV(ISEG1),ISM)
      ID(1,2) = SMLS(4,2,IOXFV(ISEG1),ISM)
      ID(2,1) = SMLS(4,1,IOXFV(ISEG2),ISM)
      ID(2,2) = SMLS(4,2,IOXFV(ISEG2),ISM)
      ID(3,1) = SMLS(4,1,IOXFV(ISEG3),ISM)
      ID(3,2) = SMLS(4,2,IOXFV(ISEG3),ISM)
C
C---  ensure that track/plane assignments are self consistent
C
C---  The diagram desribes the functioning of the
C---  following block of code. The brackets represent a candidate
C---  line segment made from two candidate clusters each (  1 | 2  ).
C---  That is id(1,1) etc.
C---  For the segment to be valid each of the three links must be in place.
C---  The code finds the two outermost  links and remembers ipn1,ipn2
C---  imn1,imn2 which constrain the final link.
C---
C---
C---                 (     |     )
C---                  /         \
C---                 /           \
C---                /             \
C---               /               \
C---           (    |imn2)---(imn1|    )
C---              ipn2          ipn1
C
      DO 100 IP = 2,3
        DO 101 IM = 1,2
          IF( ID(1,1) .NE. ID(IP,IM) ) GO TO 101
C---
            IF ( IP .EQ. 2 ) THEN
              IPN1 = 3
              IPN2 = 2
            ELSE
              IPN1 = 2
              IPN2 = 3
            ENDIF
C---
            IF ( IM .EQ. 1 ) THEN
              IMN2 = 2
            ELSE
              IMN2 = 1
            ENDIF
          GO TO 102
  101   CONTINUE
  100 CONTINUE
C
C---  the first track/plane id(1,1) not equal to any of the others reject
C
      GO TO 30
C
C---  the first track/plane link found
C
  102 CONTINUE
C
C--- now find second link for a(1,2)
C
      IF( ID(1,2) .EQ. ID(IPN1,1) )THEN
        IMN1 = 2
      ELSEIF( ID(1,2) .EQ. ID(IPN1,2) )THEN
        IMN1 = 1
      ELSE
        GO TO 30
      ENDIF
C
C--- now test last remaining link
C
      IF ( ID(IPN1,IMN1) .NE. ID(IPN2,IMN2) ) GO TO 30
C
C---  Now test absolute lengths
C
      IF (  DFX1**2 + DFY1**2 .GT. ACUTSQ .OR.
     1      DFX2**2 + DFY2**2 .GT. ACUTSQ .OR.
     2      DFX3**2 + DFY3**2 .GT. ACUTSQ .OR.
     3      DRX1**2 + DRY1**2 .GT. ACUTSQ .OR.
     4      DRX2**2 + DRY2**2 .GT. ACUTSQ .OR.
     5      DRX3**2 + DRY3**2 .GT. ACUTSQ )GO TO 30
C
C---  find the three yuv sets involved in this combination
C
      ID1 = ID(1,1)
      ID2 = ID(1,2)
      ID3 = ID(IPN1,IMN1)
C
C---  do direct lsq fit to yuv to give alternate parseg and errseg
C
      CALL FPFYUV(ID1,ID2,ID3,ISM,PCHI,CHISQ,NDF,PARSGN,ERRSGN)
C
C---  end of loops
C
   30 CONTINUE
   20 CONTINUE
   10 CONTINUE
    5 CONTINUE
C
C---  Remove connectivity between segments
C
      CALL FPSGRF
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  15.17.55  by  Stephen Burke
*CMZU:  3.09/01 20/05/93  18.29.01  by  Stephen J. Maxfield
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFYUV(ID1,ID2,ID3,ISM,PCHI,CHISQ,NDF,SOL,EXYSXY)
**: FPFYUV.......SM. Bug fix. Protect against small Chisq for PROB.
**----------------------------------------------------------------------
**: FPFYUV 30205 SM. Add diagnostic histogram
**----------------------------------------------------------------------
*
C
C
C------------------------------------------------------------------
C
C---  THIS ROUTINE PERFORMS A LEAST SQUARES FIT TO A STRAIGHT
C---  LINE FOR POINTS AT POSITIONS Z(I) MEASURED IN THE Y U V COORDINATE
C---  FRAMES WHERE U COORDINATES ARE AT ANGLE THETA(2) AND V ARE AT
C---  ANGLE THETA(3) TO Y. THETA IS ASSUMED TO BE MEASURED IN THE
C---  CLOCKWISE DIRECTION.
C
C---  INPUT  :
C
C---  Y - POINTS FOR FITTING;  4 FROM Y COORDS, 4 FROM U, 4 FROM V.
C---  RESOL - RESOLUTION ON EACH DIGITIZING (IN PRINCIPLE PER WIRE)
C---  ZPLAN(36) - Z COORDINATE OF EACH PLANAR WIRE SET
C
C---  OUTPUT  :
C
C---  PCHI PROBABILITY FROM CHISQUARE
C---  SOL(4) X0 Y0 DX/DZ DY/DZ
C---  EXYSXY(4,4) COVARIANCE MATRIX TO SOL
C
C------------------------------------------------------------------
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
      DIMENSION W(12),Z(12)
      DIMENSION WSUM(3),WZSUM(3),WZ2SUM(3)
      DIMENSION WYSUM(3),WYZSUM(3)
      DIMENSION B(4)
      DIMENSION WORK(16)
      DIMENSION WTEST(4,4)
      DIMENSION MTRIXA(4,4)
      DIMENSION Y(12),YC(12)
      DIMENSION SOL(4),EXYSXY(4,4)
      DIMENSION XSOL(2),YSOL(2),ZSOL(2)
      DIMENSION COST(3),COS2T(3),TANT(3),TAN2T(3),THETA(3)
      DIMENSION XT(12),YT(12)
      DIMENSION COUNTS(500),CHISQA(12)
C---
      REAL MTRIXA
      DOUBLE PRECISION EXYSXY,SOL,B
      REAL CHISQ
C---
      SAVE
C      DATA THETA/ 0.0 , - 1.0471976 , 1.0471976/
      DATA NEVENT/0/
      DATA IFIRST/1/
C---
C
C---   INITIALIZATION PER SUPERMODULE
C
      IF( IFIRST .EQ. 1  .OR.  ISM .NE. ISMLAS )THEN
      IFIRST = 0
      ISMLAS = ISM
C
C---  SET FOUND PLANAR SEGMENT COUNTER TO ZERO FOR FIRST SUPERMODULE
C
        IF( ISM .EQ. 1)THEN
           DO 45 IMOD = 1,3
           NFSEG(IMOD) = 0
   45      CONTINUE
        ENDIF
C
C---  ROTATE THETA SO THETA(1) = 0.0
C
      TZERO = - TP( 1 + (ISM-1)*3 )
      DO 43 I = 1,3
      THETA(I) = - TP( I + (ISM-1)*3 ) - TZERO
   43 CONTINUE
      CTZERO = COS(TZERO)
      STZERO = SIN(TZERO)
C
C---  HBOOK MONITOR PLOT
C
C      CALL HBOOK1(10008,'PROB$',50,0.0,1.0,0.0)
C
C---  SETUP GEOMETRICAL CONSTANTS
C
      DO 200 I = 1,3
      COST(I) = COS( THETA(I) )
      COS2T(I) = COST(I)**2
      TANT(I) = TAN( THETA(I) )
      TAN2T(I) = TANT(I)**2
  200 CONTINUE
      ENDIF
C
C---  SETUP Z ARRAY APPROPRIATE TO CURRENT SM
C
      DO 210 I = 1,4
      DO 211 J = 1,3
      Z(I + (J-1)*4 ) = ZPLAN( (((ISM-1)*3 + J) - 1)*4  +  I )
  211 CONTINUE
  210 CONTINUE
C
C---  CENTRE OF PLANES
C
      ZSUM = 0.0
      DO 215 I = 1,12
        ZSUM = ZSUM + Z(I)
  215 CONTINUE
      ZMEAN = ZSUM/12.0
      DO 216 I = 1,12
       Z(I) = Z(I) - ZMEAN
  216 CONTINUE
C
C---  FIND Y U V FOR THE CURRENT SEGMENT
      IPLAN1 = MOD(ID1,10)
      IPLAN2 = MOD(ID2,10)
      IPLAN3 = MOD(ID3,10)
      ITRCK1 = ID1 / 10
      ITRCK2 = ID2 / 10
      ITRCK3 = ID3 / 10
C
C---  FIND OFSETS SUCH THAT Y ARRAY IS ON ORDER YUV
C
       IND = MOD(IPLAN1,3)
       IF (IND .EQ. 0) IND = 3
       IOFF1 = 2**IND
       IF (IOFF1 .EQ. 2) IOFF1 = 0
C---
       IND = MOD(IPLAN2,3)
       IF (IND .EQ. 0) IND = 3
       IOFF2 = 2**IND
       IF (IOFF2 .EQ. 2) IOFF2 = 0
C---
       IND = MOD(IPLAN3,3)
       IF (IND .EQ. 0) IND = 3
       IOFF3 = 2**IND
       IF (IOFF3 .EQ. 2) IOFF3 = 0
C---
         DO 10 I = 1,4
C
C---  Unpack segment Y values identifiers
C
         Y(I+IOFF1) = TCYUV(I,IPLAN1,ITRCK1)
         Y(I+IOFF2) = TCYUV(I,IPLAN2,ITRCK2)
         Y(I+IOFF3) = TCYUV(I,IPLAN3,ITRCK3)
   10    CONTINUE
C
C---  SET WEIGHT MATRIX
C
      DO 20 I=1,4
      W(I+IOFF1) = TCYUVW(I,IPLAN1,ITRCK1)
      W(I+IOFF2) = TCYUVW(I,IPLAN2,ITRCK2)
      W(I+IOFF3) = TCYUVW(I,IPLAN3,ITRCK3)
   20 CONTINUE
C
C---  COUNT NUMBER OF DIGITIZINGS CONTRIBUTING
C
      NDIG = 0
      DO 21 I = 1,12
      IF(W(I) .EQ. 0.0)GO TO 21
      NDIG = NDIG+1
   21 CONTINUE
C
C---  ZERO SUMS
C
      DO 30 IO = 1,3
        WSUM(IO) = 0.0
        WZSUM(IO) = 0.0
        WZ2SUM(IO) = 0.0
        WYSUM(IO)=0.0
        WYZSUM(IO) = 0.0
   30 CONTINUE
C
C---  LOOP OVER Z POSITIONS TO FORM SUMS
C
      DO 40 IZ = 1,12
        IO = ((IZ-1)/4) + 1
C---
          WSUM(IO) = WSUM(IO) + W(IZ)
          WZSUM(IO) = WZSUM(IO)  +  W(IZ) * Z(IZ)
          WZ2SUM(IO) = WZ2SUM(IO)  +  W(IZ) * Z(IZ)**2
          WYSUM(IO) = WYSUM(IO)  +  W(IZ) * Y(IZ)
          WYZSUM(IO) = WYZSUM(IO)  +  W(IZ) * Y(IZ) * Z(IZ)
C---
   40 CONTINUE
C
C---  SCALE TERMS 2,3 BY COS2T
C
      DO 50 I =2,3
      WSUM(I) = COS2T(I) * WSUM(I)
      WZSUM(I) = COS2T(I) * WZSUM(I)
      WZ2SUM(I) = COS2T(I) * WZ2SUM(I)
   50 CONTINUE
C
C---  NOW FORM MTRIXA
C
      MTRIXA(1,1) = TAN2T(2) * WSUM(2) + TAN2T(3) * WSUM(3)
      MTRIXA(2,2) = WSUM(1) + WSUM(2) + WSUM(3)
      MTRIXA(3,3) = TAN2T(2) * WZ2SUM(2) + TAN2T(3) * WZ2SUM(3)
      MTRIXA(4,4) = WZ2SUM(1) + WZ2SUM(2) + WZ2SUM(3)
C---
      MTRIXA(1,2) = TANT(2) * WSUM(2) + TANT(3) * WSUM(3)
      MTRIXA(2,1) = MTRIXA(1,2)
      MTRIXA(1,3) = TAN2T(2) * WZSUM(2) + TAN2T(3) * WZSUM(3)
      MTRIXA(3,1) = MTRIXA(1,3)
      MTRIXA(1,4) = TANT(2) * WZSUM(2) + TANT(3) * WZSUM(3)
      MTRIXA(4,1) = MTRIXA(1,4)
C---
      MTRIXA(2,3) = TANT(2) * WZSUM(2) + TANT(3) * WZSUM(3)
      MTRIXA(3,2) = MTRIXA(2,3)
      MTRIXA(2,4) = WZSUM(1) + WZSUM(2) + WZSUM(3)
      MTRIXA(4,2) = MTRIXA(2,4)
C---
      MTRIXA(3,4) = TANT(2) * WZ2SUM(2) + TANT(3) * WZ2SUM(3)
      MTRIXA(4,3) = MTRIXA(3,4)
C
C---  NOW CALCULATE ERROR MATRIX FOR XY,SLOPE XY
C
      DO 60 IR=1,4
      DO 70IC=1,4
        EXYSXY(IR,IC) = MTRIXA(IR,IC)
   70 CONTINUE
   60 CONTINUE
C---
      CALL DINV(4,EXYSXY,4,WORK,IFAIL)
C---
      IF(IFAIL .NE. 0) THEN
      WRITE(6,*)'YUV FIT FAILED'
      RETURN
      ENDIF
C
C---  CALCULATE VECTOR B
C
      B(1) = TANT(2)*COST(2) *  WYSUM(2) + TANT(3)*COST(3) * WYSUM(3)
      B(2) = WYSUM(1) + COST(2) * WYSUM(2) + COST(3) * WYSUM(3)
      B(3) = TANT(2)*COST(2) * WYZSUM(2) + TANT(3)*COST(3) * WYZSUM(3)
      B(4) =  WYZSUM(1) + COST(2) * WYZSUM(2) + COST(3) * WYZSUM(3)
C
C---  NOW SOLVE FOR X,Y,SX,SY
C
      DO 90 IR =1,4
      SOL(IR) = 0.0
   90 CONTINUE
      DO 100 IR = 1,4
      DO 110 IC = 1,4
         SOL(IR) = SOL(IR) + EXYSXY(IR,IC)*B(IC)
  110 CONTINUE
  100 CONTINUE
C
C---  PUT ZERO BACK TO Z=0
C
      SOL(1) = SOL(1) - SOL(3)*ZMEAN
      SOL(2) = SOL(2) - SOL(4)*ZMEAN
      DO 632 I =1,12
        Z(I) = Z(I) + ZMEAN
 632  CONTINUE
C--
      CALL FPPPTZ(EXYSXY,-ZMEAN)
C
C---   NOW CALCULATE RESULTANT Y U V
C
      DO 130 IZ = 1,4
      YC(IZ) = SOL(2) + SOL(4)*Z(IZ)
      YC(IZ+4) = COST(2) * ( (SOL(2) + SOL(4)*Z(IZ+4) ) +
     1             TANT(2) * (SOL(1) + SOL(3)*Z(IZ+4) ) )
      YC(IZ+8) = COST(3) * ( (SOL(2) + SOL(4)*Z(IZ+8) ) +
     1             TANT(3) * (SOL(1) + SOL(3)*Z(IZ+8) ) )
  130 CONTINUE
C
C---  CALCULATE CHISQUARE
C
      CHISQ = 0.0
C
C---
C
      DO 140 IZ=1,12
      CHISQA(IZ) = (Y(IZ)-YC(IZ))**2*W(IZ)
      CHISQ = CHISQ + (Y(IZ)-YC(IZ))**2*W(IZ)
  140 CONTINUE
      NDF = NDIG-4
*     Fix for v. small Chisq...
      IF(CHISQ .LT. 0.001) THEN
       PCHI = 0.9999999
      ELSE
       PCHI = PROB( ABS(CHISQ),NDF )
      ENDIF

C
C---  PLSEG ARRAY FILLED HERE
C
          IF (NFSEG(ISM) .GE. MAXSEG) THEN
            CALL ERRLOG(213,'W:FPFYUV: Max segments exceeded')
            RETURN
          ELSE
C
C---  INCREMENT FOUND SEGMENT COUNTER
C
*     IF(PCHI .GT. 0.0001)THEN
      IF(PCHI .GT. 0.0000)THEN
        NFSEG(ISM) = NFSEG(ISM) + 1
      ELSE
        RETURN
      ENDIF
C
C---  Store away digitization pointers for found segment
C
      DO 305 I=1,4
      IDGISG(I+IOFF1,NFSEG(ISM),ISM) = IDGISM(I,IPLAN1,ITRCK1)
      IDGISG(I+IOFF2,NFSEG(ISM),ISM) = IDGISM(I,IPLAN2,ITRCK2)
      IDGISG(I+IOFF3,NFSEG(ISM),ISM) = IDGISM(I,IPLAN3,ITRCK3)
  305 CONTINUE
C
C---
      DO 300 I = 1,12
C
C---  PREPARE OUTPUT BANKS
C
      PW(I,NFSEG(ISM),ISM) = Y(I)
      PWC(I,NFSEG(ISM),ISM) = YC(I)
  300 CONTINUE
      PRCHI(NFSEG(ISM),ISM) = PCHI
C
C---  ROTATE BACK FROM THETA(1) = 0.0 TO X Y FRAME
C
        IF(TZERO .NE. 0.0)THEN
        S1 =   CTZERO*SOL(1) + STZERO*SOL(2)
        S2 = - STZERO*SOL(1) + CTZERO*SOL(2)
        S3 =   CTZERO*SOL(3) + STZERO*SOL(4)
        S4 = - STZERO*SOL(3) + CTZERO*SOL(4)
        SOL(1) = S1
        SOL(2) = S2
        SOL(3) = S3
        SOL(4) = S4
        ENDIF
      DO 301 I = 1,4

        XYDXY(I,NFSEG(ISM),ISM) = SOL(I)
          DO 302 J = 1,4
            EXYDXY(I,J,NFSEG(ISM),ISM) = EXYSXY(I,J)
  302     CONTINUE
  301 CONTINUE
      ZSEG(1,NFSEG(ISM),ISM) = Z(1)
      ZSEG(2,NFSEG(ISM),ISM) = Z(12)
C
C---  Store segments information for FPSGRF
C
      ISEGIN(1,NFSEG(ISM),ISM)=ID1
      ISEGIN(2,NFSEG(ISM),ISM)=ID2
      ISEGIN(3,NFSEG(ISM),ISM)=ID3
      ISEGIN(4,NFSEG(ISM),ISM)=NDF
      ASEGIN(  NFSEG(ISM),ISM)=CHISQ
C---
          ENDIF
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZ :  3.03/01 01/05/92  12.02.39  by  Gregorio Bernardi
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPIPRT
C
C---  Routine prints out planars digitizings found in Ians new
C---  simulation code
C
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
*KEEP,FPPRNT.
      COMMON/FPPRNT/IPRINT
C---
*KEND.
C---
      DO 10 IM=1,3
      IF(IM.GT.IPRINT)GOTO10
C      WRITE(*,*)'  IM #SEGS ',IM,NFSEG(IM)
      KKK=0
      DO 30 LL=1,150
      NS=NFSEG(IM)
C      WRITE(*,*)' MODULE ,# SEGS ',IM,NS
      IF(NS.EQ.0)GOTO10
      DO 20 IS=1,NS
      IF(IS.GT.MAXSEG)GOTO20
      IF(MASKSG(IS,IM).LT.0)GOTO20
      IF(LL.EQ.IABS(IDGISG(1,IS,IM)))THEN
C     TO ORDER ( IN A STUPID WAY)
C      WRITE(*,*)' LINES ',IM,IS,PRCHI(IS,IM),(IDGISG(KK,IS,IM),KK=1,12),
C     1 ' MASK ',MASKSG(IS,IM)
      XX=XYDXY(1,IS,IM)/10.
      YY=XYDXY(2,IS,IM)/10.
      IF(IPRINT.GT.0)THEN
      KKK=KKK+1
      PRINT1000,IM,IS,KKK,RCHI(IS,IM),XX,YY,(XYDXY(KK,IS,IM),KK=3,4),
     1  (IDGISG(KK,IS,IM),KK=1,12),MASKSG(IS,IM)
      ENDIF
      ENDIF
 20   CONTINUE
 30   CONTINUE
 10   CONTINUE
 1000 FORMAT(' FIT ',3I4,2X,F6.1,'  ',4F8.3,2X,4I3,1X,4I3,1X,4I3,I5)
C---
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  5.03/00 25/10/94  17.03.03  by  Stephen Burke
*CMZU:  3.03/02 04/05/92  17.15.39  by  Stephen J. Maxfield
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPLINT
C
C---  Routine finds all interections between any two planes (defined by
C---  clusters)from different wire orientations within the same
C---  supermodule
C---
C
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C--
C
      DIMENSION ZSMOD(2,3)
      DIMENSION  SMLSX(2), SMLSY(2), SMLSZ(2)
C
      REAL AMINV(2,2),PCVEC(2),CPINT(2),PONINT(3)
      REAL INLINE(3)
C
      INTEGER NSMLS(3)
C---
C
C---  define front and back of planar supermodule (f/b,sm).
C
      ZSMOD(1,1) = ZPLAN(1)
      ZSMOD(2,1) = ZPLAN(12)
      ZSMOD(1,2) = ZPLAN(13)
      ZSMOD(2,2) = ZPLAN(24)
      ZSMOD(1,3) = ZPLAN(25)
      ZSMOD(2,3) = ZPLAN(36)
C
C---  define inner and outter radii squared
C
      RMINSQ = RMIN**2
      RMAXSQ = RMAX**2
C
C--- Loop over supermodules
C
      DO 10 ISM = 1,3
C
C---  Set counter for supermodule
C
      NSMLS(ISM) = 0
C
C--- Loop over plane combinations in sm
C
      DO 20 IP1 = 1 + (ISM-1)*3 , 2 + (ISM-1)*3
C
C---  Loop on all tracks in this plane
C
      DO 30 IT1 = 1,NTC(IP1)
C
C---  remove all combinations with nothing in
C
      IF ( TC(3,IP1,IT1) .EQ. 0.0 ) GO TO 30
C
C---  Combination of planes
C
      DO 40 IP2 = IP1 + 1 , 3 + (ISM-1)*3
C
C---  Loop on all tracks in this plane
C
      DO 50 IT2 = 1,NTC(IP2)
C
C---  remove all combinations with nothing in
C
      IF ( TC(3,IP2,IT2) .EQ. 0.0 ) GO TO 50
C
C---  find cos of angle between track planes
C
      CTHETA = TPNORM(1,IP1,IT1) * TPNORM(1,IP2,IT2) +
     1         TPNORM(2,IP1,IT1) * TPNORM(2,IP2,IT2) +
     2         TPNORM(3,IP1,IT1) * TPNORM(3,IP2,IT2)
C
C---  Set up inverse matrix for finding point on line
C
      DET = 1.0 - CTHETA**2
      AMINV(1,1) = 1.0 / DET
      AMINV(2,2) = 1.0 / DET
      AMINV(1,2) = -CTHETA / DET
      AMINV(2,1) = -CTHETA / DET
C
C---  set up vector of plane definition constants
C
      PCVEC(1) = PCONST(IP1,IT1)
      PCVEC(2) = PCONST(IP2,IT2)
C
C---  find coefficient of point on line of intersection
C
      DO 100 I = 1,2
      CPINT(I) = 0.0
      DO 101 J = 1,2
      CPINT(I) = CPINT (I) + AMINV(I,J) * PCVEC(J)
  101 CONTINUE
  100 CONTINUE
C
C---  now we have line of intersection as
C      line = cpint + lambda * ( tpnorm1 vec tpnorm2 )
C
C---  calculate vector to line ponint
C
      DO 55 KK = 1,3
      PONINT(KK) = CPINT(1) * TPNORM(KK,IP1,IT1) +
     1             CPINT(2) * TPNORM(KK,IP2,IT2)
   55 CONTINUE
C
C---  Calculate direction vector of intersection
C
      INLINE(1) =
     1         (   TPNORM(3,IP1,IT1) * TPNORM(2,IP2,IT2)
     2           - TPNORM(2,IP1,IT1) * TPNORM(3,IP2,IT2)    )
      INLINE(2) =
     1       - (   TPNORM(3,IP1,IT1) * TPNORM(1,IP2,IT2)
     2           - TPNORM(1,IP1,IT1) * TPNORM(3,IP2,IT2)    )
      INLINE(3) =
     1         (   TPNORM(2,IP1,IT1) * TPNORM(1,IP2,IT2)
     2           - TPNORM(1,IP1,IT1) * TPNORM(2,IP2,IT2)    )
C
C---  solve for beginning and end of supermodule
C
      IF( INLINE(3) .NE. 0.0 ) THEN
      ALAMB = ( ZSMOD (1,ISM) - PONINT (3) ) / INLINE(3)
      ALAME = ( ZSMOD (2,ISM) - PONINT (3) ) / INLINE(3)
      ENDIF
C
      SMLSX(1) = PONINT(1) +  ALAMB*INLINE(1)
      SMLSY(1) = PONINT(2) +  ALAMB*INLINE(2)
      SMLSZ(1) = PONINT(3) +  ALAMB*INLINE(3)
C
C---  remove those segments not in sensitive volume
C
      RSQ = SMLSX(1)**2 + SMLSY(1)**2
      IF ( RSQ .LT. RMINSQ .OR. RSQ .GT. RMAXSQ )THEN
C---
C---
      ELSE
C---
C---
C
C---   Store line segment for later analysis and plot
C
C
C---  protect overwriting and store good primative segments
C
          IF (NSMLS(ISM) .GE. LIMSTO ) THEN
              CALL ERRLOG(211,'W:FPLINT: NSMLS(ISM) >= LIMSTO')
            GO TO 10
          ELSE
C---
              NSMLS(ISM) = NSMLS(ISM) + 1
              NSEGSM=NSMLS(ISM)
C---
          ENDIF
C
C---  calculate and store beginning and end points
C
      SMLS(1,1,NSEGSM,ISM) = PONINT(1) +  ALAMB*INLINE(1)
      SMLS(1,2,NSEGSM,ISM) = PONINT(1) +  ALAME*INLINE(1)
      SMLS(2,1,NSEGSM,ISM) = PONINT(2) +  ALAMB*INLINE(2)
      SMLS(2,2,NSEGSM,ISM) = PONINT(2) +  ALAME*INLINE(2)
      SMLS(3,1,NSEGSM,ISM) = PONINT(3) +  ALAMB*INLINE(3)
      SMLS(3,2,NSEGSM,ISM) = PONINT(3) +  ALAME*INLINE(3)
C
C---  record segment contributing track/planes
C---  smls(4,1 = it1*10 + ip1   smls(4,2 = it2*10 + ip2
C
      SMLS(4,1,NSEGSM,ISM) = IT1*10 + IP1
      SMLS(4,2,NSEGSM,ISM) = IT2*10 + IP2
      ENDIF
C
C---  End of loops
C
   50 CONTINUE
   40 CONTINUE
   30 CONTINUE
   20 CONTINUE
   10 CONTINUE
C
C---  find if segments are coincident
C
C---  Primary  (3 clusters)
C
      CALL FPFSEG(NSMLS)
C
C---  Secondary (2 clusters + >=1 digit)
C
      CALL FPFSSG(NSMLS)
C
C---  Tertiary  (2 clusters ONLY)
C
      CALL FPFTSG(NSMLS)
C---
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZ :  3.03/01 01/05/92  11.52.46  by  Gregorio Bernardi
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPPDEF
C---------------------------------------------------------------
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C
C---  Define the  vectors ALONG the planar planes
C
      DO 10 I = 1,9
      PLANE(1,I) =  COS(TP(I))
      PLANE(2,I) =  SIN(TP(I))
      PLANE(3,I) = 0.0
   10 CONTINUE
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  3.03/01 27/04/92  15.10.44  by  Stephen J. Maxfield
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPRCHI(PSEG,PERSEG,RSEG,RERSEG,Z,PROBCH)
**: FPRCHI.......SM. Bug fix. Protect against small Chisq for PROB.
**----------------------------------------------------------------------
C
C---  Routine calculates the probability of PSEG and RSEG
C---  being the same vector at Z given that PERSEG is the covariance
C---  matrix of PSEG both calculated at at Z=0
C---  (these are the quantities supplied by FPFYUV)
C---  and RERSEG is the covariance matrix of RSEG at Z
C
C---  The probability fron chisquare is returned as PROB
C
      DOUBLE PRECISION COVAR
C---
      DIMENSION PSEG(4) , PERSEG(4,4)
      DIMENSION RSEG(4) , RERSEG(4,4)
      DIMENSION COVAR(4,4) , DERIV(4,4) , WORK(16) , WM(4,4) , WV(4)
C
C---  Construct the derivative matrix
C
      CALL VZERO(DERIV,16)
      DO 10 I = 1,4
      DERIV(I,I) = 1.0
   10 CONTINUE
      DERIV(1,3) = Z
      DERIV(2,4) = Z
C
C---  Calculate X and Y at Z
C
      PSEG(1) = PSEG(1)  +  Z * PSEG(3)
      PSEG(2) = PSEG(2)  +  Z * PSEG(4)
C
C---  Propagate PERSEG FROM Z=0 TO Z
C
      CALL VZERO(WM,16)
      DO 24 I = 1,4
        DO 25 J = 1,4
         DO 26 K = 1,4
         WM(I,J) = WM(I,J) + PERSEG(I,K) * DERIV(J,K)
   26    CONTINUE
   25   CONTINUE
   24 CONTINUE
C---
      CALL VZERO(COVAR,32)
      DO 54 M = 1,4
        DO 55 K = 1,4
         DO 56 I = 1,4
         COVAR(M,K) = COVAR(M,K) + DERIV(M,I) * WM(I,K)
   56    CONTINUE
   55   CONTINUE
   54 CONTINUE
C---
C      DO 111 I = 1,4
C      WRITE(6,1001)(COVAR(I,J),J=1,4)
C 1001 FORMAT(1X,'COVAR',4e15.6)
C  111 CONTINUE
C      WRITE(6,*)'------------------------------'
C
C---  Add on the radial covariance matrix AT Z = Z
C
      DO 30 I = 1,4
      DO 31 J = 1,4
      COVAR(I,J) = COVAR(I,J) + RERSEG(I,J)
   31 CONTINUE
   30 CONTINUE
C
C---  Calculate weight matrix
C
      CALL DINV(4,COVAR,4,WORK,IFAIL)
        IF(IFAIL .NE. 0)THEN
          WRITE(6,*)' Matrix failed to invert in FPRCHI'
          PROBCH = 0.0
          RETURN
        ENDIF
C---
C      DO 131 I = 1,4
C      WRITE(6,1003)(COVAR(I,J),J=1,4)
C 1003 FORMAT(1X,'COVAR',4e15.6)
C  131 CONTINUE
C      WRITE(6,*)'------------------------------'
C
C---  Now calculate chisquare
C
      CHISQ = 0.0
      DO 40 I = 1,4
      WV(I) = 0.0
      DO 41 J = 1,4
      WV(I) = WV(I) +
     1        COVAR(I,J) * (PSEG(J) - RSEG(J))
   41 CONTINUE
      CHISQ = CHISQ + (PSEG(I) - RSEG(I)) * WV(I)
   40 CONTINUE
C
C---  Find probability
C
      IF(CHISQ .LT. 0.001) THEN
       PROBCH = 0.99999
      ELSE
       PROBCH = PROB(CHISQ,4)
      ENDIF
C      WRITE(6,*)PROBCH
C      WRITE(6,*)'------------------------------'
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  2.01/03 18/02/91  10.49.48  by  Girish D. Patel
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPSEG
C------------------------------------------------------------------------------
C
C---  Routine reconstructs planar line segments from digitisings
C
C------------------------------------------------------------------------------
C
C---   INPUT/drifts/  dstore(plane,wire,drift) =  drifts (not reflections)
C---   INPUT/drifts/  dstore(plane,wire,50)    =  number of drifts
C---   (please see routine drpak for interface to current patrec code)
C
C---   OUTPUT/plseg/  pw(digit,segment,sm)  = w of digitisings in segment
C---   OUTPUT/plseg/  pwc(digit,segment,sm) = fitted w of digitisings in segment
C---   OUTPUT/plseg/  prchi(segment,sm) = probability from chisquare of segment
C---   OUTPUT/plseg/  nfseg(sm)         = number of found segments
C---   OUTPUT/plseg/  xydxy         = (x,y (at first z value) ,dx/dz,dy/dz)(sm)
C---   OUTPUT/plseg/  exydxy        = covariance matrix of xydxy(sm)
C
C---  also in common /PLSEG/ and used by code to analyse segments and
C---  return an disconnected set (see MASKSG)
C
C     ASEGIN(SEG,SUPERMODULE)   = chisquare of segment
C
C     ISEGIN(1,SEG,SUPERMODULE) = 1st cluster-plane for segment
C     ISEGIN(2,SEG,SUPERMODULE) = 2nd cluster-plane for segment
C     ISEGIN(3,SEG,SUPERMODULE) = 3rd cluster-plane for segment
C     ISEGIN(4,SEG,SUPERMODULE) = number of degree of freedom for segment
C
C     NFSEG(SUPERMODULE)        = number of found segments per supermodule
C
C---  output
C
C     MASKSG(SEG,SUPERMODULE)   = 0   if SEGMENT allowed in disconnected set
C                               = -1  if SEGMENT disallowed in disconnected set
C
C
C-----------------------------------------------------------------------------
C
C---  In order to make this code compatible with compilers that
C---  unable to cope with more than 6 character names the following
C---  name translations have been necessary. Information is lost.
C
C---  stagger       =>      stager
C---  idstore       =>      idtore
C---  drift_store   =>      drsto
C---  digi_store    =>      idigst
C---  seg_table     =>      segtab
C---  n_seg_table   =>      nsgtab
C---  a_seg_table   =>      asgtab
C---  drift_mask    =>      drmask
C---  plane_wire    =>      plwire
C---  tolerance     =>      toler
C---  slope_max     =>      slmax
C---  dstore_mask   =>      dsmask
C---  iorient       =>      iorien
C---  gradient      =>      grad
C---  error_sc      =>      covslz
C---  val_maxseg    =>      vmxseg
C---  last_seg      =>      lstseg
C---  next_seg      =>      nxtseg
C---  fit_drift_end =>      fdrend
C---  fit_drift_start=>     fdrsta
C---  kseg_save     =>      kssave
C---  new_seg       =>      newseg
C---  loop_save     =>      lpsave
C---  matrix_a      =>      mtrixa
C---  err_xysxy     =>      exysxy
C---  num_seg_sm    =>      nsegsm
C---  val_seg       =>      valseg
C---  new_parseg    =>      parsgn
C---  new_errseg    =>      errsgn
C---  intline       =>      inline
C---  iplane1       =>      iplan1
C---  iplane2       =>      iplan2
C---  iplane3       =>      iplan3
C---  itrack1       =>      itrck1
C---  itrack2       =>      itrck2
C---  itrack3       =>      itrck3
C---  cponint       =>      cpint
C---  limstor       =>      limsto
C
C-------------------------------------------------------------------
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
C---
      DATA IFIRST/1/
C---
C---
C---
C---
C---
C---
C
C---  call routine to extract planar digitizings from standard program
C
C         CALL DRPAK
C
C---  calculate vectors along the 9 orientations of planar detector
C
          CALL FPPDEF
C
C---  Routine FPDG4 (sdig31 sdig32 sdig33 fpcfit) are called to
C---  find candidate clusters in each 4 wire orientation.
C---  (Clusters are a series of 3/4 digitizings in a given plnars
C---  orientation which are aligned within tolerance and represent
C---  to within a plane the tracjectory of a track. These clucters are
C---  a chosen disconnected set. )
C
         CALL FPDG4
C
C---  Calculate the normals of the planes formed by the tracks
C---  and four wires in the same orientation using FPCPLN
C--- (cluster --->plane calculation)
C
         CALL FPCPLN
C
C
C
C---  Now find all the lines of intersection between pairs of planes
C---  from clusters in different orientation within a supermodule
C---  and find the line segments from 3 coincidences of these intections
C---  within a tolerance acut. The line segments returned a disconnected
C---  set.
C
         CALL FPLINT
C
C---  FPLINT routine calls FPFSEG (finds correlations of 3
C---  intersections to form segments)
C
C---  FPFSEG calls FPFYUV to fit line segments and return fitted
C---  values and probabilites. (This rotine fills PLSEG)
C
C---  FPSEG then calls FPSGRF to determine a disconnected set of
C---  line segments. (see MASKSG description at top of this routine)
C
C
C---
C---
C---
C---
*
*
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  3.09/01 20/05/93  17.59.06  by  Stephen J. Maxfield
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPSGRF
**: FPSGRF.......SM. Bug fix. Protect against small Chisq for PROB.
**----------------------------------------------------------------------
C---------------------------------------------------------------
C
C     routine checks the connectivity of the found segments
C     and returns an optimized non-connected solution in MASKSG
C     0 = accept segment , -1 = reject segment
C
C---------------------------------------------------------------
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
C---
C---
C---  Local variables
C---
C---  ISGTAB (I,J) = segment number of Jth node connected to Ith node
C---  KSGTAB (I)   = number of segments connected to Ith node
C---  MXLIS        = list of nodes with maximum connectivity
C---  CHLIS        = weight asscociated with each node listed in MXLIS
C
      DIMENSION KSGTAB(MAXSEG) , FSGTAB(MAXSEG) , ISGTAB(MAXSEG,MAXCON)
      DIMENSION MXLIS(MAXSEG) , CHLIS(MAXSEG)
C
C---  input
C
C     ASEGIN(SEG,SUPERMODULE)   = chisquare of segment
C
C     ISEGIN(1,SEG,SUPERMODULE) = 1st cluster-plane for segment
C     ISEGIN(2,SEG,SUPERMODULE) = 2nd cluster-plane for segment
C     ISEGIN(3,SEG,SUPERMODULE) = 3rd cluster-plane for segment
C     ISEGIN(4,SEG,SUPERMODULE) = number of degree of freedom for segment
C
C     NFSEG(SUPERMODULE)        = number of found segments per supermodule
C
C---  output
C
C     MASKSG(SEG,SUPERMODULE)   = 0   if allowed
C                               = -1  if lost
C
C
C---  loop over supermodules
C
      DO 10 ISM = 1,3
C
C---  zero ksgtab
C
      DO 50 I = 1,MAXSEG
      KSGTAB(I) = 0
   50 CONTINUE
C
C---  construct connectivity table
C
C
C---  1st loop over segments
C
        DO 20 ISEG = 1,NFSEG(ISM)
          DO 21 KSEG = 1,NFSEG(ISM)
C
C---  remove if segs the same
C
          IF(ISEG.EQ.KSEG)GO TO 21
C
C---  search to see if any cluster planes in common
C
            DO 30 ID1 = 1,3
            ICP1 = ISEGIN(ID1,ISEG,ISM)
            DO 31 ID2 = 1,3
            ICP2 = ISEGIN(ID2,KSEG,ISM)
             IF(ICP1 .NE. ICP2) GO TO 31
C
C---  found one in common , increment counter , store connection
C
             KSGTAB(ISEG) = KSGTAB(ISEG) + 1
C
C---  trap out of bounds. has been known to happen in MC!
C
             IF(KSGTAB(ISEG) .GT. MAXCON) THEN
               GO TO 999
             ENDIF

             ISGTAB(ISEG,KSGTAB(ISEG)) = KSEG
C
C---  connection found skip furthur search of KSEG segment
C
             GO TO 21
   31       CONTINUE
   30       CONTINUE
   21     CONTINUE
   20   CONTINUE
C
C
C
C---  Start to remove connectivity
C
C
C---  Find the highest multiplicity
C
  500 CONTINUE
       IF( NFSEG(ISM) .GT. 0)THEN
       CALL VFLOAT(KSGTAB,FSGTAB,NFSEG(ISM))
       MXSEG = LVMAX(FSGTAB,NFSEG(ISM))
       IVMXSG = KSGTAB(MXSEG)
       ELSE
       IVMXSG = 0
       ENDIF
      IF(IVMXSG .EQ. 0) GO TO 600
C
C---   Loop over all segments and find those with same multiplicity
C
       NMXSG = 0
       DO 510 ISEG = 1,NFSEG(ISM)
C       IF(KSGTAB(ISEG) .LT. (IVMXSG-2)
       IF(KSGTAB(ISEG) .LT. (IVMXSG)
     1    .OR. KSGTAB(ISEG) .LE. 0) GO TO 510
         NMXSG = NMXSG + 1
         MXLIS(NMXSG) = ISEG
  510  CONTINUE
C
C---  Find which segment contributes most to chisquare
C
       DO 520 IMX = 1 , NMXSG
       MXSEG = MXLIS(IMX)
C
C---   Find probablility of link segments
C
       CHISUM = 0.0
       NDFSUM = 0
         DO 521 LSEG = 1,KSGTAB(MXSEG)
         CHISUM = CHISUM + ASEGIN(ISGTAB(MXSEG,LSEG),ISM)
         NDFSUM = NDFSUM + ISEGIN(4,ISGTAB(MXSEG,LSEG),ISM)
  521    CONTINUE
C
C---   Store probability of links less own prob
C
*      Fix for v.small chisq...
       IF(CHISUM .LT. 0.001) THEN
        PROB1 = 0.99999
       ELSE
        PROB1 = PROB(CHISUM,NDFSUM)
       ENDIF
       IF(ASEGIN(MXSEG,ISM) .LT. 0.001) THEN
        PROB2 = 0.99999
       ELSE
        PROB2 = PROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM))
       ENDIF
         CHLIS(IMX) = PROB1 - PROB2
*        CHLIS(IMX) = PROB(CHISUM,NDFSUM) -
*    1                PROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM))
  520  CONTINUE
C
C
C---  Find the segment with largest positive contribution
C
       MXPSEG = LVMAX(CHLIS,NMXSG)
       IWSEG  = MXLIS(MXPSEG)
C
C---  Remove all reference to this segment from connectivity table
C
      KSGTAB(IWSEG) = -1
      DO 530 IS = 1, NFSEG(ISM)
        IF( KSGTAB(IS) .LT. 1)GO TO 530
          DO 531 ILS = 1, KSGTAB(IS)
            IF(ISGTAB(IS,ILS) .NE. IWSEG) GO TO 531
              ISGTAB(IS,ILS) = ISGTAB(IS,KSGTAB(IS))
              KSGTAB(IS) = KSGTAB(IS) - 1
  531     CONTINUE
  530 CONTINUE
C
C
C---  Repeat proceedure on remaining nodes
C
      GO TO 500
C
C
C---   No connectivity remaining
C
  600 CONTINUE
C---
C---
C
C---  Write output bank
C
      DO 650 I = 1,NFSEG(ISM)
      MASKSG(I,ISM) = KSGTAB(I)
  650 CONTINUE
   10 CONTINUE
      RETURN

C
C---  Something horrible has happened - kill event!
C
  999 CONTINUE
      CALL ERRLOG(212,'W:FPSGRF: Too much confusion! Planar data off')
      DO 888 ISM = 1,3
       NFSEG(ISM) = 0
  888 CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  3.06/02 21/09/92  09.59.32  by  Stephen J. Maxfield
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPPPTZ(PERSEG,Z)
C
C---  Propagates planars error matrix from z=0 to z=z
C
      DOUBLE PRECISION COVAR,PERSEG
C---
      DIMENSION PERSEG(4,4)
      DIMENSION COVAR(4,4) , DERIV(4,4) , WM(4,4)
C
C---  Construct the derivative matrix
C
      CALL VZERO(DERIV,16)
      DO 10 I = 1,4
      DERIV(I,I) = 1.0
   10 CONTINUE
      DERIV(1,3) = Z
      DERIV(2,4) = Z
C
C---  Propagate PERSEG FROM Z=0 TO Z
C
      CALL VZERO(WM,16)
C
      DO 24 I = 1,4
        DO 25 J = 1,4
         DO 26 K = 1,4
         WM(I,J) = WM(I,J) + PERSEG(I,K) * DERIV(J,K)
   26    CONTINUE
   25   CONTINUE
   24 CONTINUE
C---
      CALL VZERO(COVAR,32)
      DO 54 M = 1,4
        DO 55 K = 1,4
         DO 56 I = 1,4
         COVAR(M,K) = COVAR(M,K) + DERIV(M,I) * WM(I,K)
   56    CONTINUE
   55   CONTINUE
   54 CONTINUE
C---
      CALL UCOPY(COVAR,PERSEG,32)
C---
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.12  by  Stephen Burke
*CMZU:  7.00/04 04/05/95  18.33.37  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.58  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.31  by  Stephen Burke
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPDG31(IP)
**: FPDG31 40000 RH. New steering parameter.
*------------------------------------------------------------------
**: FPDG31 30907 RH. Bug fix in cluster finding.
C------------------------------------------------------------------
C
C---  This routine finds cluters from 3 digitizings
C---  the missing digit on wire 2 or 3
C---  This routine should always be called from within FPDG4
C
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
C---
        CHARACTER SNTR*2
        CHARACTER SRESOL*5,PLWIRE*10
C---
        DIMENSION COVSLZ(2,2)
C---
        LOGICAL LGKS,LSPLIT
        REAL LINEX(2),LINEY(2),LOOP(50),W(4),PROBL(50)
        DOUBLE PRECISION Y(4)
C-------------------------------------------------------------------
C                     DIGITS ANALYSIS
C
C   The following arrays are used in the remainder of this routine
C
C       drsto(drift,wire_in_orientation):
C       This has both drift and reflection per orientation
C
C       ndrsto(wire_in_orientation):
C       Number of drifts + reflections on wire (Naughty)
C
C       drmask(drift,wire_in_orientation):
C       1.0 If digit or reflection used
C       0.0 If digit or reflection unused
C
C       idigst(wire_in_orientation,found_segment_candidate):
C       index of digitising associated with a particular
C       candidate segment for a particular wire
C
C       nsgtab(candidate_segment):
C       Number of candidate segments with which current segment
C       shares digitizings
C
C       segtab(candidate_segment,associated_ambiguous_segments):
C       segment index ambiguous with current segment
C
C-------------------------------------------------------------------
C
C---  tolerance for finding digitizings
C
      TOLER = RESOL*3.0
C
C---  define maximum slope to be found for segment
C
      SLMAX = 3.0
      SLYMIN = 0.005
      SLYMAX = 0.015
C
C---  Section to find 2d line segments
C
C---  loop over first and last wire in orientation
C---  but allow one of the intermediate points to be missing
C
C
C---  entry point for more relaxed segment search
C---  ifirst = 1 on first pass through
C
      IFIRST = 1
 1100 CONTINUE
      NSEG = 0
      DO 200 IO1 = 1 , NDRSTO(1)
      IF(DRMASK(IO1,1)) GO TO 200
C
C---  determine if dealing with a DIGIT IN A split cell
C
        IF(  IDCELL(IO1,1) .EQ.  1  .OR.
     1       IDCELL(IO1,1) .EQ. -1       )   THEN
           LSPLIT = .TRUE.
        ELSE
           LSPLIT = .FALSE.
        ENDIF
      DO 201 IO4 = 1 , NDRSTO(4)
      IF( LSPLIT .AND. IDCELL(IO1,1) .NE. IDCELL(IO4,4)
     1           .AND. IDCELL(IO4,4) .NE. 0            )
     1                                          GO TO 201
      IF(DRMASK(IO4,4)) GO TO 201
      LINEX(1) = 6.0
      LINEY(1) = DRSTO(IO1,1)
      LINEX(2) = (  ( ZPLAN(IP + 3) - ZPLAN(IP) ) / 10.0  ) + 6.0
      LINEY(2) = DRSTO(IO4,4)
      GRAD = (LINEY(2) - LINEY(1)) / (LINEX(2) - LINEX(1))
C
C---  On first pass filter out large slopes
C
      IF ( ABS(GRAD) .GT. SLMAX ) GO TO 201
C---
      IF ( (ABS(LINEY(1)) .GT. 100.0     .AND.
     1      GRAD*LINEY(1) .LT. 0.0                 ).OR.
     2      ABS(GRAD)     .GT. ABS(LINEY(1))*SLYMAX .OR.
     3      ABS(GRAD)     .LT. ABS(LINEY(1))*SLYMIN     ) GO TO 201
C
C---  use tolerance to find digitizings to form segments
C
C
C---  plane 2
C
      DO 202 IO2 = 1 , NDRSTO(2)
      IF(DRMASK(IO2,2)) GO TO 202
      IF( LSPLIT .AND. IDCELL(IO1,1) .NE. IDCELL(IO2,2)
     1           .AND. IDCELL(IO2,2) .NE. 0                   )
     1                                               GO TO 202
      PRED2 = LINEY(1) +  GRAD*
     1        (  ( ZPLAN(IP+1) - ZPLAN(IP) ) / 10.0  )
      IF( ABS( PRED2 - DRSTO(IO2,2)) .GT. TOLER)GO TO 202
C
C---  store the digitizing per segment found
C
      NSEG = NSEG + 1
        IF (NSEG .GT. MSEGLM) THEN
        CALL ERRLOG(204,'W:FPDG31: NSEG > MSEGLM')
          NSEG = NSEG - 1
          GO TO 202
        ENDIF
      IDIGST(1,NSEG) = IO1
      IDIGST(2,NSEG) = IO2
      IDIGST(3,NSEG) = -1
      IDIGST(4,NSEG) = IO4
  202 CONTINUE
C
C---  plane 3
C
      DO 203 IO3 = 1 , NDRSTO(3)
      IF(DRMASK(IO3,3)) GO TO 203
      IF( LSPLIT .AND. IDCELL(IO1,1) .NE. IDCELL(IO3,3)
     1           .AND. IDCELL(IO3,3) .NE. 0                   )
     1                                               GO TO 203
      PRED3 = LINEY(1) +  GRAD*
     1        (  ( ZPLAN(IP+2) - ZPLAN(IP) ) / 10.0 )
      IF( ABS( PRED3 - DRSTO(IO3,3)) .GT. TOLER)GO TO 203
C
C---  store the digitizing per segment found
C
      NSEG = NSEG + 1
        IF (NSEG .GT. MSEGLM) THEN
        CALL ERRLOG(205,'W:FPDG31: NSEG > MSEGLM')
          NSEG = NSEG - 1
          GO TO 205
        ENDIF
      IDIGST(1,NSEG) = IO1
      IDIGST(2,NSEG) = -1
      IDIGST(3,NSEG) = IO3
      IDIGST(4,NSEG) = IO4
  203 CONTINUE
  201 CONTINUE
  200 CONTINUE
  205 CONTINUE
C
C---  Now sort out which initial segments to keep
C
C
C---  Create SEGTAB showing interconnectivity
C
      CALL VZERO(NSGTAB,MSEGLM)
C
C---  loop over all segments
C
      DO 300 ISEG = 1,NSEG
      IF(NSGTAB(ISEG) .EQ. MSEGLM) GO TO 300
C
C---  loop over remaining segments
C
        DO 302 KSEG = ISEG+1,NSEG
        IF(NSGTAB(KSEG) .EQ. MSEGLM)GO TO 302
C
C---  comparison loop over each wire in turn
C
          DO 301 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
           IF(ID1 .EQ. -1) GO TO 301
             IF ( MOD(ID1,2) .EQ. 0 )THEN
              ID2 = ID1 - 1
             ELSE
              ID2 = ID1 + 1
             ENDIF
C
C---  has the same wire the same digit
C
                   IF( IDIGST(ID,KSEG) .NE. ID1  .AND.
     1                 IDIGST(ID,KSEG) .NE. ID2)   GO TO 301
                   NSGTAB(ISEG) = NSGTAB(ISEG) + 1
                   SEGTAB(ISEG,NSGTAB(ISEG)) = KSEG
                   NSGTAB(KSEG) = NSGTAB(KSEG) + 1
                   SEGTAB(KSEG,NSGTAB(KSEG)) = ISEG
                   GO TO 302
  301      CONTINUE
  302    CONTINUE
  300 CONTINUE
C
C--- remove nodes greater than or equal to 3
C
  400  CONTINUE
       IF( NSEG .LT. 1)GO TO 500
       CALL VFLOAT(NSGTAB,ASGTAB,NSEG)
       MXSEG = LVMAX(ASGTAB,NSEG)
       VMXSEG = ASGTAB(MXSEG)
       IF ( VMXSEG .LE. 2.0 ) GO TO 500
C
C--- greater than 2.0 so remove by setting nsgtab = -1.0
C
       NSGTAB(MXSEG) = -1.0
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 401 ISEG = 1, NSEG
       IF ( NSGTAB(ISEG) .EQ. -1) GO TO 401
         DO 402 ID = 1,NSGTAB(ISEG)
           IF( SEGTAB(ISEG,ID) .NE. MXSEG ) GO TO 402
            SEGTAB(ISEG,ID) = SEGTAB(ISEG,NSGTAB(ISEG))
            NSGTAB(ISEG) = NSGTAB(ISEG) - 1
  402 CONTINUE
  401 CONTINUE
      GO TO 400
  500 CONTINUE
C
C---  Now try to find loops and angles and eliminate
C
      DO 700 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 700
        VALSEG = NSGTAB(ISEG)
C
C---  Find first candidate with 2 links
C
        IF ( VALSEG .LT. 2.0 ) GO TO 700
C
C---  Now trace its path
C
          ILOOP = 1
          LOOP(ILOOP) = ISEG
          LSTSEG = ISEG
          NXTSEG = SEGTAB(ISEG,1)
C
C---  Entry point for step along chain
C
  703 CONTINUE
C
C---  Test if path at end
C
          IF( NSGTAB(NXTSEG) .LT. 2) GO TO 701
C
C---  Skip link if pointing back
C
          NEWSEG = SEGTAB(NXTSEG,1)
            IF ( NEWSEG .EQ. LSTSEG )THEN
            NEWSEG = SEGTAB(NXTSEG,2)
            ENDIF
C
C---  Store next element of chain
C
          ILOOP = ILOOP + 1
          LOOP(ILOOP) = NXTSEG
          LSTSEG = NXTSEG
          NXTSEG = NEWSEG
C
C---  Test if loop complete
C
          IF (NXTSEG .EQ. ISEG)GO TO 702
C
C---  Points to next element in chain
C
          GO TO 703
C
C---  End of branch one
C
  701 CONTINUE
C
C---  This cannot be a loop so kill off node
C
      NSGTAB(ISEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 801 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 801
         DO 802 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. ISEG ) GO TO 802
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  802 CONTINUE
  801 CONTINUE
C
C---  Now continue on node loop
C
      GO TO 700
C
C---  Loop complete
C
  702 CONTINUE
C
C---  Perform fits and eliminate all but one node in loop
C
      DO 860 KLOOP = 1,ILOOP
      KSEG = LOOP(KLOOP)
        DO 861 IWIRE = 1,4
          IF( IDIGST(IWIRE,KSEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,KSEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,KSEG) , IWIRE)**2
          ENDIF
  861 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
       PROBL(KLOOP) = PBCHI
  860 CONTINUE
C
C---  Keep only highest probability iff prob gt 10**-5
C
      LPSAVE = LVMAX(PROBL,ILOOP)
      VALPRB = PROBL(LPSAVE)
        IF( VALPRB .GT. 0.00001)THEN
          KSSAVE = LOOP(LPSAVE)
        ELSE
          KSSAVE = -1
        ENDIF
C
C---  now loop over segments and remove all but the saved
C
      DO 870 KLOOP = 1,ILOOP
      KSEG = LOOP(KLOOP)
      IF( KSEG .EQ. KSSAVE ) GO TO 870
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 871 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 871
         DO 872 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 872
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  872 CONTINUE
  871 CONTINUE
  870 CONTINUE
C
C
  700 CONTINUE
C
C--- now remove any pairs by fitting
C
      DO 900 ISEG = 1,NSEG
      IF ( NSGTAB(ISEG) .NE. 1)GO TO 900
C
C---  Found a pair so find partner
C
      ISEGP = SEGTAB(ISEG,1)
C
C---  fit the first possiblity
C
        DO 901 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
          ENDIF
  901 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ1,PBCHI1)
C
C---  Fit the second possiblity
C
        DO 902 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEGP) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEGP) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEGP) , IWIRE)**2
          ENDIF
  902 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ2,PBCHI2)
C
C---  Now remove the smaller probability segment
C
      IF ( PBCHI1 .GT. PBCHI2) THEN
      KSEG = ISEGP
      ELSE
      KSEG = ISEG
      ENDIF
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 911 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 911
         DO 912 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 912
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  912 CONTINUE
  911 CONTINUE
  900 CONTINUE
C
C---  ANALYSE remaining segments
C
      DO 600 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 600
C
C---  fit remaining segments
C
        DO 670 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
          ENDIF
  670 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
C---  find the absolute coordinate normal current wire orientation
C
         COWIRE = 0.0
C
C---  find which orientation plane (1-9) is current
C
      IPLANE = IP/4 + 1
C
C---  find fitted 'y' position at begining and end of 4 wire set
C---  fdrsta and fdrend respectively
C
      FDRSTA = COWIRE + ZERO
      FDREND = FDRSTA + SLOPE*
     1        (ZPLAN( (IPLANE)*4 ) - ZPLAN( (IPLANE-1)*4 + 1 ))
C
C---  Transform from orientation drift coordinates to global coordinates
C---  assuming that drift x coordinate is zero
C
*      XREAL1=   SIN( -TP(IPLANE) ) * FDRSTA
*      YREAL1=   COS( -TP(IPLANE) ) * FDRSTA
*      XREAL2=   SIN( -TP(IPLANE) ) * FDREND
*      YREAL2=   COS( -TP(IPLANE) ) * FDREND
      XREAL1=   -STP(IPLANE) * FDRSTA
      YREAL1=    CTP(IPLANE) * FDRSTA
      XREAL2=   -STP(IPLANE) * FDREND
      YREAL2=    CTP(IPLANE) * FDREND
C
C---  Fill track cluster banks and banks counter
C
C
C---  Increment cluster counter per plane
C
      IF( NTC(IPLANE) .GE. MAXCLU)THEN
        CALL ERRLOG(206,'W:FPDG31: NTC(IPLANE) > MAXCLU')
      ELSE
      NTC(IPLANE) = NTC(IPLANE) + 1
      ENDIF
      TC(1,IPLANE,NTC(IPLANE)) = XREAL2 - XREAL1
      TC(2,IPLANE,NTC(IPLANE)) = YREAL2 - YREAL1
      TC(3,IPLANE,NTC(IPLANE)) =
     1         ZPLAN((IPLANE)*4 ) - ZPLAN((IPLANE-1)*4 + 1)
C
C---  store toC
C
      TOC(1,IPLANE,NTC(IPLANE))=XREAL1
      TOC(2,IPLANE,NTC(IPLANE))=YREAL1
      TOC(3,IPLANE,NTC(IPLANE))=ZPLAN( (IPLANE-1)*4 + 1)
C
C---  store the digitisings associated with plane/track for final
C     fit
C
      DO 695 IWW = 1,4
          IF(IDIGST(IWW,ISEG) .NE. -1)THEN
          IDGISM(IWW,IPLANE,NTC(IPLANE)) =
     1               IDGIST( IDIGST(IWW,ISEG) , IWW )
          ELSE
          IDGISM(IWW,IPLANE,NTC(IPLANE)) = 0
          ENDIF
      TCYUV(IWW,IPLANE,NTC(IPLANE))    = COWIRE + Y(IWW)
      TCYUVW(IWW,IPLANE,NTC(IPLANE))   = W(IWW)
  695 CONTINUE
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  600 CONTINUE
C
C---  Now plot unused digitisizings
C
C
C---  Set drmask to 1.0 for used digits
C
      DO 750 ISEG = 1,NSEG
      IF(NSGTAB(ISEG) .EQ. -1) GO TO 750
        DO 751 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
           IF (ID1 .EQ. -1) GO TO 751
           IF ( MOD(ID1,2) .EQ. 0 )THEN
            ID2 = ID1 - 1
           ELSE
            ID2 = ID1 + 1
           ENDIF
          DRMASK(ID1,ID) = .TRUE.
          DRMASK(ID2,ID) = .TRUE.
  751 CONTINUE
  750 CONTINUE
C
C---  Now plot and count them
C
      IDUNUS = 0
      DO 760 IWIRE = 1,4
      DO 761 ID = 1,NDRSTO(IWIRE)
      IF( DRMASK(ID,IWIRE) ) GO TO 761
      DRIFT = DRSTO(ID,IWIRE)
      IDUNUS = IDUNUS + 1
  761 CONTINUE
  760 CONTINUE
C
C---  If first pass now loop back with 2*tolerance and 3*maxang
C
      IF (IDUNUS .NE. 0 .AND. IFIRST .EQ. 1)THEN
      IFIRST = 0
      TOLER = RESOL*8.0
      SLYMIN = 0.0
      SLYMAX = 1.0
      SLMAX = 5.0
      GO TO 1100
      ENDIF
      END
*CMZ :  8.04/00 27/06/96  20.28.13  by  Stephen Burke
*CMZU:  7.00/04 04/05/95  18.33.38  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.59  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.31  by  Stephen Burke
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPDG32(IP)
**: FPDG32 40000 RH. New steering parameter.
*------------------------------------------------------------------
**: FPDG32 30907 RH. Bug fix in cluster finding.
C------------------------------------------------------------------
C
C---  This routine finds clusters from 3 digitizings
C---  wires 1 2 3 only
C---  This routine should always be called from within FPDG4
C---  after FPDG31
C
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
        DIMENSION COVSLZ(2,2)
C---
        LOGICAL LGKS,LSPLIT
        REAL LINEX(2),LINEY(2),LOOP(50),W(4),PROBL(50)
        DOUBLE PRECISION Y(4),ONE
C-------------------------------------------------------------------
C                     DIGITS ANALYSIS
C
C   The following arrays are used in the remainder of this routine
C
C       drsto(drift,wire_in_orientation):
C       This has both drift and reflection per orientation
C
C       ndrsto(wire_in_orientation):
C       Number of drifts + reflections on wire (Naughty)
C
C       drmask(drift,wire_in_orientation):
C       1.0 If digit or reflection used
C       0.0 If digit or reflection unused
C
C       idigst(wire_in_orientation,found_segment_candidate):
C       index of digitising associated with a particular
C       candidate segment for a particular wire
C
C       nsgtab(candidate_segment):
C       Number of candidate segments with which current segment
C       shares digitizings
C
C       segtab(candidate_segment,associated_ambiguous_segments):
C       segment index ambiguous with current segment
C
C-------------------------------------------------------------------
C
C---  tolerance for finding digitizings
C
      TOLER = RESOL*3.0
C
C---  define maximum slope to be found for segment
C
      SLMAX = 3.0
      SLYMIN = 0.005
      SLYMAX = 0.015
C
C---  Section to find 2d line segments
C
C---  loop over first and last wire in orientation
C---  but allow one of the intermediate points to be missing
C
C
C---  entry point for more relaxed segment search
C---  ifirst = 1 on first pass through
C
      IFIRST = 1
 1100 CONTINUE
      NSEG = 0
      DO 200 IO1 = 1 , NDRSTO(1)
      IF(DRMASK(IO1,1)) GO TO 200
C
C---  determine if dealing with a split cell
C
        IF(  IDCELL(IO1,1) .EQ.  1  .OR.
     1       IDCELL(IO1,1) .EQ. -1       )   THEN
           LSPLIT = .TRUE.
        ELSE
           LSPLIT = .FALSE.
        ENDIF
      DO 201 IO3 = 1 , NDRSTO(3)
      IF(DRMASK(IO3,3)) GO TO 201
      IF( LSPLIT .AND. IDCELL(IO1,1) .NE. IDCELL(IO3,3)
     1           .AND. IDCELL(IO3,3) .NE. 0                  )
     1                                               GO TO 201
      LINEX(1) = 9.0
      LINEY(1) = DRSTO(IO1,1)
      LINEX(2) = (  ( ZPLAN(IP+2) - ZPLAN(IP) ) / 10.0  )
     1            + 9.0
      LINEY(2) = DRSTO(IO3,3)
      GRAD = (LINEY(2) - LINEY(1)) / (LINEX(2) - LINEX(1))
C
C---  On first pass filter out large slopes
C
      IF ( ABS(GRAD) .GT. SLMAX ) GO TO 201
C---
      IF ( (ABS(LINEY(1)) .GT. 100.0     .AND.
     1      GRAD*LINEY(1) .LT. 0.0                 ).OR.
     2      ABS(GRAD)     .GT. ABS(LINEY(1))*SLYMAX .OR.
     3      ABS(GRAD)     .LT. ABS(LINEY(1))*SLYMIN     ) GO TO 201
C
C---  use tolerance to find digitizings to form segments
C
C
C---  plane 2
C
      DO 202 IO2 = 1 , NDRSTO(2)
      IF(DRMASK(IO2,2)) GO TO 202
      IF( LSPLIT .AND. IDCELL(IO1,1) .NE. IDCELL(IO2,2)
     1           .AND. IDCELL(IO2,2) .NE. 0                  )
     1                                               GO TO 202
      PRED2 = LINEY(1) +  GRAD*
     1        (  ( ZPLAN(IP+1) - ZPLAN(IP) ) / 10.0  )
      IF( ABS( PRED2 - DRSTO(IO2,2)) .GT. TOLER)GO TO 202
C
C---  store the digitizing per segment found
C
      NSEG = NSEG + 1
        IF (NSEG .GT. MSEGLM) THEN
        CALL ERRLOG(207,'W:FPDG32: NSEG > MSEGLM')
          NSEG = NSEG - 1
          GO TO 205
        ENDIF
      IDIGST(1,NSEG) = IO1
      IDIGST(2,NSEG) = IO2
      IDIGST(3,NSEG) = IO3
      IDIGST(4,NSEG) = -1
  202 CONTINUE
  201 CONTINUE
  200 CONTINUE
  205 CONTINUE
C
C---  Now sort out which initial segments to keep
C
C
C---  Create segtab showing interconnectivity
C
      CALL VZERO(NSGTAB,MSEGLM)
      DO 300 ISEG = 1,NSEG
      IF(NSGTAB(ISEG) .EQ. MSEGLM)GO TO 300
C
C---  loop over remaining segments
C
        DO 302 KSEG = ISEG+1,NSEG
        IF(NSGTAB(KSEG) .EQ. MSEGLM)GO TO 302
C
C---  comparison loop over each wire in turn
C
          DO 301 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
           IF(ID1 .EQ. -1) GO TO 301
             IF ( MOD(ID1,2) .EQ. 0 )THEN
              ID2 = ID1 - 1
             ELSE
              ID2 = ID1 + 1
             ENDIF
C
C---  has the same wire the same digit
C
                   IF( IDIGST(ID,KSEG) .NE. ID1  .AND.
     1                 IDIGST(ID,KSEG) .NE. ID2)   GO TO 301
                   NSGTAB(ISEG) = NSGTAB(ISEG) + 1
                   SEGTAB(ISEG,NSGTAB(ISEG)) = KSEG
                   NSGTAB(KSEG) = NSGTAB(KSEG) + 1
                   SEGTAB(KSEG,NSGTAB(KSEG)) = ISEG
                   GO TO 302
  301      CONTINUE
  302    CONTINUE
  300 CONTINUE
C
C--- remove nodes greater than or equal to 3
C
  400  CONTINUE
       IF( NSEG .LT. 1)GO TO 500
       CALL VFLOAT(NSGTAB,ASGTAB,NSEG)
       MXSEG = LVMAX(ASGTAB,NSEG)
       VMXSEG = ASGTAB(MXSEG)
       IF ( VMXSEG .LE. 2.0 ) GO TO 500
C
C--- greater than 2.0 so remove by setting nsgtab = -1.0
C
       NSGTAB(MXSEG) = -1.0
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 401 ISEG = 1, NSEG
       IF ( NSGTAB(ISEG) .EQ. -1) GO TO 401
         DO 402 ID = 1,NSGTAB(ISEG)
           IF( SEGTAB(ISEG,ID) .NE. MXSEG ) GO TO 402
            SEGTAB(ISEG,ID) = SEGTAB(ISEG,NSGTAB(ISEG))
            NSGTAB(ISEG) = NSGTAB(ISEG) - 1
  402 CONTINUE
  401 CONTINUE
      GO TO 400
  500 CONTINUE
C
C---  Now try to find loops and angles and eliminate
C
      DO 700 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 700
        VALSEG = NSGTAB(ISEG)
C
C---  Find first candidate with 2 links
C
        IF ( VALSEG .LT. 2.0 ) GO TO 700
C
C---  Now trace its path
C
          ILOOP = 1
          LOOP(ILOOP) = ISEG
          LSTSEG = ISEG
          NXTSEG = SEGTAB(ISEG,1)
C
C---  Entry point for step along chain
C
  703 CONTINUE
C
C---  Test if path at end
C
          IF( NSGTAB(NXTSEG) .LT. 2) GO TO 701
C
C---  Skip link if pointing back
C
          NEWSEG = SEGTAB(NXTSEG,1)
            IF ( NEWSEG .EQ. LSTSEG )THEN
            NEWSEG = SEGTAB(NXTSEG,2)
            ENDIF
C
C---  Store next element of chain
C
          ILOOP = ILOOP + 1
          LOOP(ILOOP) = NXTSEG
          LSTSEG = NXTSEG
          NXTSEG = NEWSEG
C
C---  Test if loop complete
C
          IF (NXTSEG .EQ. ISEG)GO TO 702
C
C---  Points to next element in chain
C
          GO TO 703
C
C---  End of branch one
C
  701 CONTINUE
C
C---  This cannot be a loop so kill off node
C
      NSGTAB(ISEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 801 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 801
         DO 802 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. ISEG ) GO TO 802
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  802 CONTINUE
  801 CONTINUE
C
C---  Now continue on node loop
C
      GO TO 700
C
C---  Loop complete
C
  702 CONTINUE
C
C---  Perform fits and eliminate all but one node in loop
C
      DO 860 KLOOP = 1,ILOOP
      KSEG = LOOP(KLOOP)
        DO 861 IWIRE = 1,4
          IF( IDIGST(IWIRE,KSEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,KSEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,KSEG) , IWIRE)**2
          ENDIF
  861 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
       PROBL(KLOOP) = PBCHI
  860 CONTINUE
C
C---  Keep only highest probability iff prob gt 10**-5
C
      LPSAVE = LVMAX(PROBL,ILOOP)
      VALPRB = PROBL(LPSAVE)
        IF( VALPRB .GT. 0.00001)THEN
          KSSAVE = LOOP(LPSAVE)
        ELSE
          KSSAVE = -1
        ENDIF
C
C---  now loop over segments and remove all but the saved
C
      DO 870 KLOOP = 1,ILOOP
      KSEG = LOOP(KLOOP)
      IF( KSEG .EQ. KSSAVE ) GO TO 870
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 871 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 871
         DO 872 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 872
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  872 CONTINUE
  871 CONTINUE
  870 CONTINUE
  875 CONTINUE
C
  700 CONTINUE
C
C--- now remove any pairs by fitting
C
      DO 900 ISEG = 1,NSEG
      IF ( NSGTAB(ISEG) .NE. 1)GO TO 900
C
C---  Found a pair so find partner
C
      ISEGP = SEGTAB(ISEG,1)
C
C---  fit the first possiblity
C
        DO 901 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
          ENDIF
  901 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ1,PBCHI1)
C
C---  Fit the second possiblity
C
        DO 902 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEGP) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEGP) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEGP) , IWIRE)**2
          ENDIF
  902 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ2,PBCHI2)
C
C---  Now remove the smaller probability segment
C
      IF ( PBCHI1 .GT. PBCHI2) THEN
      KSEG = ISEGP
      ELSE
      KSEG = ISEG
      ENDIF
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 911 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 911
         DO 912 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 912
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  912 CONTINUE
  911 CONTINUE
  900 CONTINUE
C
C---  Now draw remaining segments
C
      DO 600 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 600
C
C---  fit remaining segments
C
        DO 670 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
          ENDIF
  670 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
C---  find the absolute coordinate normal current wire orientation
C
      COWIRE = 0.0
C
C---  find which orientation plane (1-9) is current
C
      IPLANE = IP/4 + 1
C
C---  find fitted 'y' position at begining and end of 4 wire set
C---  fdrsta and fdrend respectively
C
      FDRSTA = COWIRE + ZERO
      FDREND = FDRSTA + SLOPE*(
     1         ZPLAN( (IPLANE)*4 ) - ZPLAN( (IPLANE-1)*4 + 1) )
C
C---  Transform from orientation drift coordinates to global coordinates
C---  assuming that drift x coordinate is zero
C
      XREAL1=  -STP(IPLANE) * FDRSTA
      YREAL1=   CTP(IPLANE) * FDRSTA
      XREAL2=  -STP(IPLANE) * FDREND
      YREAL2=   CTP(IPLANE) * FDREND
C
C---  Fill track cluster banks and banks counter
C
C
C---  Increment cluster counter per plane
C
      IF( NTC(IPLANE) .GE. MAXCLU)THEN
        CALL ERRLOG(208,'W:FPDG32: NTC(IPLANE) > MAXCLU')
      ELSE
      NTC(IPLANE) = NTC(IPLANE) + 1
      ENDIF
      TC(1,IPLANE,NTC(IPLANE)) = XREAL2 - XREAL1
      TC(2,IPLANE,NTC(IPLANE)) = YREAL2 - YREAL1
      TC(3,IPLANE,NTC(IPLANE)) =
     1     ZPLAN((IPLANE)*4 ) - ZPLAN((IPLANE-1)*4 + 1)
C
C---  store toc
C
      TOC(1,IPLANE,NTC(IPLANE))=XREAL1
      TOC(2,IPLANE,NTC(IPLANE))=YREAL1
      TOC(3,IPLANE,NTC(IPLANE))=ZPLAN( (IPLANE-1)*4 + 1)
C
C---  store the digitisings associated with plane/track for final
C     fit
C
      DO 695 IWW = 1,4
          IF(IDIGST(IWW,ISEG) .NE. -1)THEN
          IDGISM(IWW,IPLANE,NTC(IPLANE)) =
     1               IDGIST( IDIGST(IWW,ISEG) , IWW )
          ELSE
          IDGISM(IWW,IPLANE,NTC(IPLANE)) = 0
          ENDIF
      TCYUV(IWW,IPLANE,NTC(IPLANE))    = COWIRE + Y(IWW)
      TCYUVW(IWW,IPLANE,NTC(IPLANE))   = W(IWW)
  695 CONTINUE
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  600 CONTINUE
C
C---  Now plot unused digitisizings
C
C
C---  Set drmask to 1.0 for used digits
C
      DO 750 ISEG = 1,NSEG
      IF(NSGTAB(ISEG) .EQ. -1) GO TO 750
        DO 751 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
           IF (ID1 .EQ. -1) GO TO 751
           IF ( MOD(ID1,2) .EQ. 0 )THEN
            ID2 = ID1 - 1
           ELSE
            ID2 = ID1 + 1
           ENDIF
          DRMASK(ID1,ID) = .TRUE.
          DRMASK(ID2,ID) = .TRUE.
  751 CONTINUE
  750 CONTINUE
      IDUNUS = 0
      DO 760 IWIRE = 1,4
      DO 761 ID = 1,NDRSTO(IWIRE)
      IF( DRMASK(ID,IWIRE) ) GO TO 761
      DRIFT = DRSTO(ID,IWIRE)
      IDUNUS = IDUNUS + 1
  761 CONTINUE
  760 CONTINUE
C
C---  If first pass now loop back with 2*tolerance and 3*maxang
C
      IF (IDUNUS .NE. 0 .AND. IFIRST .EQ. 1)THEN
      IFIRST = 0
      TOLER = RESOL*8.0
      SLYMAX = 1.0
      SLYMIN = 0.0
      SLMAX = 5.0
      GO TO 1100
      ENDIF
      END
*CMZ :  8.04/00 27/06/96  20.28.13  by  Stephen Burke
*CMZU:  7.00/04 04/05/95  18.33.38  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.57.59  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.32  by  Stephen Burke
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPDG33(IP)
**: FPDG33 40000 RH. New steering parameter.
*------------------------------------------------------------------
**: FPDG33 30907 RH. Bug fix in cluster finding.
C------------------------------------------------------------------
C
C---  This routine finds clusters from 3 digitizings
C---  wires 2 3 4 only
C---  This routine should always be called from within FPDG4
C---  after FPDG31
C
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
        DIMENSION COVSLZ(2,2)
C---
        LOGICAL LGKS,LSPLIT
        REAL LINEX(2),LINEY(2),LOOP(50),W(4),PROBL(50)
        DOUBLE PRECISION Y(4),ONE
C-------------------------------------------------------------------
C                     DIGITS ANALYSIS
C
C   The following arrays are used in the remainder of this routine
C
C       drsto(drift,wire_in_orientation):
C       This has both drift and reflection per orientation
C
C       ndrsto(wire_in_orientation):
C       Number of drifts + reflections on wire (Naughty)
C
C       drmask(drift,wire_in_orientation):
C       1.0 If digit or reflection used
C       0.0 If digit or reflection unused
C
C       idigst(wire_in_orientation,found_segment_candidate):
C       index of digitising associated with a particular
C       candidate segment for a particular wire
C
C       nsgtab(candidate_segment):
C       Number of candidate segments with which current segment
C       shares digitizings
C
C       segtab(candidate_segment,associated_ambiguous_segments):
C       segment index ambiguous with current segment
C
C-------------------------------------------------------------------
C
C---  tolerance for finding digitizings
C
      TOLER = RESOL*3.0
C
C---  define maximum slope to be found for segment
C
      SLMAX = 3.0
      SLYMIN = 0.005
      SLYMAX = 0.015
C
C---  Section to find 2d line segments
C
C---  loop over first and last wire in orientation
C---  but allow one of the intermediate points to be missing
C
C
C---  entry point for more relaxed segment search
C---  ifirst = 1 on first pass through
C
      IFIRST = 1
 1100 CONTINUE
      NSEG = 0
      DO 200 IO2 = 1 , NDRSTO(2)
      IF(DRMASK(IO2,2)) GO TO 200
C
C---  determine if dealing with a split cell
C
        IF(  IDCELL(IO2,2) .EQ.  1  .OR.
     1       IDCELL(IO2,2) .EQ. -1       )   THEN
           LSPLIT = .TRUE.
        ELSE
           LSPLIT = .FALSE.
        ENDIF
      DO 201 IO4 = 1 , NDRSTO(4)
      IF(DRMASK(IO4,4)) GO TO 201
      IF( LSPLIT .AND. IDCELL(IO2,2) .NE. IDCELL(IO4,4)
     1           .AND. IDCELL(IO4,4) .NE. 0                   )
     1                                               GO TO 201
      LINEX(1) = 9.0
      LINEY(1) = DRSTO(IO2,2)
      LINEX(2) = (  ( ZPLAN(IP+3) - ZPLAN(IP+1) ) / 10.0  )
     1            + 9.0
      LINEY(2) = DRSTO(IO4,4)
      GRAD = (LINEY(2) - LINEY(1)) / (LINEX(2) - LINEX(1))
C
C---  On first pass filter out large slopes
C
      IF ( ABS(GRAD) .GT. SLMAX ) GO TO 201
C---
      IF ( (ABS(LINEY(1)) .GT. 100.0     .AND.
     1      GRAD*LINEY(1) .LT. 0.0                 ).OR.
     2      ABS(GRAD)     .GT. ABS(LINEY(1))*SLYMAX .OR.
     3      ABS(GRAD)     .LT. ABS(LINEY(1))*SLYMIN     ) GO TO 201
C
C---  use tolerance to find digitizings to form segments
C
C
C---  plane 2
C
      DO 202 IO3 = 1 , NDRSTO(3)
      IF(DRMASK(IO3,3)) GO TO 202
      IF( LSPLIT .AND. IDCELL(IO2,2) .NE. IDCELL(IO3,3)
     1           .AND. IDCELL(IO3,3) .NE. 0                  )
     1                                               GO TO 202
      PRED2 = LINEY(1) +  GRAD*
     1        (  ( ZPLAN(IP+2) - ZPLAN(IP+1) ) / 10.0  )
      IF( ABS( PRED2 - DRSTO(IO3,3)) .GT. TOLER)GO TO 202
C
C---  store the digitizing per segment found
C
      NSEG = NSEG + 1
        IF (NSEG .GT. MSEGLM) THEN
        CALL ERRLOG(209,'W:FPDG33: NSEG > MSEGLM')
          NSEG = NSEG - 1
          GO TO 205
        ENDIF
      IDIGST(1,NSEG) = -1
      IDIGST(2,NSEG) = IO2
      IDIGST(3,NSEG) = IO3
      IDIGST(4,NSEG) = IO4
  202 CONTINUE
  201 CONTINUE
  200 CONTINUE
  205 CONTINUE
C
C---  Now sort out which initial segments to keep
C
C
C---  Create segtab showing interconnectivity
C
      CALL VZERO(NSGTAB,MSEGLM)
      DO 300 ISEG = 1,NSEG
      IF(NSGTAB(ISEG) .EQ. MSEGLM)GO TO 300
C
C---  loop over remaining segments
C
        DO 302 KSEG = ISEG+1,NSEG
        IF(NSGTAB(KSEG) .EQ. MSEGLM)GO TO 302
C
C---  comparison loop over each wire in turn
C
          DO 301 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
           IF(ID1 .EQ. -1) GO TO 301
             IF ( MOD(ID1,2) .EQ. 0 )THEN
              ID2 = ID1 - 1
             ELSE
              ID2 = ID1 + 1
             ENDIF
C
C---  has the same wire the same digit
C
                   IF( IDIGST(ID,KSEG) .NE. ID1  .AND.
     1                 IDIGST(ID,KSEG) .NE. ID2)   GO TO 301
                   NSGTAB(ISEG) = NSGTAB(ISEG) + 1
                   SEGTAB(ISEG,NSGTAB(ISEG)) = KSEG
                   NSGTAB(KSEG) = NSGTAB(KSEG) + 1
                   SEGTAB(KSEG,NSGTAB(KSEG)) = ISEG
                   GO TO 302
  301      CONTINUE
  302    CONTINUE
  300 CONTINUE
C
C--- remove nodes greater than or equal to 3
C
  400  CONTINUE
       IF( NSEG .LT. 1)GO TO 500
       CALL VFLOAT(NSGTAB,ASGTAB,NSEG)
       MXSEG = LVMAX(ASGTAB,NSEG)
       VMXSEG = ASGTAB(MXSEG)
       IF ( VMXSEG .LE. 2.0 ) GO TO 500
C
C--- greater than 2.0 so remove by setting nsgtab = -1.0
C
       NSGTAB(MXSEG) = -1.0
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 401 ISEG = 1, NSEG
       IF ( NSGTAB(ISEG) .EQ. -1) GO TO 401
         DO 402 ID = 1,NSGTAB(ISEG)
           IF( SEGTAB(ISEG,ID) .NE. MXSEG ) GO TO 402
            SEGTAB(ISEG,ID) = SEGTAB(ISEG,NSGTAB(ISEG))
            NSGTAB(ISEG) = NSGTAB(ISEG) - 1
  402 CONTINUE
  401 CONTINUE
      GO TO 400
  500 CONTINUE
C
C---  Now try to find loops and angles and eliminate
C
      DO 700 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 700
        VALSEG = NSGTAB(ISEG)
C
C---  Find first candidate with 2 links
C
        IF ( VALSEG .LT. 2.0 ) GO TO 700
C
C---  Now trace its path
C
          ILOOP = 1
          LOOP(ILOOP) = ISEG
          LSTSEG = ISEG
          NXTSEG = SEGTAB(ISEG,1)
C
C---  Entry point for step along chain
C
  703 CONTINUE
C
C---  Test if path at end
C
          IF( NSGTAB(NXTSEG) .LT. 2) GO TO 701
C
C---  Skip link if pointing back
C
          NEWSEG = SEGTAB(NXTSEG,1)
            IF ( NEWSEG .EQ. LSTSEG )THEN
            NEWSEG = SEGTAB(NXTSEG,2)
            ENDIF
C
C---  Store next element of chain
C
          ILOOP = ILOOP + 1
          LOOP(ILOOP) = NXTSEG
          LSTSEG = NXTSEG
          NXTSEG = NEWSEG
C
C---  Test if loop complete
C
          IF (NXTSEG .EQ. ISEG)GO TO 702
C
C---  Points to next element in chain
C
          GO TO 703
C
C---  End of branch one
C
  701 CONTINUE
C
C---  This cannot be a loop so kill off node
C
      NSGTAB(ISEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 801 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 801
         DO 802 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. ISEG ) GO TO 802
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  802 CONTINUE
  801 CONTINUE
C
C---  Now continue on node loop
C
      GO TO 700
C
C---  Loop complete
C
  702 CONTINUE
C
C---  Perform fits and eliminate all but one node in loop
C
      DO 860 KLOOP = 1,ILOOP
      KSEG = LOOP(KLOOP)
        DO 861 IWIRE = 1,4
          IF( IDIGST(IWIRE,KSEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,KSEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,KSEG) , IWIRE)**2
          ENDIF
  861 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
       PROBL(KLOOP) = PBCHI
  860 CONTINUE
C
C---  Keep only highest probability iff prob gt 10**-5
C
      LPSAVE = LVMAX(PROBL,ILOOP)
      VALPRB = PROBL(LPSAVE)
        IF( VALPRB .GT. 0.00001)THEN
          KSSAVE = LOOP(LPSAVE)
        ELSE
          KSSAVE = -1
        ENDIF
C
C---  now loop over segments and remove all but the saved
C
      DO 870 KLOOP = 1,ILOOP
      KSEG = LOOP(KLOOP)
      IF( KSEG .EQ. KSSAVE ) GO TO 870
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 871 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 871
         DO 872 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 872
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  872 CONTINUE
  871 CONTINUE
  870 CONTINUE
  875 CONTINUE
C
  700 CONTINUE
C
C--- now remove any pairs by fitting
C
      DO 900 ISEG = 1,NSEG
      IF ( NSGTAB(ISEG) .NE. 1)GO TO 900
C
C---  Found a pair so find partner
C
      ISEGP = SEGTAB(ISEG,1)
C
C---  fit the first possiblity
C
        DO 901 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
          ENDIF
  901 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ1,PBCHI1)
C
C---  Fit the second possiblity
C
        DO 902 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEGP) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEGP) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEGP) , IWIRE)**2
          ENDIF
  902 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ2,PBCHI2)
C
C---  Now remove the smaller probability segment
C
      IF ( PBCHI1 .GT. PBCHI2) THEN
      KSEG = ISEGP
      ELSE
      KSEG = ISEG
      ENDIF
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 911 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 911
         DO 912 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 912
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  912 CONTINUE
  911 CONTINUE
  900 CONTINUE
C
C---  Now draw remaining segments
C
      DO 600 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 600
C
C---  fit remaining segments
C
        DO 670 IWIRE = 1,4
          IF( IDIGST(IWIRE,ISEG) .EQ. -1)THEN
          Y(IWIRE) = 0.0
          W(IWIRE) = 0.0
          ELSE
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
          ENDIF
  670 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
C---  find the absolute coordinate normal current wire orientation
C
      COWIRE = 0.0
C
C---  find which orientation plane (1-9) is current
C
      IPLANE = IP/4 + 1
C
C---  find fitted 'y' position at begining and end of 4 wire set
C---  fdrsta and fdrend respectively
C
      FDRSTA = COWIRE + ZERO
      FDREND = FDRSTA + SLOPE*(
     1         ZPLAN( (IPLANE)*4 ) - ZPLAN( (IPLANE-1)*4 + 1) )
C
C---  Transform from orientation drift coordinates to global coordinates
C---  assuming that drift x coordinate is zero
C
      XREAL1=  -STP(IPLANE) * FDRSTA
      YREAL1=   CTP(IPLANE) * FDRSTA
      XREAL2=  -STP(IPLANE) * FDREND
      YREAL2=   CTP(IPLANE) * FDREND
C
C---  Fill track cluster banks and banks counter
C
C
C---  Increment cluster counter per plane
C
      IF( NTC(IPLANE) .GE. MAXCLU)THEN
        CALL ERRLOG(210,'W:FPDG33: NTC(IPLANE) > MAXCLU')
      ELSE
      NTC(IPLANE) = NTC(IPLANE) + 1
      ENDIF
      TC(1,IPLANE,NTC(IPLANE)) = XREAL2 - XREAL1
      TC(2,IPLANE,NTC(IPLANE)) = YREAL2 - YREAL1
      TC(3,IPLANE,NTC(IPLANE)) =
     1     ZPLAN((IPLANE)*4 ) - ZPLAN((IPLANE-1)*4 + 1)
C
C---  store toc
C
      TOC(1,IPLANE,NTC(IPLANE))=XREAL1
      TOC(2,IPLANE,NTC(IPLANE))=YREAL1
      TOC(3,IPLANE,NTC(IPLANE))=ZPLAN( (IPLANE-1)*4 + 1)
C
C---  store the digitisings associated with plane/track for final
C     fit
C
      DO 695 IWW = 1,4
          IF(IDIGST(IWW,ISEG) .NE. -1)THEN
          IDGISM(IWW,IPLANE,NTC(IPLANE)) =
     1               IDGIST( IDIGST(IWW,ISEG) , IWW )
          ELSE
          IDGISM(IWW,IPLANE,NTC(IPLANE)) = 0
          ENDIF
      TCYUV(IWW,IPLANE,NTC(IPLANE))    = COWIRE + Y(IWW)
      TCYUVW(IWW,IPLANE,NTC(IPLANE))   = W(IWW)
  695 CONTINUE
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  600 CONTINUE
C
C---  Now plot unused digitisizings
C
C
C---  Set drmask to 1.0 for used digits
C
      DO 750 ISEG = 1,NSEG
      IF(NSGTAB(ISEG) .EQ. -1) GO TO 750
        DO 751 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
           IF (ID1 .EQ. -1) GO TO 751
           IF ( MOD(ID1,2) .EQ. 0 )THEN
            ID2 = ID1 - 1
           ELSE
            ID2 = ID1 + 1
           ENDIF
          DRMASK(ID1,ID) = .TRUE.
          DRMASK(ID2,ID) = .TRUE.
  751 CONTINUE
  750 CONTINUE
      IDUNUS = 0
      DO 760 IWIRE = 1,4
      DO 761 ID = 1,NDRSTO(IWIRE)
      IF( DRMASK(ID,IWIRE) ) GO TO 761
      DRIFT = DRSTO(ID,IWIRE)
      IDUNUS = IDUNUS + 1
  761 CONTINUE
  760 CONTINUE
C
C---  If first pass now loop back with 2*tolerance and 3*maxang
C
      IF (IDUNUS .NE. 0 .AND. IFIRST .EQ. 1)THEN
      IFIRST = 0
      TOLER = RESOL*8.0
      SLYMAX = 1.0
      SLYMIN = 0.0
      SLMAX = 5.0
      GO TO 1100
      ENDIF
      END
*CMZ :  8.04/00 27/06/96  20.28.13  by  Stephen Burke
*CMZU:  7.02/11 27/10/95  20.33.42  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.00  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.32  by  Stephen Burke
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPUDAT
**: FPUDAT 40000 SM. New definition of dead wire flag.
**----------------------------------------------------------------------
**: FPUDAT 30907 RP. Farm changes.
C------------------------------------------------------------------
*
*     Unpack Digitisations from bank FRPE.
*     Create intermediate bank FPLC containing local
*     coordinates
*
*     Store hits in PLANAR H1WORK for Pattern Recognition
*
*     Called once per event. Needs previous call to FTCORG
*     to create corrected geometry bank FPG1
*

*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
*     Max allowable bad hit flag...(To be gotten from bank sometime)
      PARAMETER(IFRBAD=128)
      PARAMETER(NBN=0)
*     Locators for FPG1 bank
      PARAMETER(IPDEAD=1)
      PARAMETER(IPPPHP=2)
      PARAMETER(IPPSTP=3)
*     Locators for FPLC bank
      PARAMETER(IPPCLN=1)
      PARAMETER(IPPDRF=2)
      PARAMETER(IPPERD=3)
      PARAMETER(IPPERF=4)
      PARAMETER(IPPCHG=5)

      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)
      COMMON/FPCHAR/FPCHG(MAXHTS, 36)

      LOGICAL FIRST
      DATA FIRST/.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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

*-------------------------------------------------------------------
      IF(FIRST) THEN
         FIRST  = .FALSE.
         IQFPLC = NAMIND('FPLC')
         IQFPG1 = NAMIND('FPG1')
      ENDIF

      CALL VZERO(NDPW,NUMWPL)
*
      IFPLC = IW(IQFPLC)
      IFPG1= IW(IQFPG1)
      IF(IFPG1.EQ.0) THEN
        CALL ERRLOG(118,'S:FPUDAT: FPG1 bank not found')
        RETURN
      ENDIF
      IF(IFPLC.EQ.0) THEN
        RETURN
      ENDIF
      NFPLC = IW(IFPLC+2)
      IF(NFPLC.LE.0) THEN
        RETURN
      ENDIF

*     Extract Hits...
      NACHIT = 0
      DO 300  K= 1, NFPLC

       ICLNUM=        IBTAB(IFPLC,IPPCLN,K)
       IDEAD =        LBTAB(IFPG1,IPDEAD,ICLNUM+1)
       IF(IDEAD .NE. 1) THEN

         DRIFT =        RBTAB(IFPLC,IPPDRF,K)
         DRIFTP=        RBTAB(IFPLC,6,K)
         DRIFTM=        RBTAB(IFPLC,7,K)
         CHARGE=        RBTAB(IFPLC,IPPCHG,K)
         ERRDRF=        RBTAB(IFPLC,IPPERD,K)
         ISGNW =        IBTAB(IFPLC,IPPERF,K)
         IF(ISGNW .LT. IFRBAD) THEN
          NACHIT = NACHIT + 1
*         IOS wire planes numbered 1-36 through 3 Modules
          KWIR   =  IPIOSW(ICLNUM)
*         increment number of hits in this wire plane...
          NDPW(KWIR)              =   NDPW(KWIR) + 1
          IF(NDPW(KWIR) .GT. MAXHTS) THEN
           CALL ERRLOG(102,'W:FPTPDT: MAX HITS exceeded ')
           NDPW(KWIR)              =   NDPW(KWIR) - 1
          ELSE
*          W-coordinate of wire...
           DW ( NDPW(KWIR), KWIR)  =   SBTAB(IFPG1,IPPSTP,ICLNUM+1)
           DWG( NDPW(KWIR), KWIR)  =   SBTAB(IFPG1,5,ICLNUM+1)
*          Drift in W, Error, flag...
           DRIW( NDPW(KWIR), KWIR)  =  DRIFT
           DRIWP( NDPW(KWIR), KWIR) =  DRIFTP
           DRIWM( NDPW(KWIR), KWIR) =  DRIFTM
           ERPDR( NDPW(KWIR), KWIR) =  ERRDRF
           IERPF( NDPW(KWIR), KWIR) =  ISGNW
           FPCHG( NDPW(KWIR), KWIR) =  CHARGE
*          W-cell number of this hit...
           KWCL = IPWCL(ICLNUM)
*
           IF(KWCL.LE.15.AND.KWCL.GE.10)THEN
             IPHOLE(NDPW(KWIR),KWIR) = 1
           ELSE IF(KWCL.LE.21.AND.KWCL.GE.16)THEN
             IPHOLE(NDPW(KWIR),KWIR) = -1
           ELSE
             IPHOLE(NDPW(KWIR),KWIR) = 0
           ENDIF
*          relations between IOS labelling and FRRE bank...
           IPFRPE(NDPW(KWIR),KWIR)  =   K
           IF(K.LE.MAXDIG) THEN
            IPPIOS(K,1)             =   KWIR
            IPPIOS(K,2)             =   NDPW(KWIR)
           ENDIF

          ENDIF

         ENDIF

       ENDIF

 300  CONTINUE


      RETURN
      END
*CMZ :  8.07/00 22/11/96  15.17.06  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.13  by  Stephen Burke
*CMZU:  7.02/11 27/10/95  20.33.42  by  Stephen Burke
*CMZU:  7.00/04 04/05/95  18.33.38  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.00  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.33  by  Stephen Burke
*-- Author :  R. Henderson
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPDG4
**: FPDG4 40000 RH.  New steering parameters; use true resolution.
*------------------------------------------------------------------
**: FPDG4  30907 RH. Bug fix in cluster finding.
C------------------------------------------------------------------
**: FPDG4  30907 SM. Tune slope cuts. Add diagnostic histograms.
C-------------------------------------------------------------------
C
C---  This routine finds clusters from 4 digitizings at a single
C---  angular orientation that are aligned to within a tolerance
C
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
C---
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
C---
C---
      COMMON/FPCHAR/FPCHG(MAXHTS, 36)
      COMMON/FERROR/ERRDR(MAXHTS, 36), ERRRM(MAXHTS, 36),
     +              ERPDR(MAXHTS, 36), IERRF(MAXHTS, 36),
     +                                 IERPF(MAXHTS, 36)
        DIMENSION XBOUND(2),YBOUND(2)
        DIMENSION IN1(MSEGLM),IN4(MSEGLM)
        DIMENSION COVSLZ(2,2)
        DIMENSION DSMASK(MSEGLM),ICELL(MSEGLM)
        DIMENSION KSDEL(2)
        DIMENSION MXLST(MSEGLM),PMXLST(MSEGLM),PCLLST(MSEGLM)
C---
        REAL LINEX(2),LINEY(2),LOOP(50),W(4),PROBL(50)
        DOUBLE PRECISION Y(4),ONE
        LOGICAL LGKS,LSPLIT
C---
        CHARACTER SNTR*2
        CHARACTER SRESOL*5,PLWIRE*10
C---
        DATA ONE/1.0/
        DATA NTR/0/
        DATA TOLSF/4.0/
        DATA DRES2/1.5/
C-------------------------------------------------------------------
C                     DIGITS ANALYSIS
C
C   The following arrays are used in the remainder of this routine
C
C       DRSTO(drift,wire_in_orientation):
C       This has both drift and reflection per orientation
C
C       IDRSTO(drift,wire_in_orientation):
C       This is track id for both drift and reflection per orientation
C
C       NDRSTO(wire_in_orientation):
C       Number of drifts + reflections on wire (Naughty)
C
C       DRMASK(drift,wire_in_orientation):
C       1.0 If digit or reflection used
C       0.0 If digit or reflection unused
C
C       idigst(wire_in_orientation,found_segment_candidate):
C       index of digitising associated with a particular
C       candidate segment for a particular wire
C
C       NSGTAB(candidate_segment):
C       Number of candidate segments with which current segment
C       shares digitizings
C
C       SEGTAB(candidate_segment,associated_ambiguous_segments):
C       segment index ambiguous with current segment
C
C       dres2 two track resolution: for digits closer together than
C                                   dres2 the further away is placed
C                                   at first + dres/2 , error dres2/2
C
C       OUTPUT BANKS
C
C       NTC(tracks per plane ( 9 sets of 4 wire orientations)      )
C       TC (xyz of a vector in the plane ,plane, track intersection)
C       TOC(xyz of vector to the plane   ,plane, track intersection)
C       TCYUV  (4 digitizings forming plane       , plane, track)
C       tcyuvw (weight 4 digitizings forming plane, plane, track)
C
C
C-------------------------------------------------------------------
C
C---   This routine searches for clusters in 4 points
C---    for looking at drifts
C
C
C---  zero number of track clusters found per orientation (plane of 4 wires)
C
      DO 53 IOP = 1,9
      NTC(IOP) = 0
   53 CONTINUE
C
C---  Loop over 36 planar planes
C
         DO 100 IP = 1,36,4
      ZPD2 = (ZPLAN(IP+1) - ZPLAN(IP) )*0.1
      ZPD3 = (ZPLAN(IP+2) - ZPLAN(IP) )*0.1
C
C---  tolerance for finding digitizings
C
      TOLER = RESOL*TOLSF
C
C---  define maximum slope to be found for segment
C
*SJM  TEMPORARY MOD FOR COSMIC DATA
*     IF(IDATA.EQ.0) THEN
*       SLMAX = 40.0
*     ELSE
*       SLMAX  = 4.0
*     ENDIF
*SJM
      SLMAX  = 20.0
      SLYMIN = 0.000
      SLYMAX = 0.015
C---
C---
C---
C---
C---
C
C---   Zero drsto per 4 wire set
C
           CALL VZERO(DRSTO,4*MSEGLM)
           DO 52 IDS = 1,4
           NDRSTO(IDS) = 0
   52      CONTINUE
C
C---  Loop over four wires of orientation
C
      DO 110 IPO = IP , IP+3
C
C---  Loop over digits on each wire
C
      DO 111 IND = 1 , NDPW(IPO)
C---  drift
      DRIFP  = DRIW(IND,IPO)
      DRIFPP = DRIWP(IND,IPO)
      DRIFPM = DRIWM(IND,IPO)
      IF(DRIFP.GT.1000.0) GO TO 111
C---  Loop over reflections
      DO 112 I = 1 , 2
C---  Two track resolution code
      IF(NDRSTO(IPO-IP+1) .LT. MSEGLM) THEN
        IWR = IPO-IP+1
        NDRSTO(IWR) = NDRSTO(IWR) + 1
      ELSE
        CALL ERRLOG(201,'W:FPDG4 : NDRSTO > MSEGLM ')
        GOTO 110
      ENDIF
*      DRSTO(NDRSTO(IWR),IWR) = (DRIFP*(-1.)**(I-1) + DW(IND,IPO))*10.0
      IF (I.EQ.1) THEN
         DRSTO(NDRSTO(IWR),IWR) = (DWG(IND,IPO) + DRIFPP)*10.0
      ELSE
         DRSTO(NDRSTO(IWR),IWR) = (DWG(IND,IPO) - DRIFPM)*10.0
      ENDIF
      DRMASK(NDRSTO(IWR),IWR) = .FALSE.
*      RESSTO(NDRSTO(IWR),IWR) = RESOL
      RESSTO(NDRSTO(IWR),IWR) = 10.0*ERPDR(IND,IPO)
      IDCELL(NDRSTO(IWR),IWR) = IPHOLE(IND,IPO)
      IDRSTO(NDRSTO(IWR),IWR) = 0
      IDGIST(NDRSTO(IWR),IWR) = IND*((-1)**(I-1))
  112 CONTINUE
  111 CONTINUE
  110 CONTINUE
C---
C
C---  Section to find 2d line segments
C
C---  loop over first and last wire in orientation
C
C
C---  ifirst = 1 on first pass through
C
      IFIRST = 1
 1100 CONTINUE
      NSEG = 0
C
C---  sort drifts per plane
C
      IF( NDRSTO(1) .NE. 0)
     1    CALL SORTZV(DRSTO(1,1) , IN1 , NDRSTO(1) , 1 , 0 , 0)

      IF( NDRSTO(4) .NE. 0)
     1    CALL SORTZV(DRSTO(1,4) , IN4 , NDRSTO(4) , 1 , 0 , 0)


      DO 200 IO1 = 1 , NDRSTO(1)
      IF(DRMASK(IN1(IO1),1)) GO TO 200
C
C---  determine if dealing with a split cell
C
        IF(  IDCELL(IN1(IO1),1) .EQ.  1  .OR.
     1       IDCELL(IN1(IO1),1) .EQ. -1       )   THEN
           LSPLIT = .TRUE.
        ELSE
           LSPLIT = .FALSE.
        ENDIF
      DO 201 IO4 = 1 , NDRSTO(4)
      IF(DRMASK(IN4(IO4),4)) GO TO 201
C
C---  check if same split cells
C
      IF( LSPLIT .AND. IDCELL(IN1(IO1),1) .NE. IDCELL(IN4(IO4),4)
     1           .AND. IDCELL(IN4(IO4),4) .NE. 0                  )
     1                                                    GO TO 201
      LINEX(1) = 0.0
      LINEY(1) = DRSTO(IN1(IO1),1)
      LINEX(2) = ( ZPLAN(IP+3) - ZPLAN(IP) )/ 10.0
      LINEY(2) = DRSTO(IN4(IO4),4)
      GRAD = (LINEY(2) - LINEY(1)) / (LINEX(2) - LINEX(1))
C
C---  On first pass filter out large slopes
C
      IF ( GRAD .LT. -SLMAX ) GO TO 201
      IF ( GRAD .GT.  SLMAX ) GO TO 200
C
*SJM  TEMPORARY MOD FOR COSMIC DATA
C   Following not applied for cosmic data
*     IF(IDATA.NE.0) THEN
C
C---  filter out slopes not from vertex
C

C     CALL HFILL(400+IFIRST, LINEY(1), GRAD, 1.)
      IF(IFIRST.EQ.1) THEN
      IF ( (ABS(LINEY(1)) .GT. 100.0     .AND.
     1      GRAD*LINEY(1) .LT. 0.0                 ).OR.
     2      ABS(GRAD)     .GT. ABS(LINEY(1))*SLYMAX .OR.
     4     (ABS(LINEY(1)) .GT. 100.0     .AND.
     3      ABS(GRAD)     .LT. ABS(LINEY(1))*SLYMIN)     ) GO TO 201
      ENDIF
*     ENDIF
*SJM
C
C---  use tolerance to find digitizings to form segments
C
      PRED2 = LINEY(1) +  GRAD*ZPD2
      PRED3 = LINEY(1) +  GRAD*ZPD3
      DO 202 IO2 = 1 , NDRSTO(2)
      IF(DRMASK(IO2,2)) GO TO 202
      IF( LSPLIT .AND. IDCELL(IN1(IO1),1) .NE. IDCELL(IO2,2)
     1           .AND. IDCELL(IO2,2)      .NE. 0                   )
     1                                                    GO TO 202
           IF( RESSTO(IO2,2) .GT. 0.0 )THEN
            TOLER = RESSTO(IO2,2) * TOLSF
           ELSE
            TOLER = - RESSTO(IO2,2)
           ENDIF
      IF(  ABS(PRED2 - DRSTO(IO2,2)) .GT. TOLER)GO TO 202
      DO 203 IO3 = 1 , NDRSTO(3)
      IF(DRMASK(IO3,3)) GO TO 203
      IF( LSPLIT .AND. IDCELL(IN1(IO1),1) .NE. IDCELL(IO3,3)
     1           .AND. IDCELL(IO3,3)      .NE. 0                   )
     1                                                    GO TO 203
           IF( RESSTO(IO3,2) .GT. 0.0 )THEN
            TOLER = RESSTO(IO3,2) * TOLSF
           ELSE
            TOLER = - RESSTO(IO3,2)
           ENDIF
      IF( ABS(PRED3 - DRSTO(IO3,3)) .GT. TOLER)GO TO 203
C
C---  store the digitizing per segment found
C
      NSEG = NSEG + 1
        IF (NSEG .GT. MSEGLM) THEN
        CALL ERRLOG(202,'W:FPDG4 : NSEG   > MSEGLM ')
          NSEG = NSEG - 1
          GO TO 205
        ENDIF
C      CALL HFILL(14450,GRAD,LINEY(1),1.0)
      IDIGST(1,NSEG) = IN1(IO1)
      IDIGST(2,NSEG) = IO2
      IDIGST(3,NSEG) = IO3
      IDIGST(4,NSEG) = IN4(IO4)
  203 CONTINUE
  202 CONTINUE
  201 CONTINUE
  200 CONTINUE
  205 CONTINUE
C
C---  Now sort out which initial segments to keep
C
      CALL VZERO(NSGTAB,MSEGLM)
      DO 415 I = 1,NSEG
      PCLLST(I) = 100.0
  415 CONTINUE
C
C---  loop over all segments
C
      DO 300 ISEG = 1,NSEG
        IF(NSGTAB(ISEG) .EQ. MSEGLM)GO TO 300
C
C---  loop over remaining segments
C
        DO 302 KSEG = ISEG+1,NSEG
        IF(NSGTAB(KSEG) .EQ. MSEGLM)GO TO 302
C
C---  comparison loop over each wire in turn
C
          DO 301 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
             IF ( MOD(ID1,2) .EQ. 0 )THEN
              ID2 = ID1 - 1
             ELSE
              ID2 = ID1 + 1
             ENDIF
C
C---  has the same wire the same digit
C
                   IF( IDIGST(ID,KSEG) .NE. ID1  .AND.
     1                 IDIGST(ID,KSEG) .NE. ID2)   GO TO 301
                   NSGTAB(ISEG) = NSGTAB(ISEG) + 1
                   SEGTAB(ISEG,NSGTAB(ISEG)) = KSEG
                   NSGTAB(KSEG) = NSGTAB(KSEG) + 1
                   SEGTAB(KSEG,NSGTAB(KSEG)) = ISEG
                   GO TO 302
  301      CONTINUE
  302    CONTINUE
  300 CONTINUE
C
C--- remove nodes greater than or equal to 3
C
  400  CONTINUE
       IF( NSEG .LT. 1)GO TO 500
       CALL VFLOAT(NSGTAB,ASGTAB,NSEG)
       MXSEG = LVMAX(ASGTAB,NSEG)
       VMXSEG = ASGTAB(MXSEG)
C
C---
C
       IF ( VMXSEG .LE. 2.0 ) GO TO 500
C
C---   Find all nodes with this multipicity
C
       IMN = 0
       DO 405 ISEG = 1,NSEG
       IF( ASGTAB(ISEG) .NE. VMXSEG ) GO TO 405
         IMN = IMN + 1
         MXLST(IMN) = ISEG
  405  CONTINUE
C
C---   Skip next section if only one at this multipicity
C
       IF( IMN .EQ. 1 ) GO TO 406
C
C---   Fit all candidates and choose the worst
C
         DO 407 KMN = 1,IMN
         ISEG = MXLST(KMN)
C
C---  Check they have not already been fitted
C
              IF( PCLLST(ISEG) .EQ. 100.0 )THEN
              DO 410 IWIRE = 1,4
                Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
                W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
  410         CONTINUE
              CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
              PCLLST(ISEG) = PBCHI
              ENDIF
C
C---   Fit all CONNECTED to candidates
C
         DO 408 KSEG = 1,NSGTAB(ISEG)
              IF( PCLLST(KSEG) .EQ. 100.0 )THEN
              DO 411 IWIRE = 1,4
                Y(IWIRE) = DRSTO( IDIGST(IWIRE,KSEG) , IWIRE )
                W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,KSEG) , IWIRE)**2
  411         CONTINUE
              CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
              PCLLST(KSEG) = PBCHI
              ENDIF
  408    CONTINUE
C
C---  Probability of node LESS those connected
C
         PMXLST(KMN) = PCLLST(ISEG)
           DO 412 KSEG = 1,NSGTAB(ISEG)
           PMXLST(KMN) = PMXLST(KMN) - PCLLST(KSEG)
  412      CONTINUE
C---
  407 CONTINUE
C
C---  Now choose the cluster with worse chisqaure to remove
C
       MXSEG = MXLST( LVMIN(PMXLST,IMN) )
  406  CONTINUE
C
C--- greater than 2.0 so remove by setting nsgtab = -1.0
C
       NSGTAB(MXSEG) = -1.0
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 401 ISEG = 1, NSEG
       IF ( NSGTAB(ISEG) .EQ. -1) GO TO 401
         DO 402 ID = 1,NSGTAB(ISEG)
           IF( SEGTAB(ISEG,ID) .NE. MXSEG ) GO TO 402
             SEGTAB(ISEG,ID) = SEGTAB(ISEG,NSGTAB(ISEG))
             NSGTAB(ISEG) = NSGTAB(ISEG) - 1
             GO TO 401
  402 CONTINUE
  401 CONTINUE
C
C---  More nodes to remove
C
      GO TO 400
C
C---  Finished
C
  500 CONTINUE
C
C---  a point of restart having remove a 2 node
C
  720 CONTINUE
C
C---  Now try to find loops and angles and eliminate
C
      DO 700 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 700
        VALSEG = NSGTAB(ISEG)
C
C---  Find first candidate with 2 links
C
        IF ( VALSEG .LT. 2.0 ) GO TO 700
C
C---  Now trace its path
C
          ILOOP = 1
          LOOP(ILOOP) = ISEG
          LSTSEG = ISEG
          NXTSEG = SEGTAB(ISEG,1)
C
C---  Entry point for step along chain
C
  703 CONTINUE
C
C---  Test if path at end
C
          IF( NSGTAB(NXTSEG) .LT. 2) GO TO 701
C
C---  Skip link if pointing back
C
          NEWSEG = SEGTAB(NXTSEG,1)
            IF ( NEWSEG .EQ. LSTSEG )THEN
            NEWSEG = SEGTAB(NXTSEG,2)
            ENDIF
C
C---  Store next element of chain
C
          ILOOP = ILOOP + 1
          LOOP(ILOOP) = NXTSEG
          LSTSEG = NXTSEG
          NXTSEG = NEWSEG
C
C---  Test if loop complete
C
          IF (NXTSEG .EQ. ISEG)GO TO 702
C
C---  Points to next element in chain
C
          GO TO 703
C
C---  End of branch one
C
  701 CONTINUE
C
C---  This cannot be a loop so kill off node
C
C--&&MOD&&
      NSGTAB(LSTSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 801 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 801
         DO 802 ID = 1,NSGTAB(LSEG)
C--&&MOD&&
           IF( SEGTAB(LSEG,ID) .NE. LSTSEG ) GO TO 802
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  802 CONTINUE
  801 CONTINUE
C---&&MODS&&
C
C---  Now start again
C
      GO TO 720
C---&&END&&
C
C---  Loop complete
C
  702 CONTINUE
C
C---  Perform fits and eliminate adjacent nodes in loop
C
      DO 860 KLOOP = 1,ILOOP
      KSEG = LOOP(KLOOP)
       IF( PCLLST(KSEG) .EQ. 100.0 )THEN
        DO 861 IWIRE = 1,4
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,KSEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,KSEG) , IWIRE)**2
  861   CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
       PCLLST(KSEG) = PBCHI
       ENDIF
       PROBL(KLOOP) = PCLLST(KSEG)
  860 CONTINUE
C
C---  Keep highest probability node and delete those two either side
C
      LPSAVE = LVMAX(PROBL,ILOOP)
      VALPRB = PROBL(LPSAVE)
      KSSAVE = LOOP(LPSAVE)
      KSDEL(1) = SEGTAB(KSSAVE,1)
      KSDEL(2) = SEGTAB(KSSAVE,2)
C
C---  If loop is 4 then keep the most probable pair
C
      IF( ILOOP .EQ. 4)THEN
        PRB1 = PROBL(1) + PROBL(3)
        PRB2 = PROBL(2) + PROBL(4)
            IF( PRB1 .GT. PRB2 )THEN
              KSDEL(1) = LOOP(2)
              KSDEL(2) = LOOP(4)
            ELSE
              KSDEL(1) = LOOP(1)
              KSDEL(2) = LOOP(3)
            ENDIF
      ENDIF
C
C---  Remove links to maximum
C
      DO 870 KDEL = 1,2
      KSEG = KSDEL(KDEL)
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 871 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 871
         DO 872 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 872
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  872 CONTINUE
  871 CONTINUE
  870 CONTINUE
C---
  700 CONTINUE
C
C--- now remove any pairs by fitting
C
      DO 900 ISEG = 1,NSEG
      IF ( NSGTAB(ISEG) .NE. 1)GO TO 900
C
C---  Found a pair so find partner
C
      ISEGP = SEGTAB(ISEG,1)
C
C---  fit the first possiblity
C
       IF( PCLLST(ISEG) .EQ. 100.0 )THEN
        DO 901 IWIRE = 1,4
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
  901   CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ1,PBCHI1)
       PCLLST(ISEG) = PBCHI1
       ENDIF
C
C---  Fit the second possiblity
C
       IF( PCLLST(ISEGP) .EQ. 100.0 )THEN
        DO 902 IWIRE = 1,4
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEGP) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEGP) , IWIRE)**2
  902   CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ2,PBCHI2)
       PCLLST(ISEGP) = PBCHI2
       ENDIF
C
C---  Now remove the smaller probability segment
C
      IF ( PCLLST(ISEG) .GT. PCLLST(ISEGP) ) THEN
      KSEG = ISEGP
      ELSE
      KSEG = ISEG
      ENDIF
      NSGTAB(KSEG) = -1
C
C--- Now remove any reference to this node in the remaining nodes
C
       DO 911 LSEG = 1, NSEG
       IF ( NSGTAB(LSEG) .EQ. -1) GO TO 911
         DO 912 ID = 1,NSGTAB(LSEG)
           IF( SEGTAB(LSEG,ID) .NE. KSEG ) GO TO 912
            SEGTAB(LSEG,ID) = SEGTAB(LSEG,NSGTAB(LSEG))
            NSGTAB(LSEG) = NSGTAB(LSEG) - 1
  912 CONTINUE
  911 CONTINUE
  900 CONTINUE
C
C
C---  Now ANALYSE remaining segments
C
      DO 600 ISEG = 1,NSEG
      IF( NSGTAB(ISEG) .EQ. -1 ) GO TO 600
C
C---  fit remaining segments
C
        DO 670 IWIRE = 1,4
          Y(IWIRE) = DRSTO( IDIGST(IWIRE,ISEG) , IWIRE )
          W(IWIRE) = 1.0/RESSTO( IDIGST(IWIRE,ISEG) , IWIRE)**2
  670 CONTINUE
       CALL FPCFIT(IP,Y,W,SLOPE,ZERO,COVSLZ,CHISQ,PBCHI)
C
C---  Create routine output banks of track plane normals
C---  and points to planes at ZPLAN(lane) intersection
C
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
C---  find the absolute coordinate normal current wire orientation
C
      COWIRE = 0.0
C
C---  find which orientation plane (1-9) is current
C
      IPLANE = IP/4 + 1
C
C---  find fitted 'y' position at begining and end of 4 wire set
C---  fdrsta and fdrend respectively
C
      FDRSTA = COWIRE + ZERO
      FDREND = FDRSTA + SLOPE *
     1              (ZPLAN( (IPLANE)*4 ) - ZPLAN( (IPLANE-1)*4 + 1))
C
C---  Transform from orientation drift coordinates to global coordinates
C---  assuming that drift x coordinate is zero
C
      XREAL1=  -STP(IPLANE) * FDRSTA
      YREAL1=   CTP(IPLANE) * FDRSTA
      XREAL2=  -STP(IPLANE) * FDREND
      YREAL2=   CTP(IPLANE) * FDREND
C
C---  Fill track cluster banks and banks counter
C
C
C---  Increment cluster counter per plane
C
      IF( NTC(IPLANE) .GE. MAXCLU)THEN
        CALL ERRLOG(203,'W:FPDG4 : NTC(IPLANE) > MAXCLU')
      ELSE
      NTC(IPLANE) = NTC(IPLANE) + 1
      ENDIF
C---
      TC(1,IPLANE,NTC(IPLANE)) = XREAL2 - XREAL1
      TC(2,IPLANE,NTC(IPLANE)) = YREAL2 - YREAL1
      TC(3,IPLANE,NTC(IPLANE)) = ZPLAN((IPLANE)*4 )
     1                         - ZPLAN((IPLANE-1)*4 + 1)
C
C---  store toC
C
      TOC(1,IPLANE,NTC(IPLANE))=XREAL1
      TOC(2,IPLANE,NTC(IPLANE))=YREAL1
      TOC(3,IPLANE,NTC(IPLANE))=ZPLAN( (IPLANE-1)*4 + 1)
C
C---  store the digitisings associated with plane/track for final
C     fit
C
      DO 695 IWW = 1,4
          IDGISM(IWW,IPLANE,NTC(IPLANE)) =
     1               IDGIST( IDIGST(IWW,ISEG) , IWW )
      TCYUV(IWW,IPLANE,NTC(IPLANE))    = COWIRE + Y(IWW)
      TCYUVW(IWW,IPLANE,NTC(IPLANE))   = W(IWW)
  695 CONTINUE
C---
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  600 continue
C
C---  Set drmask to 1.0 for used digits
C
      DO 750 ISEG = 1,NSEG
      IF(NSGTAB(ISEG) .EQ. -1) GO TO 750
        DO 751 ID = 1,4
           ID1 = IDIGST(ID,ISEG)
           IF ( MOD(ID1,2) .EQ. 0 )THEN
            ID2 = ID1 - 1
           ELSE
            ID2 = ID1 + 1
           ENDIF
          DRMASK(ID1,ID) = .TRUE.
          DRMASK(ID2,ID) = .TRUE.
  751 CONTINUE
  750 CONTINUE
C
C---  Now plot and count them
C
      IDUNUS = 0
      DO 760 IWIRE = 1,4
      DO 761 ID = 1,NDRSTO(IWIRE)
      IF( DRMASK(ID,IWIRE) ) GO TO 761
      DRIFT = DRSTO(ID,IWIRE)
      IDUNUS = IDUNUS + 1
  761 CONTINUE
  760 CONTINUE
C
C---  If first pass now loop back with  increased tolerance and maxang
C
      IF (IDUNUS .NE. 0 .AND. IFIRST .EQ. 1)THEN
      IFIRST = 0
      TOLER = RESOL*8.0
*SJM  TEMPORARY MOD FOR COSMIC DATA
*     IF(IDATA.EQ.0) THEN
        SLMAX = 60.0
*     ELSE
*       SLMAX = 6.0
*     ENDIF
*SJM
      SLMAX  = 60.0
      SLYMIN = 0.0
      SLYMAX = 1.0
      GO TO 1100
      ENDIF
C
C---  END FPDG4
C
C
C---  Now deal with segments with only 3 digitizings
C
       IF(IDUNUS .NE. 0)THEN
       CALL FPDG31(IP)
       CALL FPDG32(IP)
       CALL FPDG33(IP)
       ENDIF
C               if(lgks)CALL grqst(2,1,istat,len_plwire,plwire)
  100    CONTINUE
C
C---   examine idyuv cluster ids and see how many correct
C
      END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.02/11 27/10/95  20.33.42  by  Stephen Burke
*CMZU:  7.00/04 04/05/95  18.33.39  by  Stephen Burke
*CMZU:  5.03/00 01/11/94  09.16.55  by  Stephen Burke
*-- Author :    R. Henderson   24/10/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFSSG(NSMLS)
C-----------------------------------------------------------------------
C
C---  Routine finds 'SECONDARY' segments from two Clusters/Planes
C---  + any number of previously unused digits.
C---  Firstly arrays are calculated which
C---  flag clusters which have not already been used in segments
C---  formed from three clusters.
C---         (IUCLU(IPLANE,MAXCLU) = 0 if unused)
C---  Then for unused digits that have not yet been placed in a cluster.
C---         (IUD(MAXHTS,NUMWPL) = 0 if not used)
C---
C---  A search is made for all candidate line segments formed from
C---  two unused clusters to find any that have digits (the information
C---  from which can be expressed as a line) in the orientation not
C---  yet contributing  with a Distance of Closest
C---  Approach of less than DDTOL. The closest digit is included in the
C---  segment together with any which are within DIGTOL of the closest.
C---
C---  A new cluster is formed using the newly added digit(s).( NB.
C---  If the cluster is formed of only one digit the cluster no longer
C---  represents a plane.) The number of these created is stored in
C---  COMMON/FPSTSG/ as  NSTC(9). Otherwise the normal Cluster counter
C---  is incremented to include all clusters new and old.
C---
C---  The new segments are fitted using FPFSTS. A count of the new
C---  secondary segments is kept in COMMON/FPSTSG/ as NFSSEG(9) but
C---  otherwise the normal counter NFSEG(9) is incremented to include
C---  these new segments.
C---
C---  A new disconnected set is found for all segments by FPSSGF.
C---
C---  COMMON/FPSTSG/NSTC(9)   --- Number of secondary clusters formed.
C---                NFSSEG(3) --- Number of secondary Segments formed.
C---                NFTSEG(3) --- Number of Tertiary segments formed.
C---
C---  The segments are ordered so all primary segments preceed
C---  secondary and finary secondary preceed Tertiary)
C---
C-----------------------------------------------------------------------
C
C
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEEP,FPSTSG.
      COMMON/FPSTSG/ NSTC(9),NFSSEG(3),NFTSEG(3)
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C
      DIMENSION IUD(MAXHTS,NUMWPL)
      DIMENSION IUCLU(9,MAXCLU)
      DIMENSION IPL(2),ICL(2)
      DIMENSION TODIG(3),VDIG(3),TOCLS(3),VCLS(3)
      DIMENSION DMINW(4),IDIGM(4),IWLIS(4)
C
      PARAMETER (DDCUT= 6.0)
      PARAMETER (DIGTOL= 0.3)
C
      INTEGER NSMLS(3)
C
      DOUBLE PRECISION PARSGN(4),ERRSGN(4,4)
C
C---  Initialize arrays
C
      CALL VZERO(IUD,MAXHTS*NUMWPL)
C
C---  Establish a list of clusters and digits available
C---  to form secondary segments
C
C
C---  Firstly Digits
C
C---  Loop over supermodules
C
      DO 10 ISM = 1,3
C
C---  Loop over candidate line segments
C
      DO 20 LSC = 1,NSMLS(ISM)
C
C---  Loop on clusters that form CANDIDATE line segments
C
      DO 30 IC = 1,2
C
C---  Find the planes.clusters numbers that make them up
C
      IDCLS = SMLS(4,IC,LSC,ISM)
      IP    = MOD(IDCLS,10)
      ICLU  = IDCLS/10
C
C---  Loop on four wires in cluster
C
      DO 40 IW = 1, 4
      IWW = (IP-1)*4 + IW
C
C---  Set flag in IUD (Used Digits) to +/-1 from 0
C     (SIGN = DRIFT DIRECTION)
C
      IND = ABS(IDGISM(IW,IP,ICLU))
      IF(IND .EQ. 0)GO TO 40
      ISIGN = IDGISM(IW,IP,ICLU)/IABS(IDGISM(IW,IP,ICLU))
C---
      IUD(IND,IWW) = ISIGN
C
 40   CONTINUE
C
 30   CONTINUE
C
 20   CONTINUE
C
 10   CONTINUE
C
C---  Create list of used/unused clusters
C
      CALL VZERO(IUCLU,9*MAXCLU)
C
C---  Loop over supermodules
C
      DO 100 ISM=1,3
C
C---  Loop over segments
      DO 110 ISEG = 1,NFSEG(ISM)
C
C---  Remove those outside disconnected set
C
      IF(MASKSG(ISEG,ISM) .EQ. -1) GO TO 110
C
C---
C
        IPLAN1 = MOD(ISEGIN(1,ISEG,ISM),10)
        IPLAN2 = MOD(ISEGIN(2,ISEG,ISM),10)
        IPLAN3 = MOD(ISEGIN(3,ISEG,ISM),10)
        ITRK1  = ISEGIN(1,ISEG,ISM)/10
        ITRK2  = ISEGIN(2,ISEG,ISM)/10
        ITRK3  = ISEGIN(3,ISEG,ISM)/10
C
C---    Set IUCLU to 1 if used
C
        IUCLU(IPLAN1,ITRK1) = 1
        IUCLU(IPLAN2,ITRK2) = 1
        IUCLU(IPLAN3,ITRK3) = 1
C---
 110  CONTINUE
 100  CONTINUE
C
C---  Having established the unused CLS and Digits find all
C---  distances of closest approach
C
      CALL VZERO(NFSSEG,3)
      CALL VZERO(NFTSEG,3)
C
C---  Loop over supermodule
C
      DO 200 ISM = 1,3
C
C---  Loop on candidate line segments
C
      NTRAP = 0
      DO 210 ICLS = 1,NSMLS(ISM)
*
* SB mod to help with large events
*
         IF (NFSEG(ISM) .GE. MAXSEG) THEN
            CALL ERRLOG(216,'W:FPFSSG: .GT. MAXSEG segments found')
            GOTO 200
         ENDIF
C
C---  Calculate the angle wrt to axis of candidate line segment
C
      DXCLS = SMLS(1,2,ICLS,ISM) - SMLS(1,1,ICLS,ISM)
      DYCLS = SMLS(2,2,ICLS,ISM) - SMLS(2,1,ICLS,ISM)
      DZCLS = SMLS(3,2,ICLS,ISM) - SMLS(3,1,ICLS,ISM)
      DTCLS = DXCLS**2 + DYCLS**2
         IF(DZCLS .GT. 0.0)THEN
         PHICLS = ATAN(DTCLS/(DZCLS**2))
         ENDIF
C
C---
C
      IF(PHICLS .GT. 0.5)GO TO 210
C
C---  Check that neither plane in candidate line segment used
C
      DO 220 ICLU = 1,2
      ICCLU     = SMLS(4,ICLU,ICLS,ISM)
      IPL(ICLU) = MOD(ICCLU,10)
      ICL(ICLU) = ICCLU/10
      IF(IUCLU(IPL(ICLU),ICL(ICLU)) .EQ. 1)GO TO 210
 220  CONTINUE
C
C---  Calculate which wires are to be searched for digits
C---  They must be the wires which have not contributed to CLS
C
      IF(    IPL(1) .EQ. 1 .AND. IPL(2) .EQ. 2)THEN
      IPMISS = 3
      ELSEIF(IPL(1) .EQ. 1 .AND. IPL(2) .EQ. 3)THEN
      IPMISS = 2
      ELSEIF(IPL(1) .EQ. 2 .AND. IPL(2) .EQ. 3)THEN
      IPMISS = 1
      ELSEIF(IPL(1) .EQ. 4 .AND. IPL(2) .EQ. 5)THEN
      IPMISS = 6
      ELSEIF(IPL(1) .EQ. 4 .AND. IPL(2) .EQ. 6)THEN
      IPMISS = 5
      ELSEIF(IPL(1) .EQ. 5 .AND. IPL(2) .EQ. 6)THEN
      IPMISS = 4
      ELSEIF(IPL(1) .EQ. 7 .AND. IPL(2) .EQ. 8)THEN
      IPMISS = 9
      ELSEIF(IPL(1) .EQ. 7 .AND. IPL(2) .EQ. 9)THEN
      IPMISS = 8
      ELSEIF(IPL(1) .EQ. 8 .AND. IPL(2) .EQ. 9)THEN
      IPMISS = 7
      ENDIF
*
* SB mod to help with large events
*
      IF(NTC(IPMISS) .GE. MAXCLU)THEN
         NTRAP = NTRAP + 1
         IF (NTRAP.EQ.1)
     &      CALL ERRLOG(214,'W:FPFSSG: Cluster limit reached')
         GOTO 210
      ENDIF
C
      IWSTAR = (IPMISS-1)*4  + 1
C
C---  Calculate w of cluster in missing orientation
C
      XCLSS = SMLS(1,1,ICLS,ISM)
      XCLSE = SMLS(1,2,ICLS,ISM)
      YCLSS = SMLS(2,1,ICLS,ISM)
      YCLSE = SMLS(2,2,ICLS,ISM)
      ZCLSS = SMLS(3,1,ICLS,ISM)
      ZCLSE = SMLS(3,2,ICLS,ISM)
C---
      XOR = XCLSS + ( (XCLSE-XCLSS) / (ZCLSE-ZCLSS) )
     1            * ( ZPLAN( (IPMISS-1)*4 + 1 ) - ZCLSS )
C---
      YOR = YCLSS + ( (YCLSE-YCLSS) / (ZCLSE-ZCLSS) )
     1            * ( ZPLAN( (IPMISS-1)*4 + 1 ) - ZCLSS )
C---
      WOR = YOR * CTP(IPMISS) - XOR * STP(IPMISS)
C
C---  Now find unused digitizations on these wires
C
      CALL VZERO(DMINW,4)
      CALL VZERO(IDIGM,4)
C---
      ICDIG = 0
C---
      DO 300 IWW = IWSTAR , IWSTAR + 3
C
C---  Loop over all digits on wires
C
      DMIN = 10000.0
C
      DO 310 IDIG = 1,NDPW(IWW)
C
C---  Remove any digits already used
C
      IF (IUD(IDIG,IWW) .NE. 0) GO TO 310
C
C---  Loop on sign of drifts
C
      DO 320 ISD = 1,2
C---
*      DRIFT = (DRIW(IDIG,IWW)*(-1.0)**(ISD-1) + DW(IDIG,IWW)) * 10.0
      IF (ISD.EQ.1) THEN
         DRIFT = (DWG(IDIG,IWW) + DRIWP(IDIG,IWW)) * 10.0
      ELSE
         DRIFT = (DWG(IDIG,IWW) - DRIWM(IDIG,IWW)) * 10.0
      ENDIF
C---
      IF( (WOR - DRIFT) .GT. 2.0*DDCUT) GO TO 320
C
C---  Now make vectors TO and PARALLEL to digit information
C
      XDIG =  -DRIFT * STP(IPMISS)
      YDIG =   DRIFT * CTP(IPMISS)
C---
      TODIG(1) = XDIG
      TODIG(2) = YDIG
      TODIG(3) = ZPLAN(IWW)
C---
      VDIG(1) = PLANE(1,IPMISS)
      VDIG(2) = PLANE(2,IPMISS)
      VDIG(3) = PLANE(3,IPMISS)
C
C---  Make vector TO and PARALLEL to CLS
C
      TOCLS(1) = SMLS(1,1,ICLS,ISM)
      TOCLS(2) = SMLS(2,1,ICLS,ISM)
      TOCLS(3) = SMLS(3,1,ICLS,ISM)
C---
      VCLS(1) = SMLS(1,1,ICLS,ISM) - SMLS(1,2,ICLS,ISM)
      VCLS(2) = SMLS(2,1,ICLS,ISM) - SMLS(2,2,ICLS,ISM)
      VCLS(3) = SMLS(3,1,ICLS,ISM) - SMLS(3,2,ICLS,ISM)
C
C---  Now calculate distance of closest approach of digit to CLS
C
C      CALL FPDCA(TODIG,VDIG,TOCLS,VCLS,DIST)
C New, hopefully faster version
      CALL FPNDCA(TODIG,VDIG,TOCLS,VCLS,DIST)
C---
       IF(ABS(DIST) .LT. ABS(DMIN))THEN
       DMIN = DIST
       IDGMIN = IDIG
       ISGNMN = ISD
       ENDIF
C---
 320  CONTINUE
 310  CONTINUE
C---
C
C---  Store distance to closest digit on wire plane
C
      IF(ABS(DMIN) .LT. DDCUT)THEN
      ICDIG = ICDIG + 1
      DMINW(IWW-IWSTAR+1) = DMIN
      IDIGM(IWW-IWSTAR+1) = IDGMIN*(-1.0)**(ISGNMN-1)
      ELSE
      DMINW(IWW-IWSTAR+1) = -1000000.0
      ENDIF
 300  CONTINUE
C
C---  Find closest
C
      IDCDIG = 0
      IFDIG = 0
      CALL VZERO(IWLIS,4)
      IF(ICDIG.GT.0)THEN
      DCDIG = 1000000.0
         DO 500 IWIR = 1,4
         IF(DMINW(IWIR) .LT. -1000.0)GO TO 500
         IF( ABS(DMINW(IWIR)) .LT. ABS(DCDIG) )THEN
           DCDIG  = DMINW(IWIR)
           IDCDIG = IWIR
         ENDIF
 500     CONTINUE
C---
C
C---  Find any within a tolerance of closest
C
         IF(ICDIG.GT.1)THEN
         IWLIS(1) = IDCDIG
         IFDIG = 1
         DO 501 IWIR = 1,4
         IF(IWIR .EQ. IDCDIG)GO TO 501
         IF( ABS(DCDIG-DMINW(IWIR)) .GT. DIGTOL)GO TO 501
         IFDIG = IFDIG + 1
         IWLIS(IFDIG) = IWIR
 501     CONTINUE
         ENDIF
C
C---  Create secondary clusters and segments
C
         IF(IFDIG .GT. 0)THEN
C
C---  Create new clusters
C
            NTC(IPMISS)  = NTC(IPMISS)  + 1
            NSTC(IPMISS) = NSTC(IPMISS) + 1
                 IF(NTC(IPMISS) .GT. MAXCLU)THEN
                   NTC(IPMISS)  = NTC(IPMISS)  - 1
                   NSTC(IPMISS) = NSTC(IPMISS) - 1
                   CALL ERRLOG(214,'W:FPFSSG: Cluster limit reached')
                 ELSE
                   CALL VZERO( TCYUV(1,IPMISS,NTC(IPMISS)),4)
                   CALL VZERO(TCYUVW(1,IPMISS,NTC(IPMISS)),4)
                   CALL VZERO(IDGISM(1,IPMISS,NTC(IPMISS)),4)
                     DO 700 IDG = 1,IFDIG
                       IWW = IWLIS(IDG)
                       IWIR = IWW + (IPMISS-1)*4
                       IDIG = IABS(IDIGM(IWW))
                       ISGN = IDIGM(IWW)/IDIG
*                       TCYUV(IWW,IPMISS,NTC(IPMISS)) =
*     1                 (DRIW(IDIG,IWIR)*(-1.0)**(ISGN-1) +
*     2                 DW(IDIG,IWIR)) * 10.0
                       IF (MOD(ISGN,2).EQ.1) THEN
                          TCYUV(IWW,IPMISS,NTC(IPMISS)) =
     1                    (DWG(IDIG,IWIR) + DRIWP(IDIG,IWIR)) * 10.0
                       ELSE
                          TCYUV(IWW,IPMISS,NTC(IPMISS)) =
     1                    (DWG(IDIG,IWIR) - DRIWM(IDIG,IWIR)) * 10.0
                       ENDIF
                       TCYUVW(IWW,IPMISS,NTC(IPMISS)) = 30.0
                       IDGISM(IWW,IPMISS,NTC(IPMISS)) = IDIGM(IWW)
 700                 CONTINUE
                 ENDIF
C
C---  Fit newly created cluster with candidate line segment
C---  to form new (secondary segment)
C
            ID1 = SMLS(4,1,ICLS,ISM)
            ID2 = SMLS(4,2,ICLS,ISM)
            ID3 = NTC(IPMISS)*10 + IPMISS
            CALL FPFSTS(ID1,ID2,ID3,ISM,PCHI,CHISQ,NDF,PARSGN,ERRSGN)
         ENDIF
      ENDIF
 210  CONTINUE
 200  CONTINUE
C
C---  Reform disconnected segment sets
C
      CALL FPSSGF(.TRUE.)
      END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.00/04 04/05/95  16.26.57  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  14.37.53  by  R. Henderson
*-- Author :    R. Henderson   24/10/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFTSG(NSMLS)
C-----------------------------------------------------------------------
C
C---  Routine finds 'TERTIARY' segments from two Clusters/Planes
C---  + nothing.
C---  Firstly arrays are calculated which
C---  flag clusters which have not already been used in segments.
C---         (IUCLU(IPLANE,MAXCLU) = 0 if unused)
C---  Then for unused digits that have not yet been placed in a cluster.
C---         (IUD(MAXHTS,NUMWPL) = 0 if not used)
C---
C---  The new segments are fitted using FPFSTS. A count of the new
C---  tertiary segments is kept in COMMON/FPSTSG/ as NFTSEG(9) but
C---  otherwise the normal counter NFSEG(9) is incremented to include
C---  these new segments.
C---
C---  A new disconnected set is found for all segments by FPSSGF.
C---
C---  COMMON/FPSTSG/NSTC(9)   --- Number of secondary clusters formed.
C---                NFSSEG(3) --- Number of secondary Segments formed.
C---                NFTSEG(3) --- Number of Tertiary segments formed.
C---
C---  The segments are ordered so all primary segments preceed
C---  secondary and finary secondary preceed Tertiary)
C---
C-----------------------------------------------------------------------
C
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEEP,FPSTSG.
      COMMON/FPSTSG/ NSTC(9),NFSSEG(3),NFTSEG(3)
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C
      DIMENSION IUD(MAXHTS,NUMWPL)
      DIMENSION IUCLU(9,MAXCLU)
      DIMENSION IPL(2),ICL(2)
      DIMENSION TODIG(3),VDIG(3),TOCLS(3),VCLS(3)
      DIMENSION DMINW(4),IDIGM(4),IWLIS(4)
C
      INTEGER NSMLS(3)
C
      DOUBLE PRECISION PARSGN(4),ERRSGN(4,4)
C
C---  Initialize arrays
C
      CALL VZERO(IUD,MAXHTS*NUMWPL)
C
C---  Establish a list of clusters and digits available
C---  to form secondary segments
C
C
C---  Firstly Digits
C
C---  Loop over supermodules
C
      DO 10 ISM = 1,3
C
C---  Loop over candidate line segments
C
      DO 20 LSC = 1,NSMLS(ISM)
C
C---  Loop on clusters that form CANDIDATE line segments
C
      DO 30 IC = 1,2
C
C---  Find the planes.clusters numbers that make them up
C
      IDCLS = SMLS(4,IC,LSC,ISM)
      IP    = MOD(IDCLS,10)
      ICLU  = IDCLS/10
C
C---  Loop on four wires in cluster
C
      DO 40 IW = 1, 4
      IWW = (IP-1)*4 + IW
C
C---  Set flag in IUD (Used Digits) to +/-1 from 0
C     (SIGN = DRIFT DIRECTION)
C
      IND = ABS(IDGISM(IW,IP,ICLU))
      IF(IND .EQ. 0)GO TO 40
      ISIGN = IDGISM(IW,IP,ICLU)/IABS(IDGISM(IW,IP,ICLU))
C---
      IUD(IND,IWW) = ISIGN
C
 40   CONTINUE
C
 30   CONTINUE
C
 20   CONTINUE
C
 10   CONTINUE
C
C---  Create list of used/unused clusters
C
      CALL VZERO(IUCLU,9*MAXCLU)
C
C---  Loop over supermodules
C
      DO 100 ISM=1,3
C
C---  Loop over segments
      DO 110 ISEG = 1,NFSEG(ISM)
C
C---  Remove those outside disconnected set
C
      IF(MASKSG(ISEG,ISM) .EQ. -1) GO TO 110
C
C---
C
        IPLAN1 = MOD(ISEGIN(1,ISEG,ISM),10)
        IPLAN2 = MOD(ISEGIN(2,ISEG,ISM),10)
        IPLAN3 = MOD(ISEGIN(3,ISEG,ISM),10)
        ITRK1  = ISEGIN(1,ISEG,ISM)/10
        ITRK2  = ISEGIN(2,ISEG,ISM)/10
        ITRK3  = ISEGIN(3,ISEG,ISM)/10
C
C---    Set IUCLU to 1 if used
C
        IUCLU(IPLAN1,ITRK1) = 1
        IUCLU(IPLAN2,ITRK2) = 1
        IUCLU(IPLAN3,ITRK3) = 1
C---
 110  CONTINUE
 100  CONTINUE
C
C---  Having established the unused CLS and Digits find all
C---  distances of closest approach
C
      CALL VZERO(NFTSEG,3)
C
C---  Loop over supermodule
C
      DO 200 ISM = 1,3
C
C---  Loop on candidate line segments
C
      DO 210 ICLS = 1,NSMLS(ISM)
*
* SB mod to help with large events
*
         IF (NFSEG(ISM) .GE. MAXSEG) THEN
            CALL ERRLOG(216,'W:FPFTSG: .GT. MAXSEG segments found')
            GOTO 200
         ENDIF
C
C---  Calculate the angle wrt to axis of candidate line segment
C
      DXCLS = SMLS(1,2,ICLS,ISM) - SMLS(1,1,ICLS,ISM)
      DYCLS = SMLS(2,2,ICLS,ISM) - SMLS(2,1,ICLS,ISM)
      DZCLS = SMLS(3,2,ICLS,ISM) - SMLS(3,1,ICLS,ISM)
      DTCLS = SQRT( DXCLS**2 + DYCLS**2 )
         IF(DZCLS .GT. 0.0)THEN
         PHICLS = ATAN(DTCLS/DZCLS)
         ENDIF
C
C---
C
      IF(PHICLS .GT. 0.5)GO TO 210
C
C---  Check that neither plane in candidate line segment used
C
      DO 220 ICLU = 1,2
      ICCLU     = SMLS(4,ICLU,ICLS,ISM)
      IPL(ICLU) = MOD(ICCLU,10)
      ICL(ICLU) = ICCLU/10
      IF(IUCLU(IPL(ICLU),ICL(ICLU)) .EQ. 1)GO TO 210
 220  CONTINUE
C
C---  Calculate which wires are to be searched for digits
C---  They must be the wires which have not contributed to CLS
C
      IF(    IPL(1) .EQ. 1 .AND. IPL(2) .EQ. 2)THEN
      IPMISS = 3
      ELSEIF(IPL(1) .EQ. 1 .AND. IPL(2) .EQ. 3)THEN
      IPMISS = 2
      ELSEIF(IPL(1) .EQ. 2 .AND. IPL(2) .EQ. 3)THEN
      IPMISS = 1
      ELSEIF(IPL(1) .EQ. 4 .AND. IPL(2) .EQ. 5)THEN
      IPMISS = 6
      ELSEIF(IPL(1) .EQ. 4 .AND. IPL(2) .EQ. 6)THEN
      IPMISS = 5
      ELSEIF(IPL(1) .EQ. 5 .AND. IPL(2) .EQ. 6)THEN
      IPMISS = 4
      ELSEIF(IPL(1) .EQ. 7 .AND. IPL(2) .EQ. 8)THEN
      IPMISS = 9
      ELSEIF(IPL(1) .EQ. 7 .AND. IPL(2) .EQ. 9)THEN
      IPMISS = 8
      ELSEIF(IPL(1) .EQ. 8 .AND. IPL(2) .EQ. 9)THEN
      IPMISS = 7
      ENDIF
C
C
C---  Fit newly created cluster with candidate line segment
C---  to form new (secondary segment)
C
            ID1 = SMLS(4,1,ICLS,ISM)
            ID2 = SMLS(4,2,ICLS,ISM)
            ID3 = 0 + IPMISS
            CALL FPFSTS(ID1,ID2,ID3,ISM,PCHI,CHISQ,NDF,PARSGN,ERRSGN)
 210  CONTINUE
 200  CONTINUE
C
C---  Reform disconnected segment sets
C
      CALL FPSSGF(.FALSE.)
      END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.00/04 26/04/95  15.32.52  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  13.52.44  by  R. Henderson
*-- Author :    R. Henderson   24/10/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPDCA(TODIG,VDIG,TOCLS,VCLS,DIST)
C----
C------------------------------------------------------------
C-----  FIND dca for the vectors a = todig + x*vdig
C-----           and the vectors b = tocls + x*vcls
C------------------------------------------------------------
C----
      DIMENSION UVWSOL(3)
      DOUBLE PRECISION ATRIX(3,3),BTRIX(3),WORK(100)
      DIMENSION TODIG(3),VDIG(3),TOCLS(3),VCLS(3),TCP(3)
C----
          CALL VUNIT(VCLS,VCLS,3)
C----
          TCP(1) = VCLS(2)*VDIG(3)
     1               - VCLS(3)*VDIG(2)
          TCP(2) = VCLS(3)*VDIG(1)
     1               - VCLS(1)*VDIG(3)
          TCP(3) = VCLS(1)*VDIG(2)
     1               - VCLS(2)*VDIG(1)
C---
          CALL VUNIT(TCP,TCP,3)
C---
          ATRIX(1,1) = VCLS(1)
          ATRIX(1,2) = VCLS(2)
          ATRIX(1,3) = VCLS(3)
          ATRIX(2,1) = -VDIG(1)
          ATRIX(2,2) = -VDIG(2)
          ATRIX(2,3) = -VDIG(3)
          ATRIX(3,1) = TCP(1)
          ATRIX(3,2) = TCP(2)
          ATRIX(3,3) = TCP(3)
C---
          CALL DINV(3,ATRIX,3,WORK,IFAIL)
C---
          BTRIX(1) = TOCLS(1)-TODIG(1)
          BTRIX(2) = TOCLS(2)-TODIG(2)
          BTRIX(3) = TOCLS(3)-TODIG(3)
C---
           CALL VZERO(UVWSOL,3)
           DO 995 IC = 3,3
           DO 996 IR = 1,3
           UVWSOL(IC) = UVWSOL(IC) + ATRIX(IR,IC)*BTRIX(IR)
  996      CONTINUE
  995      CONTINUE
C
C---       Assign DIST to UVWSOL(3)
C
           DIST = UVWSOL(3)
C
           END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZ :  7.04/00 15/01/96  16.09.58  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  15.17.56  by  Stephen Burke
*-- Author :    R. Henderson   24/10/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFSTS(ID1,ID2,ID3,ISM,PCHI,CHISQ,NDF,SOL,EXYSXY)
C------------------------------------------------------------------
C
C---  ESPECIALLY MODIFIED TO FIT SECONDARY AND TERTIARY SEGMENTS
C
C------------------------------------------------------------------
C
C---  THIS ROUTINE PERFORMS A LEAST SQUARES FIT TO A STRAIGHT
C---  LINE FOR POINTS AT POSITIONS Z(I) MEASURED IN THE Y U V COORDINATE
C---  FRAMES WHERE U COORDINATES ARE AT ANGLE THETA(2) AND V ARE AT
C---  ANGLE THETA(3) TO Y. THETA IS ASSUMED TO BE MEASURED IN THE
C---  CLOCKWISE DIRECTION.
C
C---  INPUT  :
C
C---  Y - POINTS FOR FITTING;  4 FROM Y COORDS, 4 FROM U, 4 FROM V.
C---  RESOL - RESOLUTION ON EACH DIGITIZING (IN PRINCIPLE PER WIRE)
C---  ZPLAN(36) - Z COORDINATE OF EACH PLANAR WIRE SET
C
C---  OUTPUT  :
C
C---  PCHI PROBABILITY FROM CHISQUARE
C---  SOL(4) X0 Y0 DX/DZ DY/DZ
C---  EXYSXY(4,4) COVARIANCE MATRIX TO SOL
C
C------------------------------------------------------------------
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
*KEEP,FPLGEO.
C---
      COMMON /FPLGEO/   ZPLAN(36)   , TP(9)   , YP(26)    , PLANE(3,9),
     1                 RMAX    , RMIN    , YSTART    , YSPACE    ,
     2                 X0      , Y0      , PZSTRU (8), STAGER   ,
     3                 RESOL   , ACUT    , CTP(9)    , STP(9)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEND.
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*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,FPSTSG.
      COMMON/FPSTSG/ NSTC(9),NFSSEG(3),NFTSEG(3)
C---
*KEND.
C---
      DIMENSION W(12),Z(12)
      DIMENSION WSUM(3),WZSUM(3),WZ2SUM(3)
      DIMENSION WYSUM(3),WYZSUM(3)
      DIMENSION B(4)
      DIMENSION WORK(16)
      DIMENSION WTEST(4,4)
      DIMENSION MTRIXA(4,4)
      DIMENSION Y(12),YC(12)
      DIMENSION SOL(4),EXYSXY(4,4)
      DIMENSION XSOL(2),YSOL(2),ZSOL(2)
      DIMENSION COST(3),COS2T(3),TANT(3),TAN2T(3),THETA(3)
      DIMENSION XT(12),YT(12)
      DIMENSION COUNTS(500),CHISQA(12)
C---
      REAL MTRIXA
      DOUBLE PRECISION EXYSXY,SOL,B
      REAL CHISQ
C---
      SAVE
C      DATA THETA/ 0.0 , - 1.0471976 , 1.0471976/
      DATA IFIRST/1/
C---
C
C---   INITIALIZATION PER SUPERMODULE
C
      IF( IFIRST .EQ. 1  .OR.  ISM .NE. ISMLAS )THEN
      IFIRST = 0
      ISMLAS = ISM
C
C---  ROTATE THETA SO THETA(1) = 0.0
C
      TZERO = - TP( 1 + (ISM-1)*3 )
      DO 43 I = 1,3
      THETA(I) = - TP( I + (ISM-1)*3 ) - TZERO
   43 CONTINUE
      CTZERO = COS(TZERO)
      STZERO = SIN(TZERO)
C
C---  SETUP GEOMETRICAL CONSTANTS
C
      DO 200 I = 1,3
      COST(I) = COS( THETA(I) )
      COS2T(I) = COST(I)**2
      TANT(I) = TAN( THETA(I) )
      TAN2T(I) = TANT(I)**2
  200 CONTINUE
      ENDIF
C
C---  SETUP Z ARRAY APPROPRIATE TO CURRENT SM
C
      DO 210 I = 1,4
      DO 211 J = 1,3
      Z(I + (J-1)*4 ) = ZPLAN( (((ISM-1)*3 + J) - 1)*4  +  I )
  211 CONTINUE
  210 CONTINUE
C
C---  CENTRE OF PLANES
C
      ZSUM = 0.0
      DO 215 I = 1,12
      ZSUM = ZSUM + Z(I)
  215 CONTINUE
      ZMEAN = ZSUM/12.0
      DO 216 I = 1,12
      Z(I) = Z(I) - ZMEAN
  216 CONTINUE
C
C---  FIND Y U V FOR THE CURRENT SEGMENT
C
      IPLAN1 = MOD(ID1,10)
      IPLAN2 = MOD(ID2,10)
      IPLAN3 = MOD(ID3,10)
      ITRCK1 = ID1 / 10
      ITRCK2 = ID2 / 10
      ITRCK3 = ID3 / 10
C
C---  FIND OFSETS SUCH THAT Y ARRAY IS ON ORDER YUV
C
       IND = MOD(IPLAN1,3)
       IF (IND .EQ. 0) IND = 3
       IOFF1 = 2**IND
       IF (IOFF1 .EQ. 2) IOFF1 = 0
C---
       IND = MOD(IPLAN2,3)
       IF (IND .EQ. 0) IND = 3
       IOFF2 = 2**IND
       IF (IOFF2 .EQ. 2) IOFF2 = 0
C---
       IND = MOD(IPLAN3,3)
       IF (IND .EQ. 0) IND = 3
       IOFF3 = 2**IND
       IF (IOFF3 .EQ. 2) IOFF3 = 0
C---
         DO 10 I = 1,4
C
C---  Unpack segment Y values identifiers
C
         Y(I+IOFF1) = TCYUV(I,IPLAN1,ITRCK1)
         Y(I+IOFF2) = TCYUV(I,IPLAN2,ITRCK2)
         IF(ITRCK3 .NE. 0)THEN
            Y(I+IOFF3) = TCYUV(I,IPLAN3,ITRCK3)
         ELSE
            Y(I+IOFF3) = 0.0
         ENDIF
   10    CONTINUE
C
C---  SET WEIGHT MATRIX
C
      DO 20 I=1,4
         W(I+IOFF1) = TCYUVW(I,IPLAN1,ITRCK1)
         W(I+IOFF2) = TCYUVW(I,IPLAN2,ITRCK2)
      IF(ITRCK3 .NE. 0)THEN
         W(I+IOFF3) = TCYUVW(I,IPLAN3,ITRCK3)
      ELSE
         W(I+IOFF3) = 0.0
      ENDIF
C---
      IF(W(I+IOFF1) .NE. 0)THEN
       W(I+IOFF1) = 44.0
      ENDIF
      IF(W(I+IOFF2) .NE. 0)THEN
       W(I+IOFF2) = 44.0
      ENDIF
      IF(W(I+IOFF3) .NE. 0)THEN
       W(I+IOFF3) = 44.0
      ENDIF
   20 CONTINUE
C
C---  COUNT NUMBER OF DIGITIZINGS CONTRIBUTING
C
      NDIG = 0
      DO 21 I = 1,12
      IF(W(I) .EQ. 0.0)GO TO 21
      NDIG = NDIG+1
   21 CONTINUE
C
C---  ZERO SUMS
C
      DO 30 IO = 1,3
        WSUM(IO) = 0.0
        WZSUM(IO) = 0.0
        WZ2SUM(IO) = 0.0
        WYSUM(IO)=0.0
        WYZSUM(IO) = 0.0
   30 CONTINUE
C
C---  LOOP OVER Z POSITIONS TO FORM SUMS
C
      DO 40 IZ = 1,12
        IO = ((IZ-1)/4) + 1
C---
          WSUM(IO) = WSUM(IO) + W(IZ)
          WZSUM(IO) = WZSUM(IO)  +  W(IZ) * Z(IZ)
          WZ2SUM(IO) = WZ2SUM(IO)  +  W(IZ) * Z(IZ)**2
          WYSUM(IO) = WYSUM(IO)  +  W(IZ) * Y(IZ)
          WYZSUM(IO) = WYZSUM(IO)  +  W(IZ) * Y(IZ) * Z(IZ)
C---
   40 CONTINUE
C
C---  SCALE TERMS 2,3 BY COS2T
C
      DO 50 I =2,3
      WSUM(I) = COS2T(I) * WSUM(I)
      WZSUM(I) = COS2T(I) * WZSUM(I)
      WZ2SUM(I) = COS2T(I) * WZ2SUM(I)
   50 CONTINUE
C
C---  NOW FORM MTRIXA
C
      MTRIXA(1,1) = TAN2T(2) * WSUM(2) + TAN2T(3) * WSUM(3)
      MTRIXA(2,2) = WSUM(1) + WSUM(2) + WSUM(3)
      MTRIXA(3,3) = TAN2T(2) * WZ2SUM(2) + TAN2T(3) * WZ2SUM(3)
      MTRIXA(4,4) = WZ2SUM(1) + WZ2SUM(2) + WZ2SUM(3)
C---
      MTRIXA(1,2) = TANT(2) * WSUM(2) + TANT(3) * WSUM(3)
      MTRIXA(2,1) = MTRIXA(1,2)
      MTRIXA(1,3) = TAN2T(2) * WZSUM(2) + TAN2T(3) * WZSUM(3)
      MTRIXA(3,1) = MTRIXA(1,3)
      MTRIXA(1,4) = TANT(2) * WZSUM(2) + TANT(3) * WZSUM(3)
      MTRIXA(4,1) = MTRIXA(1,4)
C---
      MTRIXA(2,3) = TANT(2) * WZSUM(2) + TANT(3) * WZSUM(3)
      MTRIXA(3,2) = MTRIXA(2,3)
      MTRIXA(2,4) = WZSUM(1) + WZSUM(2) + WZSUM(3)
      MTRIXA(4,2) = MTRIXA(2,4)
C---
      MTRIXA(3,4) = TANT(2) * WZ2SUM(2) + TANT(3) * WZ2SUM(3)
      MTRIXA(4,3) = MTRIXA(3,4)
C
C---  NOW CALCULATE ERROR MATRIX FOR XY,SLOPE XY
C
      DO 60 IR=1,4
      DO 70IC=1,4
        EXYSXY(IR,IC) = MTRIXA(IR,IC)
   70 CONTINUE
   60 CONTINUE
C---
      CALL DINV(4,EXYSXY,4,WORK,IFAIL)
C---
      IF(IFAIL .NE. 0) THEN
         CALL ERRLOG(215,'W:FPFSTS: YUV fit failed')
         RETURN
      ENDIF
C
C---  CALCULATE VECTOR B
C
      B(1) = TANT(2)*COST(2) *  WYSUM(2) + TANT(3)*COST(3) * WYSUM(3)
      B(2) = WYSUM(1) + COST(2) * WYSUM(2) + COST(3) * WYSUM(3)
      B(3) = TANT(2)*COST(2) * WYZSUM(2) + TANT(3)*COST(3) * WYZSUM(3)
      B(4) =  WYZSUM(1) + COST(2) * WYZSUM(2) + COST(3) * WYZSUM(3)
C
C---  NOW SOLVE FOR X,Y,SX,SY
C
      DO 90 IR =1,4
      SOL(IR) = 0.0
   90 CONTINUE
      DO 100 IR = 1,4
      DO 110 IC = 1,4
         SOL(IR) = SOL(IR) + EXYSXY(IR,IC)*B(IC)
  110 CONTINUE
  100 CONTINUE
C
C---   PUT ZERO BACK TO Z=0 FROM Z=ZMEAN
C
         SOL(1) = SOL(1) - SOL(3)*ZMEAN
         SOL(2) = SOL(2) - SOL(4)*ZMEAN
         DO 632 I =1,12
         Z(I) = Z(I) + ZMEAN
  632    CONTINUE
C--
         CALL FPPPTZ(EXYSXY,-ZMEAN)
C
C---   NOW CALCULATE RESULTANT Y U V
C
      DO 130 IZ = 1,4
      YC(IZ) = SOL(2) + SOL(4)*Z(IZ)
      YC(IZ+4) = COST(2) * ( (SOL(2) + SOL(4)*Z(IZ+4) ) +
     1             TANT(2) * (SOL(1) + SOL(3)*Z(IZ+4) ) )
      YC(IZ+8) = COST(3) * ( (SOL(2) + SOL(4)*Z(IZ+8) ) +
     1             TANT(3) * (SOL(1) + SOL(3)*Z(IZ+8) ) )
  130 CONTINUE
C
C---  CALCULATE CHISQUARE
C
      CHISQ = 0.0
C
C---
C
      DO 140 IZ=1,12
      CHISQA(IZ) = (Y(IZ)-YC(IZ))**2*W(IZ)
      CHISQ = CHISQ + (Y(IZ)-YC(IZ))**2*W(IZ)
  140 CONTINUE
      NDF = NDIG-4
*     Fix for v. small Chisq...
      IF(CHISQ .LT. 0.001) THEN
       PCHI = 0.9999999
      ELSE
       PCHI = PROB( ABS(CHISQ),NDF )
      ENDIF

C
C---  PLSEG ARRAY FILLED HERE
C
          IF (NFSEG(ISM) .GE. MAXSEG) THEN
            CALL ERRLOG(216,'W:FPFSTS: .GT. MAXSEG segments found')
            RETURN
          ELSE
C
C---  INCREMENT FOUND SEGMENT COUNTER
C
      IF(PCHI .GT. 0.0)THEN
        NFSEG(ISM) = NFSEG(ISM) + 1
        IF(ITRCK3 .GT. 0)THEN
        NFSSEG(ISM) = NFSSEG(ISM) + 1
        ELSE
        NFTSEG(ISM) = NFTSEG(ISM) + 1
        ENDIF
      ELSE
        RETURN
      ENDIF
C
C---  Store away digitization pointers for found segment
C
      DO 305 I=1,4
       IDGISG(I+IOFF1,NFSEG(ISM),ISM) = IDGISM(I,IPLAN1,ITRCK1)
       IDGISG(I+IOFF2,NFSEG(ISM),ISM) = IDGISM(I,IPLAN2,ITRCK2)
      IF(ITRCK3 .GT. 0)THEN
       IDGISG(I+IOFF3,NFSEG(ISM),ISM) = IDGISM(I,IPLAN3,ITRCK3)
      ELSE
       IDGISG(I+IOFF3,NFSEG(ISM),ISM) = 0
      ENDIF
  305 CONTINUE
C
C---
      DO 300 I = 1,12
C
C---  PREPARE OUTPUT BANKS
C
      PW(I,NFSEG(ISM),ISM) = Y(I)
      PWC(I,NFSEG(ISM),ISM) = YC(I)
  300 CONTINUE
      PRCHI(NFSEG(ISM),ISM) = PCHI
C
C---  ROTATE BACK FROM THETA(1) = 0.0 TO X Y FRAME
C
        IF(TZERO .NE. 0.0)THEN
        S1 =   CTZERO*SOL(1) + STZERO*SOL(2)
        S2 = - STZERO*SOL(1) + CTZERO*SOL(2)
        S3 =   CTZERO*SOL(3) + STZERO*SOL(4)
        S4 = - STZERO*SOL(3) + CTZERO*SOL(4)
        SOL(1) = S1
        SOL(2) = S2
        SOL(3) = S3
        SOL(4) = S4
        ENDIF
      DO 301 I = 1,4

        XYDXY(I,NFSEG(ISM),ISM) = SOL(I)
          DO 302 J = 1,4
            EXYDXY(I,J,NFSEG(ISM),ISM) = EXYSXY(I,J)
  302     CONTINUE
  301 CONTINUE
      ZSEG(1,NFSEG(ISM),ISM) = Z(1)
      ZSEG(2,NFSEG(ISM),ISM) = Z(12)
C
C---  Store segments information for FPSGRF
C
      ISEGIN(1,NFSEG(ISM),ISM)=ID1
      ISEGIN(2,NFSEG(ISM),ISM)=ID2
      ISEGIN(3,NFSEG(ISM),ISM)=ID3
      ISEGIN(4,NFSEG(ISM),ISM)=NDF
      ASEGIN(  NFSEG(ISM),ISM)=CHISQ
C---
C---
          ENDIF
      END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.00/04 05/05/95  01.51.20  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  15.17.57  by  Stephen Burke
*-- Author :    R. Henderson   24/10/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPSSGF(LSECSG)
C---------------------------------------------------------------
C
C     Routine checks the connectivity of the found
C
C              SECONDARY and TERTIARY segments
C
C     and returns an optimized non-connected solution in MASKSG
C     0 = accept segment , -1 = reject segment
C
C     the difference between this routine and FPSGRF is that it
C     cannot assume that clusters are disconnected a priori
C
C---------------------------------------------------------------
C---
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEND.
C---
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
C---
*KEEP,FPCLUS.
      COMMON /FPCLUS/   TC(3,9,MAXCLU) , NTC(9) , TOC(3,9,MAXCLU) ,
     2                 TCYUV(4,9,MAXCLU), TCYUVW(4,9,MAXCLU)
C---
*KEEP,FPH1WRK.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
      LOGICAL DRMASK
      COMMON /H1WORK/
C--    *KEEP,FPCSEG.
C---
     3                  TPNORM(3,9,MAXCLU), PCONST(9,MAXCLU)     ,
     4                 SMLS(4,2,LIMSTO,3) ,
C---
C--    *KEEP,FPDIGI.
     5                 DRSTO(MSEGLM,4),NDRSTO(4),
     6               IDIGST(4,MSEGLM),
     7               SEGTAB(MSEGLM,MSEGLM),DRMASK(MSEGLM,4),
     8               IDCELL(MSEGLM,4),
     9               NSGTAB(MSEGLM),ASGTAB(MSEGLM),
     A               RESSTO(MSEGLM,4) ,
C---
C--    *KEEP,FPDGI.
     B               IDGIST(MSEGLM,4),IDGISM(4,9,MAXCLU)
     C               ,RCHI(MAXSEG,3) ,
C---
C--    *KEEP,FPSTID.
     D               IDRSTO(MSEGLM,4),IDYUV(4,9,MSEGLM),
     E               IDYUVS(12,MAXSEG,3),FREQ(MSEGLM+1) ,
C---
C--    *interface to real data
     F             NDPW(NUMWPL),DW(MAXHTS,NUMWPL),DWG(MAXHTS,NUMWPL),
     G             DRIWP(MAXHTS,NUMWPL),DRIWM(MAXHTS,NUMWPL),
     G             DRIW(MAXHTS,NUMWPL),IPHOLE(MAXHTS,NUMWPL),
     H             IPFRPE(MAXHTS,36), IPPIOS(MAXDIG,2)
C---.
*KEND.
C---
*KEEP,FPSTSG.
      COMMON/FPSTSG/ NSTC(9),NFSSEG(3),NFTSEG(3)
C---
*KEND.
C
C---
C---
C---
C---  Local variables
C---
C---  ISGTAB (I,J) = segment number of Jth node connected to Ith node
C---  KSGTAB (I)   = number of segments connected to Ith node
C---  MXLIS        = list of nodes with maximum connectivity
C---  CHLIS        = weight asscociated with each node listed in MXLIS
C
      DIMENSION KSGTAB(MAXSEG) , FSGTAB(MAXSEG) , ISGTAB(MAXSEG,MAXCON)
      DIMENSION MXLIS(MAXSEG) , CHLIS(MAXSEG)
      LOGICAL LSECSG,LFIRST
      DATA LFIRST/.TRUE./
C
C---  input
C
C     ASEGIN(SEG,SUPERMODULE)   = chisquare of segment
C
C     ISEGIN(1,SEG,SUPERMODULE) = 1st cluster-plane for segment
C     ISEGIN(2,SEG,SUPERMODULE) = 2nd cluster-plane for segment
C     ISEGIN(3,SEG,SUPERMODULE) = 3rd cluster-plane for segment
C     ISEGIN(4,SEG,SUPERMODULE) = number of degree of freedom for segment
C
C     NFSEG(SUPERMODULE)        = number of found segments per supermodule
C
C---  output
C
C     MASKSG(SEG,SUPERMODULE)   = 0   if allowed
C                               = -1  if lost
C
      IF (LFIRST) THEN
         LFIRST = .FALSE.
         CALL FPPBIN
      ENDIF
C
C---  loop over supermodules
C
      DO 10 ISM = 1,3
C
C---  define where secondary segments start depending on whether
C---  called from Secondary or tertiary segment finder.
C
      IF(LSECSG)THEN
      NGSEG = NFSEG(ISM) - NFSSEG(ISM)
      NSTSSG = NGSEG + 1
      ELSE
      NGSEG = NFSEG(ISM) - NFTSEG(ISM)
      NSTSSG = NGSEG + 1
      ENDIF
C
C---  zero ksgtab
C
      DO 50 I = 1,MAXSEG
      KSGTAB(I) = 0
   50 CONTINUE
C
C---  construct connectivity table
C
C
C---  1st loop over segments
C
        DO 20 ISEG = NSTSSG,NFSEG(ISM)
          DO 21 KSEG = NSTSSG,NFSEG(ISM)
C
C---  remove if segs the same
C
          IF(ISEG.EQ.KSEG)GO TO 21
C
C---  search to see if any cluster planes in common
C
            DO 30 ID1 = 1,3
            ICP1 = ISEGIN(ID1,ISEG,ISM)
C
C---  decode cluster planes
C
*            IP1 = MOD(ICP1,10)
            ICL1 = ICP1/10
            IP1  = ICP1 - ICL1*10
C---
            DO 31 ID2 = 1,3
            ICP2 = ISEGIN(ID2,KSEG,ISM)
C
C---  decode cluster planes
C
*            IP2 = MOD(ICP2,10)
            ICL2 = ICP2/10
            IP2  = ICP2 - ICL2*10
C
C---  if planes the same loop over wires to see if same digits used
C
      IF(IP1 .EQ. IP2 .AND. ICL1.NE.0 .AND. ICL2.NE.0)THEN
      IP = IP1
         DO 33 IWW = 1,4
C
C---  if digits are the same (and not 0) then build connection
C
*         IF(ICL1 .EQ. 0  .OR.  ICL2 .EQ. 0)GO TO 33
C
         IF(IABS(IDGISM(IWW,IP,ICL1)) .EQ. 0)GO TO 33
C
         IF(IABS(IDGISM(IWW,IP,ICL1)) .NE.
     1      IABS(IDGISM(IWW,IP,ICL2)))GO TO 33
C
C---  found one in common , increment counter , store connection
C
             KSGTAB(ISEG) = KSGTAB(ISEG) + 1
C
C---  trap out of bounds. has been known to happen in MC!
C
             IF(KSGTAB(ISEG) .GT. MAXCON) THEN
               GO TO 999
             ENDIF

             ISGTAB(ISEG,KSGTAB(ISEG)) = KSEG
C
C---  connection found skip furthur search of KSEG segment
C
             GO TO 21
C
 33      CONTINUE
      ENDIF
   31       CONTINUE
   30       CONTINUE
   21     CONTINUE
   20   CONTINUE
C
C
C
C
C---  Start to remove connectivity
C
C
C---  Find the highest multiplicity
C
  500 CONTINUE
       IF( NFSEG(ISM) .GT. 0)THEN
       CALL VFLOAT(KSGTAB,FSGTAB,NFSEG(ISM))
       MXSEG = LVMAX(FSGTAB,NFSEG(ISM))
       IVMXSG = KSGTAB(MXSEG)
       ELSE
       IVMXSG = 0
       ENDIF
      IF(IVMXSG .EQ. 0) GO TO 600
C
C---   Loop over all segments and find those with same multiplicity
C
       NMXSG = 0
       DO 510 ISEG = NSTSSG,NFSEG(ISM)
C       IF(KSGTAB(ISEG) .LT. (IVMXSG-2)
       IF(KSGTAB(ISEG) .LT. (IVMXSG)
     1    .OR. KSGTAB(ISEG) .LE. 0) GO TO 510
         NMXSG = NMXSG + 1
         MXLIS(NMXSG) = ISEG
  510  CONTINUE
C
C---  Find which segment contributes most to chisquare
C
       DO 520 IMX = 1 , NMXSG
       MXSEG = MXLIS(IMX)
C
C---   Find probablility of link segments
C
       CHISUM = 0.0
       NDFSUM = 0
         DO 521 LSEG = 1,KSGTAB(MXSEG)
         CHISUM = CHISUM + ASEGIN(ISGTAB(MXSEG,LSEG),ISM)
         NDFSUM = NDFSUM + ISEGIN(4,ISGTAB(MXSEG,LSEG),ISM)
  521    CONTINUE
C
C---   Store probability of links less own prob
C
*      Fix for v.small chisq...
       IF(CHISUM .LT. 0.001) THEN
        PROB1 = 0.99999
       ELSE
        PROB1 = FPPROB(CHISUM,NDFSUM)
C        PROB1 = PROB(CHISUM,NDFSUM)
       ENDIF
       IF(ASEGIN(MXSEG,ISM) .LT. 0.001) THEN
        PROB2 = 0.99999
       ELSE
        PROB2 = FPPROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM))
C        PROB2 = PROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM))
       ENDIF
         CHLIS(IMX) = PROB1 - PROB2
*        CHLIS(IMX) = PROB(CHISUM,NDFSUM) -
*    1                PROB(ASEGIN(MXSEG,ISM),ISEGIN(4,MXSEG,ISM))
  520  CONTINUE
C
C
C---  Find the segment with largest positive contribution
C
       MXPSEG = LVMAX(CHLIS,NMXSG)
       IWSEG  = MXLIS(MXPSEG)
C
C---  Remove all reference to this segment from connectivity table
C
*      KSGTAB(IWSEG) = -1
*      DO 530 IS = NSTSSG, NFSEG(ISM)
*        IF( KSGTAB(IS) .LT. 1)GO TO 530
*          DO 531 ILS = 1, KSGTAB(IS)
*            IF(ISGTAB(IS,ILS) .NE. IWSEG) GO TO 531
*              ISGTAB(IS,ILS) = ISGTAB(IS,KSGTAB(IS))
*              KSGTAB(IS) = KSGTAB(IS) - 1
*  531     CONTINUE
*  530 CONTINUE
      DO 530 ILLS = 1, KSGTAB(IWSEG)
        IS = ISGTAB(IWSEG,ILLS)
          DO 531 ILS = 1, KSGTAB(IS)
            IF(ISGTAB(IS,ILS) .NE. IWSEG) GO TO 531
              ISGTAB(IS,ILS) = ISGTAB(IS,KSGTAB(IS))
              KSGTAB(IS) = KSGTAB(IS) - 1
              GOTO 530
  531     CONTINUE
  530 CONTINUE
      KSGTAB(IWSEG) = -1
C
C
C---  Repeat proceedure on remaining nodes
C
C
      GO TO 500
C
C
C---   No connectivity remaining
C
  600 CONTINUE
C---
C
C---  Write output bank
C
      DO 650 I = NSTSSG,NFSEG(ISM)
      MASKSG(I,ISM) = KSGTAB(I)
  650 CONTINUE
   10 CONTINUE
      RETURN

C
C---  Something horrible has happened - kill event!
C
  999 CONTINUE
      CALL ERRLOG(217,'W:FPSSGF: Too much confusion! Planar data off')
      DO 888 ISM = 1,3
       NFSEG(ISM) = 0
  888 CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.00/04 27/04/95  21.19.24  by  Stephen Burke
*-- Author :    R. Henderson   24/10/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPNDCA(TODIG,VDIG,TOCLS,VCLS,DIST)
C------------------------------------------------------------
C-----  FIND dca for the vectors a = todig + x*vdig
C-----           and the vectors b = tocls + x*vcls
C------------------------------------------------------------

      DOUBLE PRECISION AX(3,3),BTRIX(3),ADET,A1,A2,A3
      DIMENSION TODIG(3),VDIG(3),TOCLS(3),VCLS(3),TCP(3)

C------------------------------------------------------------

      TCP(1) = VCLS(2)*VDIG(3) - VCLS(3)*VDIG(2)
      TCP(2) = VCLS(3)*VDIG(1) - VCLS(1)*VDIG(3)
      TCP(3) = VCLS(1)*VDIG(2) - VCLS(2)*VDIG(1)

      AX(1,1) = VCLS(1)
      AX(1,2) = VCLS(2)
      AX(1,3) = VCLS(3)
      AX(2,1) = -VDIG(1)
      AX(2,2) = -VDIG(2)
      AX(2,3) = -VDIG(3)
      AX(3,1) = TCP(1)
      AX(3,2) = TCP(2)
      AX(3,3) = TCP(3)

      ADET = AX(1,3)*(AX(2,2)*AX(3,1) - AX(2,1)*AX(3,2))
     &     - AX(2,3)*(AX(1,2)*AX(3,1) - AX(1,1)*AX(3,2))
     &     + AX(3,3)*(AX(1,2)*AX(2,1) - AX(2,2)*AX(1,1))

      A1 = AX(1,3)*AX(2,2) - AX(1,2)*AX(2,3)
      A2 = AX(1,1)*AX(2,3) - AX(1,3)*AX(2,1)
      A3 = AX(1,2)*AX(2,1) - AX(1,1)*AX(2,2)

      BTRIX(1) = TOCLS(1) - TODIG(1)
      BTRIX(2) = TOCLS(2) - TODIG(2)
      BTRIX(3) = TOCLS(3) - TODIG(3)

      VMOD = TCP(1)**2 + TCP(2)**2 + TCP(3)**2

      DIST = (A1*BTRIX(1) + A2*BTRIX(2) + A3*BTRIX(3))*SQRT(VMOD)/ADET

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.00/04 05/05/95  00.57.39  by  Stephen Burke
*-- Author :    Stephen Burke   05/05/95
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPPBIN
C----------------------------------------------------
C
C---  Initialize an array parray with probabilities
C---  for chisq versus number of degrees of freedom
C---  for ndf .lt. 20
C---  first bin n    1-1000 is chisq in n/16ths
C---  first bin n 1001-2000 is chisq in n/8ths
C---  for ndf .ge. 20 .and. ndf .le.50
C---  first bin n    1-1000 is chisq in n/8ths
C---  first bin n 1001-2000 is chisq in n/4ths
C---  second bin is NDF 6-55
C---  if greater than 55 the prob function used directly
C
C----------------------------------------------------
      COMMON/FPBCOM/PARRAY(1800,50)

      DO 300 J=2,51
         IF (J.LT.20) THEN
            NFACT1 = 16
            NFACT2 = 8
         ELSE
            NFACT1 = 8
            NFACT2 = 4
         ENDIF
         DO 100 I=1,1000
            PARRAY(I,J-1) = PROB(FLOAT(I)/NFACT1,J)
 100     CONTINUE
         DO 200 I=501,1300
            PARRAY(I+500,J-1) = PROB(FLOAT(I)/NFACT2,J)
 200     CONTINUE
 300  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.14  by  Stephen Burke
*CMZU:  7.00/04 08/05/95  16.14.12  by  Stephen Burke
*-- Author :    Stephen Burke   05/05/95
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      FUNCTION FPPROB(CHISQ,NDF)
C----------------------------------------------------
C
C---  Array parray with probabilities
C---  for chisq versus number of degrees of freedom
C---  first bin n    1-1000 is chisq in n/16ths
C---  first bin n 1001-2000 is chisq in n/8ths
C---  second bin is NDF 6-12
C
C----------------------------------------------------

      COMMON/FPBCOM/PARRAY(1800,50)

C----------------------------------------------------

      IF(NDF.LT.20)THEN
         IF(CHISQ.LT.62.5)THEN
           ICHIBN = IFIX(CHISQ*16.0 - 0.5) + 1
           FPPROB = PARRAY(ICHIBN,NDF-1)
         ELSEIF(CHISQ.LT.162.5)THEN
           ICHIBN = 1000 + IFIX((CHISQ-62.5)*8.0 - 0.5) + 1
           FPPROB = PARRAY(ICHIBN,NDF-1)
         ELSE
           FPPROB = 0.0
         ENDIF
      ELSEIF(NDF.LE.51)THEN
         IF(CHISQ.LT.125.0)THEN
           ICHIBN = IFIX(CHISQ*8.0 - 0.5) + 1
           FPPROB = PARRAY(ICHIBN,NDF-1)
         ELSEIF(CHISQ.LT.325.0)THEN
           ICHIBN = 1000 + IFIX((CHISQ-125.0)*4.0 - 0.5) + 1
           FPPROB = PARRAY(ICHIBN,NDF-1)
         ELSE
           FPPROB = 0.0
         ENDIF
      ELSE
         FPPROB = PROB(CHISQ,NDF)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZ :  3.01/08 13/02/92  18.25.30  by  Gregorio Bernardi
*-- Author :
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPHITZ(IPRT)
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.  FRHC hit multiplicity/pointer 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/
*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.

      DIMENSION NUMR(36) , NUMP(36)
      COMMON/FRSTAT/IEVRAD, IEVR12, IEVPLA, IEVP12
      LOGICAL FIRST
      DATA FIRST / .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))
*KEND.

      IF(FIRST) THEN
         FIRST = .FALSE.
         IEVRAD = 0
         IEVR12 = 0
         IEVPLA = 0
         IEVP12 = 0
      ENDIF

      NBN = 0
      IND = NLINK('FRHC',NBN)
      IF(IND.EQ.0 .AND. IPRT .EQ. 1) THEN
        WRITE(6,*) ' FPHITZ>> FRHC Bank not found in event ',NEVENT
        RETURN
      ENDIF

      IPLANE = 0
      IRTOT  = 0
      DO 2 I = 0, 2
      DO 1 J = 1, 12
        IPLANE = IPLANE + 1
        NUMR(IPLANE) = 0
        DO 3 K=0, 23
           NUM = IBTAB(IND,1,I*12*24 + J + K*12)
           NUMR(IPLANE) = NUMR(IPLANE) + NUM
           IRTOT        = IRTOT        + NUM
 3      CONTINUE
 1    CONTINUE
 2    CONTINUE

      NBN = 0
      IND = NLINK('FPHC',NBN)
      IF(IND.EQ.0 .AND. IPRT .EQ. 1) THEN
        WRITE(6,*) ' FPHITZ>> FPHC Bank not found in event ',NEVENT
        RETURN
      ENDIF

      IPLANE = 0
      IPTOT  = 0
      DO 6 IJK=0,3*3*4-1
        I=IJK/12
        IREST=IJK-I*12
        J=IREST/4
        K=IREST-J*4+1
*      DO 4 I = 0, 2
*      DO 5 J = 0, 2
*      DO 6 K = 1, 4
        IPLANE = IPLANE + 1
        NUMP(IPLANE) = 0
        DO 7  L = 0, 31
        NUM = IBTAB(IND,1,I*4*3*32 + J*4*32 + K + L*4)
        NUMP(IPLANE) = NUMP(IPLANE) + NUM
        IPTOT        = IPTOT        + NUM
 7    CONTINUE
 6    CONTINUE
* 5    CONTINUE
* 4    CONTINUE


      IF(IRTOT .GT. 0) IEVRAD = IEVRAD + 1
      IF(IRTOT .GT.12) IEVR12 = IEVR12 + 1

      IF(IPTOT .GT. 0) IEVPLA = IEVPLA + 1
      IF(IPTOT .GT.12) IEVP12 = IEVP12 + 1

      CALL HFILL(40401,FLOAT(IPTOT)+0.5,0.0,1.0)
      CALL HFILL(40402,FLOAT(IRTOT)+0.5,0.0,1.0)

      IF(IPRT .EQ. 1) THEN
      WRITE(6,'(/,8X,'' ----  Radial hits:  Event'',I10,'' Num='',I4)')
     +      NEVENT, IRTOT
      WRITE(6,'(3(4I3,2X,4I3,2X,4I3,/))') (NUMR(IPL), IPL = 1,36)
      WRITE(6,'(/,8X,'' ----  Planar Hits:  Event'',I10,'' Num='',I4)')
     +      NEVENT, IPTOT
      WRITE(6,'(3(4I3,2X,4I3,2X,4I3,/))') (NUMP(IPL), IPL = 1,36)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZU:  2.05/07 18/07/91  00.01.58  by  Girish D. Patel
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTDIA
******========== ======*********************************************
*  DIAGNOSTICS FOR PATTERN RECOGNITION IN FORWARD DRIFT CHAMBERS   *
*  =========== === ======= =========== == ======= ===== ========   *
*                                                                  *
********************************************************************
* BOS Commons...
*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,FRDIMS.
      PARAMETER (MAXHTS=200)
      PARAMETER (NUMWPL=36)
      PARAMETER (MAXTRK=200)
      PARAMETER (MXTTRK=900)
      PARAMETER (MAXTR3=200)
      PARAMETER (MAXHPW=2)
      PARAMETER (MAXDIG=2000)
      PARAMETER (NUMRWR=1727)
      PARAMETER (NUMPWR=1151)
*KEEP,FPPRAM.
C
C---  MAXSEG is maximum number of segments per supermodule
C---  MAXCON is maximum number of amibiguous segments associatable with
C---         one segment
C---  LIMSTO is maximum number of 2 cluster planes intersections to be
C---         stored per supermodule
C---  MSEGLM is maximum number of clusters that can be found before
C---         connectivity considered
C---  MAXCLU is maximum number of clusters that can be found after
C---         forming non-connected set    MUST BE 50 IF RUN WITH OLD RCWH CODE
C---         (cluster = 3/4 digits found in a straight line in one
C---          4-wire orientation)
C
      PARAMETER (MAXSEG = 200)
      PARAMETER (MAXCON = 100)
      PARAMETER (LIMSTO = 5000)
      PARAMETER (MSEGLM = 150)
      PARAMETER (MAXCLU = 50)
C---
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
*     Diagnostic flag from FRCS BANK
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.
*     Vertex...
*KEEP,FPTVTX.
      COMMON/VERTVV/ZV ,XVV,YVV
**the common/VERTEX/ becomes /VERTVV/ (in analogy to /VERTFF/) on the
** 17/6/91, since it is in conflict with the VERTEX module (g.bernardi)
** (note that all these common names should start by F in this deck...)
*KEND.
*     Radial geometry...
*     Planar geometry...
*     Radial hits...
*     Planar hits...
*KEEP,FH1WORK.
       COMMON/FGMIOS/
*    Planar geometry
     + ZPP(140),C(140),S(140),ITYPE(140),WZERO(140),WSPACE,
*
*    Radial geometry
     + ZP(36),PHW(36),WS(36)
*
       COMMON/H1WORK/
*    Radial data...
     + WW(MAXHTS,36),DRI(MAXHTS,36),RM(MAXHTS,36),
     + NDP(36),  NW(MAXHTS,36), DWS(MAXHTS,36),
*
*    Planar Data
     + NDPW(NUMWPL),DW(MAXHTS,NUMWPL),
     + DRIW(MAXHTS,NUMWPL),NDW(MAXHTS,NUMWPL),
     + WWP(MAXHTS,NUMWPL),
     + IPHOLE(MAXHTS,NUMWPL),
*
*    Pointers into DIGI bank for IOS labelled hits
     +  IPFRRE(MAXHTS,36),IPFRPE(MAXHTS,36),NFRRE,NFRPE,
     +  IRPIOS(MAXDIG,2), IPPIOS(MAXDIG,2),
*
*    Track segment data
     + NTRAKS(3),IRPT(12,MAXTRK,3),SDRFT(12,MAXTRK,3),
*
*    Fit data
     + PCOSL(MAXTRK,3),PSINL(MAXTRK,3),PHZL(MAXTRK,3),
     + DPCOSL(MAXTRK,3),DPSINL(MAXTRK,3),
     + DPHZL(MAXTRK,3),CHSQ(MAXTRK,3),RZI(MAXTRK,3),
     + RPCOSG(MAXTRK),RPSING(MAXTRK),
     + PHZG(MAXTRK),CC(3,MAXTRK),ZIG(MAXTRK),
     + IRADG(36,MAXTRK),PHIG(36,MAXTRK),
     + IG,SDRADG(36,MAXTRK),
     + R1,Z1,RFIT(MAXTRK,3),
     + CHG(MAXTRK),
     + PPA(MAXTRK,3),  ZZA(MAXTRK,3),
     + GPA(MAXTRK,3),GZA(MAXTRK,3)
*
*
*KEEP,FPLSEG.
C---
      COMMON /FPLSEG / PW(12,MAXSEG,3)   , PWC(12,MAXSEG,3)     ,
     1                 PRCHI(MAXSEG,3)   , NFSEG(3)             ,
     2                 XYDXY(4,MAXSEG,3) , EXYDXY(4,4,MAXSEG,3) ,
     3                 ZSEG(2,MAXSEG,3)  ,
     4                 ASEGIN(MAXSEG,3)  , ISEGIN(5,MAXSEG,3)   ,
     5                 MASKSG(MAXSEG,3)  , IDGISG(12,MAXSEG,3)
C---
*KEND.
      DIMENSION ITRUT(36), JDIGS(36), IDX(36)
      DIMENSION ITRUTP(36), JDIGSP(36), IDXP(36)
      DIMENSION KFNDR(36), KFNDP(36)
      DIMENSION ICOMPR(36), ICOMPP(36)
*     Common for work bank indices...
      COMMON /FRDIAC/IWFPUR,IWFRUX,IWFPUX
*------statement functions for table access--------------------------
*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.
*------------------------Begin --------------------------------------

*     Short printout...
      IF(IDIAG2.GE.1) THEN
       KFTUR=0
       IWFTUR  = NLINK('FTUR',0)
*      Check to see if any information...
       IF( IWFTUR .NE. 0 ) THEN
         KFTUR  = IW(IWFTUR+2)
       ENDIF
       WRITE(6,'('' '','' Event'',I5,5X,I4,
     +           '' FTUR tracks reconstructed'')')NEVENT, KFTUR
      ENDIF
      IF(IDIAG.EQ.0) RETURN
*
*     For all events, REAL and MONTE CARLO...
      WRITE(6,'(/,
     +          70(''=''),/,
     +            17X,''Diagnostics For Event:'',I5)') NEVENT
      IF(IDIAG.GE.1)THEN
         CALL FPFTUR
      ENDIF
      IF(IDIAG.GE.2)THEN
         CALL FPFPUR
         CALL FPFRUX
         CALL FPFPUX
      ENDIF
      IF(IDIAG.GE.3) THEN
          CALL FPFRRE
          CALL FPFRPE
          CALL FPFRLC
          CALL FPFRHC
          CALL FPFPLC
          CALL FPFPHC
      ENDIF

*---- real data diagnostics end here-------------------------
*
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZU:  7.01/00 11/07/95  22.11.35  by  Stephen Burke
*CMZU:  7.00/04 21/04/95  15.35.36  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.01  by  Stephen Burke
*-- Author :    Stephen Burke   30/08/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPT0
*-----------------------------------------Updates 07/09/93-------
**: FPT0 40000 SB.   New routine to plot DT vs. trigger element.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Histogram the planar drift time distribution for each trigger      *
* element.                                                           *
*                                                                    *
**********************************************************************

      COMMON /FPT0XX/ INFRPE

*KEEP,CTCPAR.
*
*     DESCRIPTION of INPUT CARDS
*                             number of CTC_Input cards
      INTEGER NCARD
      PARAMETER (NCARD=3)
*                             number of Trigger Elements groups per card
*                             and number of trigger elements per group
      INTEGER NTEGRP,NTEPGP
      PARAMETER (NTEGRP=8,NTEPGP=8)
*                             number of Trigger Elements
      INTEGER NTELMS
      PARAMETER (NTELMS=NTEGRP*NTEPGP*NCARD)
*                             number of trigger elements per word
      INTEGER NTE_P_WRD
      PARAMETER (NTE_P_WRD=32)
*                             number of trigger element words
      INTEGER TE_NWORD
      PARAMETER (TE_NWORD=NTELMS/NTE_P_WRD)

*                             number of RAM (8(11) bit groups)
      INTEGER NRAM
      PARAMETER (NRAM=NTEGRP*NCARD)
*                             maximal number of bits per RAM
      INTEGER BPRAM
      PARAMETER (BPRAM=11)
*
*     DESCRIPTION of SUMMING CARDS
*                             number of CTC_Summing cards
      INTEGER NSUMCD
      PARAMETER (NSUMCD=4)
*                             number of subtriggers
      INTEGER NSUBTR
      PARAMETER (NSUBTR=128)
*                             number of subtriggers per card
      INTEGER NST_P_CARD
      PARAMETER (NST_P_CARD=32)
*                             number of subtrigger gate groups
      INTEGER NST_GATEGR
      PARAMETER (NST_GATEGR=8)
*
*     TECHNICAL OFFLINE PARAMETERS
*                             maximum number of conditions per subtrigger
      INTEGER MAXCON
      PARAMETER (MAXCON=16)

*KEND.
      INTEGER TEL1(0:NTELMS-1)
      CHARACTER*256 TNAME

*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,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 (BEGJOB) THEN
         CALL HCDIR('//PAWC',' ')
         CALL HMDIR('FPT0','S')
         DO 100 JHIST=1,NTELMS
            CALL TELNAM(JHIST-1,TNAME)
            CALL HBOOK1(JHIST,'PLANAR DRIFT TIME - '//
     &                         TNAME(1:LENB(TNAME)),100,0.,2000.,0.)
 100     CONTINUE
         CALL HMINIM(0,0.)
         CALL HIDOPT(0,'INTE')
      ENDIF

      IF (ENDJOB) THEN
         CALL HCDIR('//PAWC/FPT0',' ')
         DO 200 JHIST=1,NTELMS
            CALL HPRINT(JHIST)
 200     CONTINUE
         CALL HCDIR('//PAWC',' ')
         RETURN
      ENDIF

      IF (.NOT.REVENT) RETURN

      CALL UNTEL1(0,0,1,TEL1,IEXIST)
      INFRPE = NLINK('FRPE',0)

      IF (IEXIST.LE.0  .OR. INFRPE.LE.0) RETURN

      CALL HCDIR('//PAWC/FPT0',' ')

      INFRPE = 0
      CALL BKTOW(IW,'FRPE',0,IW,INFRPE,*1000)

      DO 700 JFRPE=1,IW(INFRPE+2)
         DT = IBTAB(INFRPE,2,JFRPE)
         DO 400 JB=1,NTELMS
            IF (TEL1(JB-1).EQ.1) CALL HFILL(JB,DT,0.,1.)
 400     CONTINUE
 700  CONTINUE

 1000 CONTINUE

* Must make sure work banks are dropped!!!
      CALL WDROP(IW,INFRPE)

      CALL HCDIR('//PAWC',' ')

      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.20.53  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZ :  3.01/08 13/02/92  18.25.30  by  Gregorio Bernardi
*-- Author :    Girish D. Patel   25/04/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FPHC.DDL.html">FPHC</A>
*  (Planar Hit multiplicity) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FPHC bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FPHC bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFPHC
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.  FPHC hit multiplicity/pointer 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/
*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,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.

      NBN = 0
      IND = NLINK('FPHC',NBN)
      IF(IND.EQ.0) THEN
        WRITE(6,*) ' FPFPHC>> FPHC Bank not found in event ',NEVENT
        RETURN
      ENDIF
      NROW = IW(IND+2)
      WRITE(6,'(''  '')')
      WRITE(6,'(/,8X,'' -------  FPHC BANK:  Event'',I10,
     +          2X,I4,'' Hits ---------'')')
     +      NEVENT,NROW

      WRITE(6, '(1x,''No '',32I3)') (K,K=0,31)

      IPLANE = 0
      DO 3 IJK=0,3*3*4-1
        I=IJK/12
        IREST=IJK-I*12
        IF(IREST.EQ.0)WRITE(6,*) ' '
        J=IREST/4
        K=IREST-J*4+1
        IF(K.EQ.1)WRITE(6,*) ' '
*      DO 3 I = 0, 2
*        WRITE(6,*) ' '
*      DO 2 J = 0, 2
*        WRITE(6,*) ' '
*      DO 1 K = 1, 4
        IPLANE = IPLANE + 1
        WRITE(6,'(1X,33I3)') IPLANE,
     &  (IBTAB(IND,1,I*4*3*32 + J*4*32 + K + L*4),L=0,31)

* 1    CONTINUE
* 2    CONTINUE
 3    CONTINUE
      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.19.08  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.34  by  Stephen Burke
*-- Author :    Girish D. Patel   16/04/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FPLC.DDL.html">FPLC</A>
*  (Planar Local Co-ordinates) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FPLC bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FPLC bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFPLC
**: FPFPLC 30907 RP. Farm changes.
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.  FPLC local coordinate 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/
*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.
      COMMON /FPF8WW/ INDFPX
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

      NBN = 0
      IND = NLINK('FPLC',NBN)
      IF(IND.EQ.0) THEN
        WRITE(6,*) ' FPFPLC>> FPLC Bank not found in event ',NEVENT
        RETURN
      ENDIF
      NROW = IW(IND+2)

      WRITE(6,'(''  '')')
      WRITE(6,'(/,8X,'' -------  FPLC BANK:  Event'',I10,
     +          2X,I4,'' Hits ---------'')')
     +      NEVENT,NROW
      IF(NROW .GT.0) THEN

      NBN = 0
      INDE = NLINK('FPUX',NBN)

      INDFPX = 0
      IF(INDE .NE. 0) THEN
         CALL BKTOW(IW,'FPUX',NBN,IW,INDFPX,*900)
      ELSE
         WRITE(6,'('' FPFPLC Error ... Hits but no FPUX bank!'')')
      ENDIF

      WRITE(6, '(
     +      '' Row Cel Pln   Drf  Edrf   Phiw   Wwir'',
     +              ''     w+     w-      z Sg'')')

      DO 1 J= 1,NROW
*       Calculate w coordinates of the hit (both solutions)
        CALL FPWHIT(J,WWP,WWM,PHW,WWIR,ZZ,IBAD)
*       Sign of hit from FPUX bank
        IF(INDFPX .NE. 0) THEN
          IUSED = IBTAB(INDFPX,1,J)
          IF(IUSED .NE. 0) THEN
            ISIGN = IBTAB(INDFPX,2,J)
          ELSE
            ISIGN = -1
          ENDIF
        ELSE
          ISIGN = -1
        ENDIF

        WRITE(6,'(I4,I5,I4,2(F6.3),5(1X,F6.2),I3)')
     +          J, IBTAB(IND,1,J),
     +             IPIOSW(IBTAB(IND,1,J)),
     +            (RBTAB(IND,K,J), K=2,3),
     +          PHW, WWIR, WWP, WWM, ZZ, ISIGN

 1    CONTINUE

      ENDIF
 900  CONTINUE
      CALL WDROP(IW,INDFPX)
      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.22.51  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZ :  2.05/07 18/07/91  13.19.16  by  Gregorio Bernardi
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FPUR.DDL.html">FPUR</A>
*  (Track hit pointering) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FPUR bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FPUR bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFPUR
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form. Pointering Bank FPUR                *
*-----------------------------------------------------------*
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
      COMMON /FPF6WW/ INDFRD
*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.
*     pointer list...
      NBN  = 0
      IND  = NLINK('FPUR',NBN)
      IF (IND .EQ. 0) THEN
        WRITE(6,*) ' FPFPUR>> FPUR Bank not found in event ',NEVENT
        RETURN
      ENDIF
      INDFRD=0
      CALL BKTOW(IW,'FPUR',NBN,IW,INDFRD,*900)
      NROW = IW(INDFRD+2)
      WRITE(6,'('' '')')
      WRITE(6,'(/,10X,'' ------  FPUR BANK:  Event'',I10,
     +          3X,I4,'' tracks------'')')
     +      NEVENT,NROW
      WRITE(6,  '(''  Track NHITFR   FRUX NHITFP   FPUX'')')
      DO 4 J= 1,NROW
        WRITE(6,'( 5(1X,I6) )')
     +       J   ,(IBTAB(INDFRD,K,J   ), K=1,4)
 4    CONTINUE
      CALL WDROP(IW,INDFRD)
      RETURN
*     Error condition...
 900  CONTINUE
      WRITE(6,*) ' FPFPUR >> Error in Work Bank Creation'
      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.24.46  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZ :  2.05/07 18/07/91  13.19.16  by  Gregorio Bernardi
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FPUX.DDL.html">FPUX</A>
*  (Planar track hit-list) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FPUX bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FPUX bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFPUX
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.                                     *
*-----------------------------------------------------------*
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
      COMMON /FPFRWW/ INDFPD
*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.
      NBN  = 0
      IND  = NLINK('FPUX',NBN)
      IF (IND .EQ. 0) THEN
        WRITE(6,*) ' FPFPUX>> FPUX Bank not found in event ',NEVENT
        RETURN
      ENDIF
      INDFPD=0
      CALL BKTOW(IW,'FPUX',NBN,IW,INDFPD,*900)
      NROW = IW(INDFPD+2)
      WRITE(6,'('' '')')
      WRITE(6,'(/,10X,'' ------  FPUX BANK:  Event'',I10,
     +          3X,I4,'' hits -------'')')
     +      NEVENT,NROW
      WRITE(6,  '(''    Hit   Next    Sgn'',
     +    ''    '',''   Hit   Next    Sgn'',
     +    ''    '',''   Hit   Next    Sgn'')')
      MROW = NROW/3
      KMORE= NROW-3*MROW
      J2   = MROW
      IF(KMORE.NE.0) J2 = J2 + 1
      J3   = MROW*2 + KMORE
      IF(MROW.GT.0) THEN
      DO 6 J= 1,MROW
        WRITE(6,'( 3(1X,I6),3X,3(1X,I6),3X,3(1X,I6) )')
     +       J   ,(IBTAB(INDFPD,K,J   ), K=1,2),
     +       J+J2,(IBTAB(INDFPD,K,J+J2), K=1,2),
     +       J+J3,(IBTAB(INDFPD,K,J+J3), K=1,2)
 6    CONTINUE
      ENDIF
      IF(KMORE.EQ.1) THEN
        J= MROW + 1
        WRITE(6,'( 3(1X,I6) )')
     +       J   ,(IBTAB(INDFPD,K,J   ), K=1,2)
      ENDIF
      IF(KMORE.EQ.2) THEN
        J= MROW + 1
        WRITE(6,'(3(1X,I6),3X,3(1X,I6))')
     +       J   ,(IBTAB(INDFPD,K,J   ), K=1,2),
     +       J+J2,(IBTAB(INDFPD,K,J+J2), K=1,2)
      ENDIF
      CALL WDROP(IW,INDFPD)
      RETURN
*     Error condition...
 900  CONTINUE
      WRITE(6,*) ' FPFPUX >> Error in Work Bank Creation'
      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.25.54  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZU:  2.05/01 21/06/91  14.44.46  by  Girish D. Patel
*-- Author :    Girish D. Patel   25/04/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FRHC.DDL.html">FRHC</A>
*  (Radial Hit multiplicity) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FRHC bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FRHC bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFRHC
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.  FRHC hit multiplicity/pointer 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/
*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,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.

      NBN = 0
      IND = NLINK('FRHC',NBN)
      IF(IND.EQ.0) THEN
        WRITE(6,*) ' FPFRHC>> FRHC Bank not found in event ',NEVENT
        RETURN
      ENDIF
      NROW = IW(IND+2)
      WRITE(6,'(''  '')')
      WRITE(6,'(/,8X,'' -------  FRHC BANK:  Event'',I10,
     +          2X,I4,'' Hits ---------'')')
     +      NEVENT,NROW

      WRITE(6, '(1x,''No '',24I3)') (K,K=0,23)

      IPLANE = 0
      DO 2 I = 0, 2
        WRITE(6,*) ' '
      DO 1 J = 1, 12
        IPLANE = IPLANE + 1
        WRITE(6,'(1X,25I3)') IPLANE,
     &  (IBTAB(IND,1,I*12*24 + J + K*12),K=0,23)

 1    CONTINUE
 2    CONTINUE
      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.27.10  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.19  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.34  by  Stephen Burke
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FRLC.DDL.html">FRLC</A>
*  (Radial Local Co-ordinates) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FRLC bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FRLC bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFRLC
**: FPFRLC 30907 RP. Farm changes.
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.  FRLC local coordinate bank.        *
*     +  cartesian coordinates a la FRCART.                 *
*-----------------------------------------------------------*
*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.
      COMMON /FPF7WW/ INDFRX
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

      NBN = 0
      IND = NLINK('FRLC',NBN)
      IF(IND.EQ.0) THEN
        WRITE(6,*) ' FPFRLC>> FRLC Bank not found in event ',NEVENT
        RETURN
      ENDIF
      NROW = IW(IND+2)
      WRITE(6,'(''  '')')
      WRITE(6,'(/,8X,'' -------  FRLC BANK:  Event'',I10,
     +          2X,I4,'' Hits ---------'')')
     +      NEVENT,NROW

      IF(NROW .GT.0) THEN

      NBN = 0
      INDE = NLINK('FRUX',NBN)
      INDFRX = 0
      IF(INDE .NE. 0) THEN
         CALL BKTOW(IW,'FRUX',NBN,IW,INDFRX,*900)
      ELSE
         WRITE(6,'('' FPFRLC Error ... Hits but no FRUX bank!'')')
      ENDIF

      WRITE(6, '(
     +      '' Row Cel Pln   Drf  Edrf  Rad Erad Sr'',
     +          ''     x+     y+     x-     y-      z Sg'')')

      DO 1 J= 1,NROW
*       Calculate cartesisan coordinates of the hit (both solutions)
        CALL FRCART(J,XXP,YYP,XXM,YYM,ZZ,IBAD)
*       Sign of hit from FRUX bank
        IF(INDFRX .NE. 0) THEN
          IUSED = IBTAB(INDFRX,1,J)
          IF(IUSED .NE. 0) THEN
            ISIGN = IBTAB(INDFRX,2,J)
          ELSE
            ISIGN = -1
          ENDIF
        ELSE
          ISIGN = -1
        ENDIF

        WRITE(6,'(I4,I5,I4,2(F6.3),2(F5.1),I3,5(1X,F6.2), I3)')
     +                J, IBTAB(IND,1,J),
     +                   IRIOSW(IBTAB(IND,1,J)),
     +                  (RBTAB(IND,K,J), K=2,5),
     +                   IBTAB(IND,6,J),
     +                   XXP, YYP, XXM, YYM, ZZ, ISIGN
 1    CONTINUE

      ENDIF
 900  CONTINUE
      CALL WDROP(IW,INDFRX)
      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.28.04  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.20  by  Stephen Burke
*CMZ :  2.05/07 18/07/91  13.19.16  by  Gregorio Bernardi
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FRUX.DDL.html">FRUX</A>
*  (Radial track hit-list) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FRUX bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FRUX bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFRUX
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.                                     *
*-----------------------------------------------------------*
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
      COMMON /FPFRWW/ INDFRD
*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.
*     pointer list...
      NBN  = 0
      IND  = NLINK('FRUX',NBN)
      IF (IND .EQ. 0) THEN
        WRITE(6,*) ' FPFRUX>> FRUX Bank not found in event ',NEVENT
        RETURN
      ENDIF
      INDFRD=0
      CALL BKTOW(IW,'FRUX',NBN,IW,INDFRD,*900)
      NROW = IW(INDFRD+2)
      WRITE(6,'('' '')')
      WRITE(6,'(/,10X,'' ------  FRUX BANK:  Event'',I10,
     +          3X,I4,'' hits -------'')')
     +      NEVENT,NROW
      WRITE(6,  '(''    Hit   Next    Sgn'',
     +    ''    '',''   Hit   Next    Sgn'',
     +    ''    '',''   Hit   Next    Sgn'')')
      MROW = NROW/3
      KMORE= NROW-3*MROW
      J2   = MROW
      IF(KMORE.NE.0) J2 = J2 + 1
      J3   = MROW*2 + KMORE
      IF(MROW.GT.0) THEN
      DO 4 J= 1,MROW
        WRITE(6,'( 3(1X,I6),3X,3(1X,I6),3X,3(1X,I6) )')
     +       J   ,(IBTAB(INDFRD,K,J   ), K=1,2),
     +       J+J2,(IBTAB(INDFRD,K,J+J2), K=1,2),
     +       J+J3,(IBTAB(INDFRD,K,J+J3), K=1,2)
 4    CONTINUE
      ENDIF
      IF(KMORE.EQ.1) THEN
        J= MROW + 1
        WRITE(6,'( 3(1X,I6) )')
     +       J   ,(IBTAB(INDFRD,K,J   ), K=1,2)
      ENDIF
      IF(KMORE.EQ.2) THEN
        J= MROW + 1
        WRITE(6,'(3(1X,I6),3X,3(1X,I6))')
     +       J   ,(IBTAB(INDFRD,K,J   ), K=1,2),
     +       J+J2,(IBTAB(INDFRD,K,J+J2), K=1,2)
      ENDIF
      CALL WDROP(IW,INDFRD)
      RETURN
*     Error condition...
 900  CONTINUE
      WRITE(6,*) ' FPFRUX >> Error in Work Bank Creation'
      RETURN
      END
*CMZU:  8.05/03 17/09/96  14.33.42  by  Girish D. Patel
*CMZ :  8.04/00 27/06/96  20.28.20  by  Stephen Burke
*CMZU:  2.05/01 21/06/91  14.50.52  by  Girish D. Patel
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Print the contents of the <A HREF="FTUR.DDL.html">FTUR</A>
*  (FT Pattern recognition output) bank in a readable format.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No arguments passed. Accesses the FTUR bank via BOS
*
*HTMLO     : Describe the Output of the routine
*
*  Contents of the FTUR bank printed on unit 6
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPFTUR
*-----------------------------------------------------------*
*     Print output banks from Forward Pattern recognition   *
*     in readable form.                                     *
*-----------------------------------------------------------*
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.
*     Diagnostic flag from FRCS BANK
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEND.
      DIMENSION COV(5,5)
*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.
*     FTUR bank...
      NBN = 0
      IND = NLINK('FTUR',NBN)
      IF(IND.EQ.0) THEN
        WRITE(6,*) ' FPFTUR>> FTUR Bank not found in event ',NEVENT
        RETURN
      ENDIF
      NROW = IW(IND+2)
      WRITE(6,'(''  '')')
      WRITE(6,'(/,8X,'' -------  FTUR BANK:  Event'',I10,
     +          2X,I4,'' tracks -------'')')
     +      NEVENT,NROW
      WRITE(6,'(10X,'' Level zero track fits'')')
      WRITE(6, '(
     +      ''Trk      Cu     Phi   Theta'',
     +          ''       x       y       z'',
     +          '' Ndf  Chsq FPUR'')')
      DO 1 J= 1,NROW
        WRITE(6,'(I3,6(1X,F7.3),I4,F6.3,I5)')
     +                J,(RBTAB(IND,K,J), K=1,6),IBTAB(IND,17,J),
     +                   RBTAB(IND,18,J),IBTAB(IND,21,J)
 1    CONTINUE
      IF(IDIAG.GE.2) THEN
      DO 2 J=1,NROW
*     Track 4-momentum...
        CURV =  RBTAB(IND,1,J)
        PHI  =  RBTAB(IND,2,J)
        THET =  RBTAB(IND,3,J)
        IF(ABS(CURV) .GT. 0.0) THEN
           PTMEAS = ABS(0.0002998*12.0/CURV)
           PMEAS  = PTMEAS/SIN(THET)
           PXMEAS = PTMEAS * COS(PHI)
           PYMEAS = PTMEAS * SIN(PHI)
           PZMEAS = PMEAS / TAN(THET)
           WRITE(6,'(/,''   Momentum of Track '',I4,
     +                 '' for 12 kG field'')') J
           WRITE(6, '(''        Px        Py        Pz         P'',
     +               /, 4E10.3)') PXMEAS, PYMEAS, PZMEAS, PMEAS
        ELSE
           WRITE(6,'(/,''      Momentum of Track '',I4)') J
           WRITE(6, '('' ... is infinite'')')
        ENDIF

*     Decompress covariance matrix
        CALL COVCP(5,COV,RW(INDCR(IND,8,J)),1)
        WRITE(6,'(/,''      Covariance Matrix for Track '',I4)') J
        WRITE(6, '(''        Cu       Phi     Theta'',
     +             ''         x         y'',/,
     +    (5E10.3) )' )
     +                 COV
 2    CONTINUE
      ENDIF
      RETURN
      END
*CMZ :  8.05/03 09/10/96  17.57.18  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.20  by  Stephen Burke
*CMZU:  3.09/01 06/04/93  14.55.02  by  Stephen J. Maxfield
*-- Author :    Stephen J. Maxfield   27/02/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Fill some LOOK histograms for monitoring of Forward Tracker
*  Pattern Recognition.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FILHIS
**-------------------------------------------------------------
*
*     Fill some LOOK histograms for monitoring
*     Forward Tracker Pattern Recognition.
*
*--------------------------------------------------------------
*
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEND.
      COMMON /WWFPTH/ INDPUR, INDTUR, INDRUX, INDPUX, INDRRX, INDRPX

*------statement functions for table access--------------------------
*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.
*
*
*
*-----------------------------------------------------------------
*       Fill Histograms.
*

*     Zero all Work Bank Indices...
      INDPUR = 0
      INDTUR = 0
      INDRUX = 0
      INDPUX = 0
*
*      'Pointering' bank FPUR...
        NBN = 0
        IND = NLINK('FPUR',NBN)
        IF (IND .EQ. 0) THEN
          RETURN
        ENDIF
        CALL BKTOW(IW,'FPUR',NBN,IW,INDPUR,*900)
        NTRK = IW(INDPUR+2)
*
*       Number of tracks found...
        CALL SHS(101, 0, FLOAT(NTRK))
*
*
*
*       Level '0' track parameters...
        NBN = 0
        INDTUR = NLINK('FTUR',NBN)
        IF (INDTUR .EQ. 0) THEN
          GO TO 900
        ENDIF
*
*       List of radial hits...
        NBN = 0
        IND = NLINK('FRUX',NBN)
        IF (IND .EQ. 0) THEN
          GO TO 900
        ENDIF
        CALL BKTOW(IW,'FRUX',NBN,IW,INDRUX,*900)
*
*       List of planar hits...
        NBN = 0
        IND = NLINK('FPUX',NBN)
        IF (IND .EQ. 0) THEN
          GO TO 900
        ENDIF
        CALL BKTOW(IW,'FPUX',NBN,IW,INDPUX,*900)
*
*       Radial hit data (drifts etc.)...
        INDRLC = NLINK('FRLC',NBN)
        IF (INDRLC .EQ. 0) THEN
          GO TO 900
        ENDIF
*
*       Planar hit data (drifts etc.)...
        INDPLC = NLINK('FPLC',NBN)
        IF (INDPLC .EQ. 0) THEN
          GO TO 900
        ENDIF
*
*       Loop over pattern recognised tracks
        NPRFND = 0
        DO 1 JTRK = 1, NTRK
*
          CURV   =   RBTAB(INDTUR, 1, JTRK )
          PHI    =   RBTAB(INDTUR, 2, JTRK )
          THETA  =   RBTAB(INDTUR, 3, JTRK )
*
          IF(ABS(CURV) .GT. 0.) THEN
           PTMEAS = ABS(0.0002998*12.0/CURV)
           PMEAS  = PTMEAS/ABS(SIN(THETA))
          ELSE
           PTMEAS = 0.0
           PMEAS = 0.0
          ENDIF

          CALL SHS(102, 0, PHI  )
          CALL SHS(103, 0, THETA)
          CALL SHS(104, 0, PMEAS)

          IF (PMEAS .GT. 0.0) THEN
            CALL SHS(105, 0, 1./PMEAS)
            CALL SHS(106, 0, LOG(1./PMEAS))
          ENDIF
*
          NHITSR =   IBTAB(INDPUR, 1, JTRK )
          IPFRUX =   IBTAB(INDPUR, 2, JTRK )
          NHITSP =   IBTAB(INDPUR, 3, JTRK )
          IPFPUX =   IBTAB(INDPUR, 4, JTRK )
*
*         Get hit data for each radial hit on the track...
          IPNEXT = IPFRUX
          DO 6  KHIT = 1, NHITSR
*           Drift from FRLC bank...
            DRIFT =  RBTAB(INDRLC, 2, IPNEXT)
            RADIUS=  RBTAB(INDRLC, 4, IPNEXT)
            CALL SHS( 110,0, DRIFT)
            CALL SHS( 111,0, RADIUS)
            CALL SHD( 112,0, DRIFT, RADIUS)
            IPNEXT = IBTAB(INDRUX,1,IPNEXT)
 6        CONTINUE
*         Get hit data for each planar hit on the track...
          IPNEXT = IPFPUX
          DO 7  KHIT = 1, NHITSP
*           Drift from FPLC bank...
            DRIFT =  RBTAB(INDPLC, 2, IPNEXT)
            CALL SHS( 113,0, DRIFT)
            IPNEXT = IBTAB(INDPUX,1,IPNEXT)
 7        CONTINUE
*                  ...Monte Carlo
*
 1      CONTINUE
*               ...Loop over tracks
*
*----------- Done ----------------------------------------
*     Drop all Work banks (unused ones should have index 0 so O.K.)
 900  CONTINUE
      CALL WDROP(IW,INDPUR)
      CALL WDROP(IW,INDRUX)
      CALL WDROP(IW,INDPUX)
*
      RETURN
      END
*CMZ :  8.07/00 20/11/96  21.33.02  by  Stephen Burke
*CMZ :  8.05/03 09/10/96  17.57.18  by  Stephen Burke
*CMZ :  8.05/00 11/09/96  11.58.20  by  Stephen Burke
*CMZ :  8.04/00 30/07/96  20.49.29  by  Stephen Burke
*CMZU:  7.03/08 13/12/95  22.56.44  by  Stephen Burke
*CMZU:  7.02/11 31/10/95  22.02.35  by  Stephen Burke
*CMZU:  7.02/00 24/08/95  17.15.04  by  Stephen Burke
*CMZU:  7.00/04 24/04/95  17.18.21  by  Stephen Burke
*CMZU:  5.03/00 03/05/94  15.52.15  by  Stephen J. Maxfield
*CMZU:  4.00/08 21/10/93  17.00.28  by  Stephen J. Maxfield
*CMZ :  4.00/00 07/09/93  17.58.02  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.34  by  Stephen Burke
*-- Author : S.J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Book LOOK histograms for monitoring of Forward Tracker
*  Pattern Recognition.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPTHIS
**: FPTHIS 40000 SM. New monitoring/debug histos.
*-----------------------------------------------------------*
**: FPTHIS 30907 RP. Farm changes.
*-----------------------------------------------------------*
**: FPTHIS 30907 SM. Yet mor changes to histograms.
**----------------------------------------------------------------------
**: FPTHIS 30207 GB. comment lines moved inside the routine
**: FPTHIS 30205 SM. Numerous changes to histograms
**-------------------------------------------------------------
*
*     Book and Fill LOOK histograms for monitoring
*     Forward Tracker Pattern Recognition.
*
*     Booking and filling is controlled by word 4 in the
*     steering bank FRCS. (IDOHIS in COMMON FDIFLG)
*
*--------------------------------------------------------------
*
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FDIFLG.
      COMMON/LDIAG/IDIAG,IDIAG2,MAXPRT,IDOHIS,PMCUT
*KEEP,FPTFLG.
      COMMON/FPTFLG/IPLAR, NIT, IREZ, LUNFP, NPLMAX
*KEND.

      LOGICAL FIRST
      DATA FIRST /.TRUE./
*------statement functions for table access--------------------------
*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(FIRST) THEN
        FIRST = .FALSE.

*       Book  LOOK Histograms For Pattern recognition
*       I. AREAs 1 and 2.
*
*
        CALL SAREA('FTREC',1)
*
*       Book all the time - used in endjob stats...
        CALL BHS(   108,0,60,0.0,6.0)
        CALL STEXT( 108,1,'Radial drifts from FRLOCO')
        CALL BHS(   109,0,60,-2.0,4.0)
        CALL STEXT( 109,1,'Planar drifts from FPLOCO')
*
        CALL BHS(   610,0,100,-1000.,6000.)
        CALL STEXT( 610,1,'Rad: raw drift times')
        CALL BHS(   612,0,100,-1000.,6000.)
        CALL STEXT( 612,1,'Pla: raw drift times')
        CALL BHS(   616,0,100,-1000.,6000.)
        CALL STEXT( 616,1,'Pla: raw drift times (2000 plus)')

        CALL BHS(   650,0,100,1000.,3000.)
        CALL STEXT( 650,1,'Pla: avg drift times')
        CALL BHS(   651,0,100,1000.,3000.)
        CALL STEXT( 651,1,'Pla: avg drift times (0 to 500)')
        CALL BHS(   652,0,100,1000.,3000.)
        CALL STEXT( 652,1,'Pla: avg drift times (500 to 2000')
        CALL BHS(   653,0,100,1000.,3000.)
        CALL STEXT( 653,1,'Pla: avg drift times (2000 plus)')
        CALL BHS(   654,0,100,500.,2500.)
        CALL STEXT( 654,1,'T0: FT - CT')
        CALL BHS(   655,0,100,500.,2500.)
        CALL STEXT( 655,1,'T0: FT - CT (0 to 500)')
        CALL BHS(   656,0,100,500.,2500.)
        CALL STEXT( 656,1,'T0: FT - CT (500 to 2000')
        CALL BHS(   657,0,100,500.,2500.)
        CALL STEXT( 657,1,'T0: FT - CT (2000 plus)')
        CALL BHD(   658,0,50,1000.,3000.,50,0.,2000.)
        CALL STEXT( 658,1,'T0: FT vs CT (500 to 2000)')
        CALL BHD(   659,0,50,1000.,3000.,50,0.,2000.)
        CALL STEXT( 659,1,'T0: FT vs CT (2000 plus)')
*
        CALL BHS(   200,0,20, 0.,20.)
        CALL STEXT( 200,1,'Num hits on radial segments')
        CALL BHS(   201,0,20, 0.,20.)
        CALL STEXT( 201,1,'Num hits on radial segments SM0')
        CALL BHS(   202,0,20, 0.,20.)
        CALL STEXT( 202,1,'Num hits on radial segments SM1')
        CALL BHS(   203,0,20, 0.,20.)
        CALL STEXT( 203,1,'Num hits on radial segments SM2')

C+SELF,IF=FTTIME.
          CALL BHS( 224,0,100,0.0,5.0)
          CALL STEXT( 224,1,'Total time in FTREC')
          CALL BHS( 225,0,100,0.0,5.0)
          CALL STEXT( 225,1,'Time in FPSEG')
          CALL BHD( 226,0,40,0.0,4000.0,50,0.0,5.0)
          CALL STEXT( 226,1,'Total time vs total num hits')
          CALL BHD( 227,0,40,0.0,2000.0,50,0.0,5.0)
          CALL STEXT( 227,1,'Time in FPSEG vs num pla hits')
          CALL BHD( 228,0,40,0.0,2000.0,50,0.0,1.0)
          CALL STEXT( 228,1,'Time FPSEG vs num pla hits(exp)')
          CALL BHD( 229,0,50,0.0,5.0,50,0.0,5.0)
          CALL STEXT( 229,1,'Total time vs time in FPSEG')
          CALL BHS( 230,0,100,0.0,2000.0)
          CALL STEXT( 230,1,'Num pla hits / event')
          CALL BHS( 231,0,100,0.0,2000.0)
          CALL STEXT( 231,1,'Num rad hits / event')
          CALL BHS( 232,0,100,0.0,4000.0)
          CALL STEXT( 232,1,'Tot num hits / event')
C+SELF.

        CALL BHS(   320,0,20, 0.,20.)
        CALL STEXT( 320,1,'Num hits on planar segments')
        CALL BHS(   321,0,20, 0.,20.)
        CALL STEXT( 321,1,'Num hits on planar segments SM0')
        CALL BHS(   322,0,20, 0.,20.)
        CALL STEXT( 322,1,'Num hits on planar segments SM1')
        CALL BHS(   323,0,20, 0.,20.)
        CALL STEXT( 323,1,'Num hits on planar segments SM2')


        IF(IDOHIS.GE.1) THEN
*            Basic set if IDOHIS >=1...
*       Histograms  101 - 106 are filled in this routine FPTHIS.
          CALL BHS( 101,0,50,0.0,50.0)
          CALL STEXT( 101,1,'Number of Pattern-recognised tracks)')
*
          CALL BHS( 102,0,80,-3.2, 3.2)
          CALL STEXT( 102,1,'Phi of Pattern-recognised tracks)')
*
          CALL BHS( 103,0,60,0.0,0.6)
          CALL STEXT( 103,1,'Theta of Pattern-recognised tracks)')
*
          CALL BHS( 104,0,60,0.0,100.0)
          CALL STEXT( 104,1,'Momentum of Pattern-recognised tracks)')
*
          CALL BHS( 105,0,60,0.,10.0)
          CALL STEXT( 105,1,'1/Momentum of Pattern-recognised tracks')
*
          CALL BHS( 106,0,50,-6.0,4.0)
          CALL STEXT( 106,1,'LN(1/Mom) of Pattern-recognised tracks')
*
*
          CALL BHS( 115,0,80,0.0,80.)
          CALL STEXT( 115,1,'Radius in radials from FRLOCO')
          CALL BHS( 114,0,10,-0.5,9.5)
          CALL STEXT( 114,1,'Bad hit flag from FRLOCO')
*
*       Histograms  110 - 113 are filled in this routine FPTHIS.
          CALL BHS( 110,0,60,0.0,6.0)
          CALL STEXT( 110,1,'Drift in radials for track hits')
*
          CALL BHS( 111,0,80,0.0,80.)
          CALL STEXT( 111,1,'Radius in radials for track hits')
*
          CALL BHD( 112,0,60,0.0,6.0,80,0.0,80.0)
          CALL STEXT( 112,1,'Radial wedge plot for track hits')

          CALL BHS( 113,0,60,0.0,6.0)
          CALL STEXT( 113,1,'Drift in planars for track hits')

          IF(IREZ.GT.0) THEN
*        Histograms 209, 233 -242 are filled in FPTREZ...
            CALL BHS( 209,0,40, 0.,40.)
            CALL STEXT( 209,1,'Wire number of missing radial hits')
            CALL BHS( 233,0,60,-0.15,0.15)
            CALL STEXT( 233,1,'Rad seg drift residuals in SM0')
            CALL BHS( 234,0,60,-0.15,0.15)
            CALL STEXT( 234,1,'Rad seg drift residuals in SM1')
            CALL BHS( 235,0,60,-0.15,0.15)
            CALL STEXT( 235,1,'Rad seg drift residuals in SM2')
            CALL BHS( 236,0,60,-0.15,0.15)
            CALL STEXT( 236,1,'Rad seg drift residuals in SM0+SM1+SM2')

            CALL BHS( 237,0,50,-15.0,15.0)
            CALL STEXT( 237,1,'Rad seg rad   residuals in SM0')
            CALL BHS( 238,0,50,-15.0,15.0)
            CALL STEXT( 238,1,'Rad seg rad   residuals in SM1')
            CALL BHS( 239,0,50,-15.0,15.0)
            CALL STEXT( 239,1,'Rad seg rad   residuals in SM2')
            CALL BHS( 240,0,50,-15.0,15.0)
            CALL STEXT( 240,1,'Rad seg rad   residuals in SM0+SM1+SM2')
            CALL BHS( 241,0,50,0.0,10.0)
            CALL STEXT( 241,1,'Rad seg chi-squared in SM0+SM1+SM2')

            CALL BHD( 250,0,50,0.0,80.0,50,-15.,15.)
            CALL STEXT( 250,1,'Rad seg rad res vs. Rmeas')

            CALL BHD( 242,0,60,0.0,6.0,60,-0.15,0.15 )
            CALL STEXT( 242,1,'Rad seg res vs. drift in SM0+SM1+SM2')

*       Histograms  243 -249 263-264  are filled in FPREZI...
            CALL BHS( 243,0,60,-0.15,0.15)
            CALL STEXT( 243,1,'Pla seg drift residuals for ORI 0')
            CALL BHS( 244,0,60,-0.15,0.15)
            CALL STEXT( 244,1,'Pla seg drift residuals for ORI 1')
            CALL BHS( 245,0,60,-0.15,0.15)
            CALL STEXT( 245,1,'Pla seg drift residuals for ORI 2')
            CALL BHS( 246,0,60,-0.15,0.15)
            CALL STEXT( 246,1,'Pla seg drift residuals for ORI 0+1+2')
            CALL BHD( 247,0,60,0.0,6.0,60,-0.15,0.15 )
            CALL STEXT( 247,1,'Pla seg res vs. drift in ORI 0+1+2')
            CALL BHS( 248,0,20, 0., 20.)
            CALL STEXT( 248,1,'Num hits on planar segments')
            CALL BHS( 249,0,50, 0., 1.)
            CALL STEXT( 249,1,'Prob Chisq planar segments')
            CALL BHS( 263,0,40, 0.,40.)
            CALL STEXT( 263,1,'Wire number of missing planar hits')
            CALL BHD( 264,0,40, 0.,40.,26,-74.1,74.1)
            CALL STEXT( 264,1,'W vs wire of missing planar hits')
          ENDIF
          IF(IREZ.GE.2) THEN
*       Histograms  116- 119 are filled in FPTREZ...
            CALL BHS( 116,0,50,-5.0,5.0)
            CALL STEXT( 116,1,'R0 res/150mic of nearest hits')
*
            CALL BHS( 117,0,50,-5.0,5.0)
            CALL STEXT( 117,1,'R1 res/150mic of nearest hits')
*
            CALL BHS( 118,0,50,-5.0,5.0)
            CALL STEXT( 118,1,'R2 res/150mic of nearest hits')
*
            CALL BHS( 119,0,50,-5.0,5.0)
            CALL STEXT( 119,1,'R012 res/150mic of nearest hits')
*
*       Histograms  120- 123 are filled in FPLPK1...
            CALL BHS( 120,0,50,-10.0,10.0)
            CALL STEXT( 120,1,'P0 res/150mic of nearest hits')
            CALL BHS( 121,0,50,-10.0,10.0)
            CALL STEXT( 121,1,'P1 res/150mic of nearest hits')
            CALL BHS( 122,0,50,-10.0,10.0)
            CALL STEXT( 122,1,'P2 res/150mic of nearest hits')
            CALL BHS( 123,0,50,-10.0,10.0)
            CALL STEXT( 123,1,'P012 res/150mic of nearest hits')
          ENDIF

        ENDIF
*            ...IDOHIS > 1

        IF(IDOHIS.GE.2) THEN

*       Histograms 215 - 223 filled in FPLPKS.

          CALL BHS( 210,0,100,0.,50.)
          CALL STEXT( 210,1,'Min DrPhi accepted r-p match')
          CALL BHS( 211,0,100,0.,50.)
          CALL STEXT( 211,1,'Dr for    accepted r-p match')
          CALL BHD( 212,0,100,0.,50.,100, 0.,50.)
          CALL STEXT( 212,1,'Dr vs DrPhi accepted r-p match')

          CALL BHS( 215,0,100,0.,100.)
          CALL STEXT( 215,1,'Min DrPhi Pla-rad match mm IT=1')
          CALL BHS( 216,0,100,0.,100.)
          CALL STEXT( 216,1,'Min DrPhi Pla-rad match mm IT=2')
          CALL BHS( 217,0,100,0.,100.)
          CALL STEXT( 217,1,'Min DrPhi Pla-rad match mm IT=3')

          CALL BHS( 218,0,100,0.,100.)
          CALL STEXT( 218,1,'Dr for min Pla-rad match mm IT=1')
          CALL BHS( 219,0,100,0.,100.)
          CALL STEXT( 219,1,'Dr for min Pla-rad match mm IT=2')
          CALL BHS( 220,0,100,0.,100.)
          CALL STEXT( 220,1,'Dr for min Pla-rad match mm IT=3')

          CALL BHS( 204,0,60, 0.,60.)
          CALL STEXT( 204,1,'Num radial segments in SM0')
          CALL BHS( 205,0,60, 0.,60.)
          CALL STEXT( 205,1,'Num radial segments in SM1')
          CALL BHS( 206,0,60, 0.,60.)
          CALL STEXT( 206,1,'Num radial segments in SM2')
          CALL BHS( 207,0,60, 0.,150.)
          CALL STEXT( 207,1,'Num radial segments in SM0+1+2')
          CALL BHS( 260,0,50,0.0,1.0)
          CALL STEXT( 260,1,'Frac radial hits attached to segments')

          CALL BHS( 221,0,60,0.,60.)
          CALL STEXT( 221,1,'Num planar segments in Mod 0 ')
          CALL BHS( 222,0,60,0.,60.)
          CALL STEXT( 222,1,'Num planar segments in Mod 1 ')
          CALL BHS( 223,0,60,0.,60.)
          CALL STEXT( 223,1,'Num planar segments in Mod 2 ')
          CALL BHS( 261,0,60,0.,60.)
          CALL STEXT( 261,1,'Num planar segments in Mod 0+1+2 ')

          CALL BHS( 262,0,50,0.0,1.0)
          CALL STEXT( 262,1,'Frac planar hits attached to segments')

          CALL BHS( 251, 0,100,0.0,10000.)
          CALL BHS( 251, 1,100,0.0,10000.)
          CALL BHS( 251, 2,100,0.0,10000.)
          CALL BHS( 251, 3,100,0.0,10000.)
          CALL BHS( 251, 4,100,0.0,10000.)
          CALL BHS( 251, 5,100,0.0,10000.)
          CALL BHS( 251, 6,100,0.0,10000.)
          CALL BHS( 251, 7,100,0.0,10000.)
          CALL BHS( 251, 8,100,0.0,10000.)
          CALL BHS( 251, 9,100,0.0,10000.)
          CALL BHS( 251,10,100,0.0,10000.)
          CALL BHS( 251,11,100,0.0,10000.)
          CALL BHS( 251,12,100,0.0,10000.)
          CALL STEXT( 251,1,'Chg sum hits on rad segments')
          CALL BHD( 252,0,100,0.0,10000.,15,0.,15.)
          CALL STEXT( 252,1,'Radial Chg vs wire number')

          CALL BHS( 253,0,100,0.0,10000.)
          CALL STEXT( 253,1,'Chg hits on pla segments - outer')
          CALL BHD( 254,0,100,0.0,10000.,15,0.,15.)
          CALL STEXT( 254,1,'Planar Chg vs wire number - outer')
          CALL BHS( 255,0,100,0.0,10000.)
          CALL STEXT( 255,1,'Chg hits on pla segments - inner')
          CALL BHD( 256,0,100,0.0,10000.,15,0.,15.)
          CALL STEXT( 256,1,'Planar Chg vs wire number - inner')

          CALL BHS( 257,0,100,0.0,10000.)
          CALL STEXT( 257,1,'Chg sum hits in radials')


          CALL BHS( 300,0,50,-20.,20.)
          CALL STEXT( 300,1,'Rrad-Rpred all')
          CALL BHD( 301,0, 80,10.0,90.0,50,-20.,20.)
          CALL STEXT( 301,1,'Rrad-Rpred  vs. Rpred all')
          CALL BHD( 302,0,80, 10., 90., 80, 10., 90.0)
          CALL STEXT( 302,1,'Rrad vs. Rpred all')

          CALL BHS( 303,0,50,-20.,20.)
          CALL STEXT( 303,1,'Rrad-Rpred  long projection')
          CALL BHD( 304,0, 80,10.0,90.0,50,-20.,20.)
          CALL STEXT( 304,1,'Rrad-Rpred  vs. Rpred long projection')
          CALL BHD( 305,0,80, 10., 90., 80, 10., 90.0)
          CALL STEXT( 305,1,'Rrad vs. Rpred long projection')

          CALL BHS( 306,0,50,-20.,20.)
          CALL STEXT( 306,1,'Rrad-Rpred  shrt projection')
          CALL BHD( 307,0, 80,10.0,90.0,50,-20.,20.)
          CALL STEXT( 307,1,'Rrad-Rpred  vs. Rpred shrt projection')
          CALL BHD( 308,0,80, 10., 90., 80, 10., 90.0)
          CALL STEXT( 308,1,'Rrad vs. Rpred shrt projection')

          CALL BHS( 310,0,50,-10.,10.)
          CALL STEXT( 310,1,'Del drift   all')
          CALL BHD( 311,0,80,-10., 10.,80, -10.,10.)
          CALL STEXT( 311,1,'Drad v Dpred al')

          CALL BHS( 312,0,50,-10.,10.)
          CALL STEXT( 312,1,'Drad - Dpred long projection')
          CALL BHD( 313,0,80,-10., 10.,80,-10.,10.)
          CALL STEXT( 313,1,'Drad v Dpred long projection')

          CALL BHS( 314,0,50,-10.,10.)
          CALL STEXT( 314,1,'Drad - Dpred shrt projection')
          CALL BHD( 315,0,80,-10., 10.,80, -10.,10.)
          CALL STEXT( 315,1,'Drad v Dpred shrt projection')

          CALL BHS( 316,0,50,-10.,10.)
          CALL STEXT( 316,1,'Drad - Dpred all: Dpred < 0')
          CALL BHS( 317,0,50,-10.,10.)
          CALL STEXT( 317,1,'Drad - Dpred all: Dpred > 0')
        ENDIF
* ...........IDOHIS GE 2.


*------------------------------------------------------
*       Book More  Histograms...

*       Now book additional histograms in area 2:-
        CALL SAREA('FTREC',2)
*       This set previously booked locally in FPLPKP...
        CALL STEXT(500,4,' CHI LINK 123 ALL')
        CALL BHS(500,0,50,0.0,10.0)
        CALL STEXT(501,4,' CHI LINK 123')
        CALL BHS(501,0,50,0.0,10.0)
        CALL STEXT(510,4,' CHI LINK 12 PHI')
        CALL BHS(510,0,50,0.0,10.0)
        CALL STEXT(511,4,' CHI LINK 12 STR LINE XZ YZ')
        CALL BHS(511,0,50,0.0,10.0)
        CALL STEXT(520,4,' CHI LINK 23')
        CALL BHS(520,0,50,0.0,10.0)
        CALL STEXT(530,4,' CHI LINK 13')
        CALL BHS(530,0,50,0.0,10.0)

        CALL STEXT(550,4,' # LINKS 123,12,23,13 TOT ')
        CALL BHS(550,0,50,0.0,50.0)
        CALL STEXT(560,4,' # PLANAR TRACKS/EVENT           ')
        CALL BHS(560,0,50,0.0,50.0)

        CALL STEXT(571,4,' CHI DRIFT  LINK 123 ALL')
        CALL BHS(571,0,50,0.0,50.0)
        CALL STEXT(572,4,' CHI DRIFT  LINK 12 ALL')
        CALL BHS(572,0,50,0.0,50.0)
        CALL STEXT(573,4,' CHI DRIFT  LINK 23 ALL')
        CALL BHS(573,0,50,0.0,50.0)
        CALL STEXT(574,4,' CHI DRIFT  LINK 13 ALL')
        CALL BHS(574,0,50,0.0,50.0)

        CALL STEXT(575,4,' CHI DRIFT  LINK 123 SEL')
        CALL BHS(575,0,50,0.0, 1.0)
        CALL STEXT(576,4,' CHI DRIFT  LINK 12 SEL')
        CALL BHS(576,0,50,0.0, 1.0)
        CALL STEXT(577,4,' CHI DRIFT  LINK 23 SEL')
        CALL BHS(577,0,50,0.0, 1.0)
        CALL STEXT(578,4,' CHI DRIFT  LINK 13 SEL')
        CALL BHS(578,0,50,0.0, 1.0)

        CALL STEXT(901,4,' PLANAR (X**2+Y**2)  COMP 12  2 MOD    ')
        CALL BHS(901,0,50,0.0,100.0)
        CALL STEXT(902,4,' PLANAR (X**2+Y**2)  COMP 23  2 MOD    ')
        CALL BHS(902,0,50,0.0,100.0)
        CALL STEXT(903,4,' PLANAR (X**2+Y**2)  COMP 13  2 MOD    ')
        CALL BHS(903,0,50,0.0,100.0)
        CALL STEXT(904,4,' PLANAR (X**2+Y**2)  COMP 12  3MOD JOIN')
        CALL BHS(904,0,50,0.0,100.0)
        CALL STEXT(905,4,' PLANAR (X**2+Y**2)  COMP 23  3MOD JOIN')
        CALL BHS(905,0,50,0.0,100.0)
        CALL STEXT(907,4,' dx  12   3 MOD ')
        CALL BHS(907,0,50,-15.,15.)
        CALL STEXT(908,4,' dy  12   3 MOD ')
        CALL BHS(908,0,50,-20.,20.)
        CALL STEXT(911,4,' PLANAR SQRT(X**2+Y**2)  COMP 12  2 MOD    ')
        CALL BHS(911,0,50,0.0,50.0)
        CALL STEXT(912,4,' PLANAR SQRT(X**2+Y**2)  COMP 23  2 MOD    ')
        CALL BHS(912,0,50,0.0,50.0)
        CALL STEXT(913,4,' PLANAR SQRT(X**2+Y**2)  COMP 13  2 MOD    ')
        CALL BHS(913,0,50,0.0,50.0)
        CALL STEXT(921,4,' PLANAR R1-R2            COMP 12  MID PROJ ')
        CALL BHS(921,0,50,0.0,100.0)
        CALL STEXT(922,4,' PLANAR R3-R2            COMP 23  MID PROJ ')
        CALL BHS(922,0,50,0.0,100.0)
        CALL STEXT(923,4,' PLANAR R3-R1            COMP 13  MID PROJ ')
        CALL BHS(923,0,50,0.0,100.0)

        CALL STEXT(699,4,' P->R LINK MEAS-PRED DRIFT SLOPE ')
        CALL BHS(699,0,50,-0.5,0.5)
        CALL STEXT(700,4,' PLANAR->RADIAL LINK  DRPHI MIN            ')
        CALL BHS(700,0,50,.0,2.0)
        CALL STEXT(701,4,' PLANAR->RADIAL LINK  DR MIN               ')
        CALL BHS(701,0,50,.0,50.0)
        CALL STEXT(702,4,' PLANAR->RADIAL LINK  DRI PRED-MEAS M0     ')
        CALL BHS(702,0,50,-1.0,1.0)
        CALL STEXT(703,4,' PLANAR->RADIAL LINK  DRI PRED-MEAS M1     ')
        CALL BHS(703,0,50,-1.0,1.0)
        CALL STEXT(704,4,' PLANAR->RADIAL LINK  DRI PRED-MEAS M2     ')
        CALL BHS(704,0,50,-1.0,1.0)
        CALL STEXT(705,4,' PLANAR->RADIAL LINK  DRI P-M M0 MIN       ')
        CALL BHS(705,0,50,-1.0,1.0)
        CALL STEXT(706,4,' PLANAR->RADIAL LINK  DRI P-M M1 MIN       ')
        CALL BHS(706,0,50,-1.0,1.0)
        CALL STEXT(707,4,' PLANAR->RADIAL LINK  DRI P-M M2 MIN       ')
        CALL BHS(707,0,50,-1.0,1.0)
        CALL STEXT(708,4,' PL->RAD  LINK  SLOPE DRIFT RESIDUALS')
        CALL BHS(708,0,50,-0.5,0.5)
        CALL STEXT(710,4,' RAD EFCNCY FRM PLANAR PROJ. EXPECTED/OBS ' )
        CALL BHS(710,0,50,0.,50.0)

        CALL STEXT(721,4,' # PLANAR SEGMENTS SM 0 ' )
        CALL BHS(721,0,50,0.,50.0)
        CALL STEXT(722,4,' # PLANAR SEGMENTS SM 1 ' )
        CALL BHS(722,0,50,0.,50.0)
        CALL STEXT(723,4,' # PLANAR SEGMENTS SM 2 ' )
        CALL BHS(723,0,50,0.,50.0)
        CALL STEXT(731,4,' # RADIAL SEGMENTS SM 0 ' )
        CALL BHS(731,0,50,0.,50.0)
        CALL STEXT(732,4,' # RADIAL SEGMENTS SM 1 ' )
        CALL BHS(732,0,50,0.,50.0)
        CALL STEXT(733,4,' # RADIAL SEGMENTS SM 2 ' )
        CALL BHS(733,0,50,0.,50.0)

        CALL STEXT(751,4,' P->R LINK  V-FACTOR FIT M1 SEG  ')
        CALL BHS(751,0,50,.0,2.0)
        CALL STEXT(752,4,' P->R LINK  V-FACTOR FIT M2 SEG  ')
        CALL BHS(752,0,50,.0,2.0)
        CALL STEXT(753,4,' P->R LINK  V-FACTOR FIT M3 SEG  ')
        CALL BHS(753,0,50,.0,2.0)
        CALL STEXT(761,4,' P->R LINK  V-FACTOR FIT M1M2 TRK  ')
        CALL BHS(761,0,50,.0,2.0)
        CALL STEXT(762,4,' P->R LINK  TZ M1M2 TRK          ')
        CALL BHS(762,0,50,-1.0,1.0)

        CALL STEXT(764,4,' # HITS PLANAR LINE SEGMENT      ')
        CALL BHS(764,0,50,.0,25.)
        CALL STEXT(765,4,' # PLANAR SEGMENTS/MODULE        ')
        CALL BHS(765,0,50,.0,25.)
        CALL STEXT(766,4,' PLANAR LINKS 123 12 23 13  USED 1 2 3     ')
        CALL BHS(766,0,50,.0,25.)
*       End FPLPKP set.

*       This set previously booked in FTMERG...
        CALL STEXT(711,4,' #P,#R-Ver,#R-Unver,#R-Shr,#R,#singR,#totR')
        CALL BHS(711,0,50,0.,25.)
        CALL STEXT(712,4,' #PR LINKS;21,32,11,22,33,TOT,RADS/PL SEG')
        CALL BHS(712,0,50,0.,25.)
        CALL STEXT(713,4,' P VER BY RAD;R-P COMMON R,COMMON P    ')
        CALL BHS(713,0,50,0.,25.)
        CALL STEXT(714,4,' SINGLE SEGS  R ; P    UNUSED/TOTAL    ')
        CALL BHS(714,0,50,0.,25.)
        CALL STEXT(715,4,'#R1-R2 TRACKS;#P2,P3 FND . PL EFFICIENCY')
        CALL BHS(715,0,50,0.,25.)
        CALL STEXT(716,4,' #P1P2P3,P1P2,P2P3,P1P3  TOTS  TOT   ')
        CALL BHS(716,0,50,0.,25.)

        CALL STEXT(1630,4,' DRPHI R-P SEL MM ')
        CALL BHS(1630,0,50,0.,20.)
        CALL STEXT(1631,4,' DR    R-P SEL MM')
        CALL BHS(1631,0,50,0.,250.)
        CALL STEXT(1632,4,' EXPT-MEAS DRIFT ')
        CALL BHS(1632,0,50,-5.0,5.0)
        CALL STEXT(1633,4,' SLOPE OF RESID  ')
        CALL BHS(1633,0,50,-0.5,0.5)
        CALL STEXT(1634,4,' EXPT-MEAS LINE SEG. CENTRE ')
        CALL BHS(1634,0,50,-5.0,5.0)
*       End FTMERG set.
*
        CALL SAREA('FTREC',1)
*
      ENDIF
*
*-----------------------------------------------------------------
*
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.26  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKADJ(SSMT,SPRO,QGAIN,SADJ)
**********************************************************************
*                                                                    *
* Adjust a smoothed state vector for multiple scattering             *
*                                                                    *
* Output is SADJ = SSMT + QGAIN.(SPRO - SSMT)                        *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION SSMT(5),SPRO(5),DS(5),QGAIN(5,5),SADJ(5)

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

      CALL FKDIFF(SPRO,SSMT,DS)

      SADJ(1) = SSMT(1) + QGAIN(1,1)*DS(1) + QGAIN(1,2)*DS(2)
     &        + QGAIN(1,3)*DS(3) + QGAIN(1,4)*DS(4) + QGAIN(1,5)*DS(5)

      SADJ(2) = SSMT(2) + QGAIN(2,1)*DS(1) + QGAIN(2,2)*DS(2)
     &        + QGAIN(2,3)*DS(3) + QGAIN(2,4)*DS(4) + QGAIN(2,5)*DS(5)

* QGAIN(3,x) is zero due to zeros in QMS
      SADJ(3) = SSMT(3)

      SADJ(4) = SSMT(4) + QGAIN(4,1)*DS(1) + QGAIN(4,2)*DS(2)
     &        + QGAIN(4,3)*DS(3) + QGAIN(4,4)*DS(4) + QGAIN(4,5)*DS(5)

      SADJ(5) = SSMT(5) + QGAIN(5,1)*DS(1) + QGAIN(5,2)*DS(2)
     &        + QGAIN(5,3)*DS(3) + QGAIN(5,4)*DS(4) + QGAIN(5,5)*DS(5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.28  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      DOUBLE PRECISION FUNCTION FKCHPR(NPROB,NFREE,IERR)
**********************************************************************
*                                                                    *
*  Inverse chi-sq probability                                        *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ; normal termination                             *
*   ->  IERR = 101  ; invalid probability cut                        *
*   ->  IERR = 104  ; invalid value of NPROB or NFREE                *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
* The function returns -1 for error 4, 0 or 10**10 for error 1       *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=9)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEND.

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

      REAL PROB
      DIMENSION PCUT(8),CHISQ(4,2*NPL)
      EQUIVALENCE(PCUT,X2PCUT)

      SAVE CHISQ

      PARAMETER (NDIM=8*NPL)
      DATA CHISQ/NDIM*-1.D0/

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

      IERR = 0

      IF (NPROB.LE.0 .OR. NPROB.GT.4 .OR. NFREE.LE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINV,IERR)
         FKCHPR = -1.D0
         RETURN
      ENDIF

      IF (NFREE.LE.2*NPL .AND. CHISQ(NPROB,NFREE).GE.0.D0) THEN
         FKCHPR = CHISQ(NPROB,NFREE)
         RETURN
      ENDIF

      PROB = 1.D0 - PCUT(NPROB)
      IF (PROB.LT.0.D0 .OR. PROB.GT.1.D0)
     &   CALL FKERR(IUTIL,IROUT,IFATAL,IINF1,IERR)

      IF (PROB.LE.0.D0) THEN
         FKCHPR = 0.D0
      ELSEIF (PROB.GE.1.D0) THEN
         FKCHPR = 1.D10
      ELSE
         FKCHPR = CHISIN(PROB,NFREE)
      ENDIF

      IF (NFREE.LE.2*NPL) CHISQ(NPROB,NFREE) = FKCHPR

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.35  by  Stephen Burke
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      DOUBLE PRECISION FUNCTION FKCHXY(XY,CXY,SVEC,CVEC,IERR)
*-----------------------------------------Updates 27/07/93-------
**: FKCHXY 30907 SB. Function now (correctly) double precision.
**********************************************************************
*                                                                    *
* Calculate (filtered/smoothed) chi-squared for an x-y measurement   *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 112 ; CRES not positive definite                      *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=10)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION XY(2),CXY(2,2),SVEC(5),CVEC(5,5)

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

      IERR=0

* Calculate the residuals and covariance ...
      R1  = XY(1) - SVEC(1)
      R2  = XY(2) - SVEC(2)
      C11 = CXY(1,1) - CVEC(1,1)
      C21 = CXY(2,1) - CVEC(2,1)
      C22 = CXY(2,2) - CVEC(2,2)

* ... and the chi-squared
      DET = C11*C22 - C21*C21
      IF (C11.LE.0.D0 .OR. DET.LE.0.D0) THEN
         FKCHXY = 0.D0
         CALL FKERR(IUTIL,IROUT,IFATAL,IRCV,IERR)
         RETURN
      ENDIF

      FKCHXY = (R1*(C22*R1 - 2*C21*R2) + C11*R2*R2)/DET

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.24  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKCOVP(CPRO,H,GMES,CFIL,WT,IERR)
**********************************************************************
*                                                                    *
* Calculate filtered covariance for a `planar' (i.e. only one        *
* measurement)                                                       *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 111 ; filtered covariance not positive definite       *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=1)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION CPRO(5,5),H(2,2),GMES(2,2),CFIL(5,5),WT(2,5)

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

      IERR = 0

      IF (H(2,1).EQ.1.D0) GOTO 1000
      IF (H(2,2).EQ.1.D0) GOTO 2000

* Rotate the top left corner of CPRO into measurement space ...
      CP11 = (H(1,1)*CPRO(1,1) + 2.*H(1,2)*CPRO(2,1))*H(1,1)
     &                         +    H(1,2)*CPRO(2,2) *H(1,2)
      CP12 = (H(2,1)*CPRO(1,1) + H(2,2)*CPRO(2,1))*H(1,1) +
     &       (H(2,1)*CPRO(2,1) + H(2,2)*CPRO(2,2))*H(1,2)
      CP13 = H(1,1)*CPRO(3,1) + H(1,2)*CPRO(3,2)
      CP14 = H(1,1)*CPRO(4,1) + H(1,2)*CPRO(4,2)
      CP15 = H(1,1)*CPRO(5,1) + H(1,2)*CPRO(5,2)

* Premultiply by GMES, add  the unit matrix and invert - all trivial ...
      DET = GMES(1,1)*CP11 + 1.D0
      IF (DET.LE.0.D0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF
      DET = 1.D0/DET
      GDET = GMES(1,1)*DET

      GCP12 = -CP12*GDET
      GCP13 = -CP13*GDET
      GCP14 = -CP14*GDET
      GCP15 = -CP15*GDET

* ... except for rotating the result back into state vector space ...
      GH11 = DET*H(1,1) + GCP12*H(2,1)
      GH12 = DET*H(1,2) + GCP12*H(2,2)
      WT(1,1) = H(1,1)*GH11 + H(2,1)*H(2,1)
      WT(1,2) = H(1,1)*GH12 + H(2,1)*H(2,2)
      WT(1,3) = H(1,1)*GCP13
      WT(1,4) = H(1,1)*GCP14
      WT(1,5) = H(1,1)*GCP15

      WT(2,1) = H(1,2)*GH11 + H(2,2)*H(2,1)
      WT(2,2) = H(1,2)*GH12 + H(2,2)*H(2,2)
      WT(2,3) = H(1,2)*GCP13
      WT(2,4) = H(1,2)*GCP14
      WT(2,5) = H(1,2)*GCP15

* ... and finally, premultiply by CPRO
      CFIL(1,1) = CPRO(1,1)*WT(1,1) + CPRO(2,1)*WT(2,1)

      CFIL(2,1) = CPRO(2,1)*WT(1,1) + CPRO(2,2)*WT(2,1)
      CFIL(2,2) = CPRO(2,1)*WT(1,2) + CPRO(2,2)*WT(2,2)

      CFIL(3,1) = CPRO(3,1)*WT(1,1) + CPRO(3,2)*WT(2,1)
      CFIL(3,2) = CPRO(3,1)*WT(1,2) + CPRO(3,2)*WT(2,2)
      CFIL(3,3) = CPRO(3,1)*WT(1,3) + CPRO(3,2)*WT(2,3) + CPRO(3,3)

      CFIL(4,1) = CPRO(4,1)*WT(1,1) + CPRO(4,2)*WT(2,1)
      CFIL(4,2) = CPRO(4,1)*WT(1,2) + CPRO(4,2)*WT(2,2)
      CFIL(4,3) = CPRO(4,1)*WT(1,3) + CPRO(4,2)*WT(2,3) + CPRO(4,3)
      CFIL(4,4) = CPRO(4,1)*WT(1,4) + CPRO(4,2)*WT(2,4) + CPRO(4,4)

      CFIL(5,1) = CPRO(5,1)*WT(1,1) + CPRO(5,2)*WT(2,1)
      CFIL(5,2) = CPRO(5,1)*WT(1,2) + CPRO(5,2)*WT(2,2)
      CFIL(5,3) = CPRO(5,1)*WT(1,3) + CPRO(5,2)*WT(2,3) + CPRO(5,3)
      CFIL(5,4) = CPRO(5,1)*WT(1,4) + CPRO(5,2)*WT(2,4) + CPRO(5,4)
      CFIL(5,5) = CPRO(5,1)*WT(1,5) + CPRO(5,2)*WT(2,5) + CPRO(5,5)

      RETURN

 1000 CONTINUE

* For 1/3 of the planars there is no rotation, and the rest is trivial
      DET = GMES(1,1)*CPRO(2,2) + 1.D0
      IF (DET.LE.0.D0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF
      DET = 1.D0/DET
      GDET = GMES(1,1)*DET

      WT(1,1) = 1.D0
      WT(1,2) = 0.D0
      WT(1,3) = 0.D0
      WT(1,4) = 0.D0
      WT(1,5) = 0.D0

      WT(2,1) = -GDET*CPRO(2,1)
      WT(2,2) =  DET
      WT(2,3) = -GDET*CPRO(3,2)
      WT(2,4) = -GDET*CPRO(4,2)
      WT(2,5) = -GDET*CPRO(5,2)

      CFIL(1,1) = CPRO(1,1) + CPRO(2,1)*WT(2,1)

      CFIL(2,1) = CPRO(2,1) + CPRO(2,2)*WT(2,1)
      CFIL(2,2) =             CPRO(2,2)*WT(2,2)

      CFIL(3,1) = CPRO(3,1) + CPRO(3,2)*WT(2,1)
      CFIL(3,2) =             CPRO(3,2)*WT(2,2)
      CFIL(3,3) =             CPRO(3,2)*WT(2,3) + CPRO(3,3)

      CFIL(4,1) = CPRO(4,1) + CPRO(4,2)*WT(2,1)
      CFIL(4,2) =             CPRO(4,2)*WT(2,2)
      CFIL(4,3) =             CPRO(4,2)*WT(2,3) + CPRO(4,3)
      CFIL(4,4) =             CPRO(4,2)*WT(2,4) + CPRO(4,4)

      CFIL(5,1) = CPRO(5,1) + CPRO(5,2)*WT(2,1)
      CFIL(5,2) =             CPRO(5,2)*WT(2,2)
      CFIL(5,3) =             CPRO(5,2)*WT(2,3) + CPRO(5,3)
      CFIL(5,4) =             CPRO(5,2)*WT(2,4) + CPRO(5,4)
      CFIL(5,5) =             CPRO(5,2)*WT(2,5) + CPRO(5,5)

      RETURN

 2000 CONTINUE

*
* Same as the above, for a different wire alignment (I think this
* is the one which actually occurs).
*

      DET = GMES(1,1)*CPRO(1,1) + 1.D0
      IF (DET.LE.0.D0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF
      DET = 1.D0/DET
      GDET = GMES(1,1)*DET

      WT(1,1) = DET
      WT(1,2) = -CPRO(2,1)*GDET
      WT(1,3) = -CPRO(3,1)*GDET
      WT(1,4) = -CPRO(4,1)*GDET
      WT(1,5) = -CPRO(5,1)*GDET

      WT(2,1) = 0.D0
      WT(2,2) = 1.D0
      WT(2,3) = 0.D0
      WT(2,4) = 0.D0
      WT(2,5) = 0.D0

* ... and finally, premultiply by CPRO
      CFIL(1,1) = CPRO(1,1)*WT(1,1)

      CFIL(2,1) = CPRO(2,1)*WT(1,1)
      CFIL(2,2) = CPRO(2,1)*WT(1,2) + CPRO(2,2)

      CFIL(3,1) = CPRO(3,1)*WT(1,1)
      CFIL(3,2) = CPRO(3,1)*WT(1,2) + CPRO(3,2)
      CFIL(3,3) = CPRO(3,1)*WT(1,3) + CPRO(3,3)

      CFIL(4,1) = CPRO(4,1)*WT(1,1)
      CFIL(4,2) = CPRO(4,1)*WT(1,2) + CPRO(4,2)
      CFIL(4,3) = CPRO(4,1)*WT(1,3) + CPRO(4,3)
      CFIL(4,4) = CPRO(4,1)*WT(1,4) + CPRO(4,4)

      CFIL(5,1) = CPRO(5,1)*WT(1,1)
      CFIL(5,2) = CPRO(5,1)*WT(1,2) + CPRO(5,2)
      CFIL(5,3) = CPRO(5,1)*WT(1,3) + CPRO(5,3)
      CFIL(5,4) = CPRO(5,1)*WT(1,4) + CPRO(5,4)
      CFIL(5,5) = CPRO(5,1)*WT(1,5) + CPRO(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.45.08  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKCOVR(CPRO,H,GMES,CFIL,WT,IERR)
*-----------------------------------------Updates 24/01/92-------
**: FKCOVR 30205.SB. Overflow error trapped.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Calculate filtered covariance for a `radial' (i.e. two             *
* measurements)                                                      *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 111 ; filtered covariance not positive definite       *
*   ->  IERR = 113 ; determinant .GT. 10**20                         *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=2)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      PARAMETER (GCMAX=1.0D10)

      DIMENSION CPRO(5,5),H(2,2),GMES(2,2),CFIL(5,5),WT(2,5)

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

      IERR = 0

* First rotate the measurement covariance ...
      CR11 = H(1,1)*(GMES(1,1)*H(1,1) + 2.*GMES(2,1)*H(2,1)) +
     &       H(2,1)*GMES(2,2)*H(2,1)
      HG21 = H(1,2)*GMES(1,1) + H(2,2)*GMES(2,1)
      HG22 = H(1,2)*GMES(2,1) + H(2,2)*GMES(2,2)
      CR21 = HG21*H(1,1) + HG22*H(2,1)
      CR22 = HG21*H(1,2) + HG22*H(2,2)

* ... then calculate the top two rows of G.CPRO + 1 ...
      GC11 = CR11*CPRO(1,1) + CR21*CPRO(2,1) + 1.D0
      GC12 = CR11*CPRO(2,1) + CR21*CPRO(2,2)
      GC13 = CR11*CPRO(3,1) + CR21*CPRO(3,2)
      GC14 = CR11*CPRO(4,1) + CR21*CPRO(4,2)
      GC15 = CR11*CPRO(5,1) + CR21*CPRO(5,2)

      GC21 = CR21*CPRO(1,1) + CR22*CPRO(2,1)
      GC22 = CR21*CPRO(2,1) + CR22*CPRO(2,2) + 1.D0
      GC23 = CR21*CPRO(3,1) + CR22*CPRO(3,2)
      GC24 = CR21*CPRO(4,1) + CR22*CPRO(4,2)
      GC25 = CR21*CPRO(5,1) + CR22*CPRO(5,2)

      IF (GC11.GT.GCMAX .OR. GC22.GT.GCMAX .OR.
     &    GC12.GT.GCMAX .OR. GC21.GT.GCMAX) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOVCV,IERR)
         RETURN
      ENDIF

* ... and invert (only the top two rows are non-trivial) ...
      DET = GC11*GC22 - GC12*GC21
      IF (DET.LE.0.) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF
      DET = 1.D0/DET

      GDET22 = GC22*DET
      GDET12 = GC12*DET
      WT(1,1) =  GDET22
      WT(1,2) = -GDET12
      WT(1,3) =  GDET12*GC23 - GC13*GDET22
      WT(1,4) =  GDET12*GC24 - GC14*GDET22
      WT(1,5) =  GDET12*GC25 - GC15*GDET22

      GDET11 = GC11*DET
      GDET21 = GC21*DET
      WT(2,1) = -GDET21
      WT(2,2) =  GDET11
      WT(2,3) =  GC13*GDET21 - GDET11*GC23
      WT(2,4) =  GC14*GDET21 - GDET11*GC24
      WT(2,5) =  GC15*GDET21 - GDET11*GC25

* ... and finally, premultiply by CPRO

      CFIL(1,1) = CPRO(1,1)*WT(1,1) + CPRO(2,1)*WT(2,1)

      CFIL(2,1) = CPRO(2,1)*WT(1,1) + CPRO(2,2)*WT(2,1)
      CFIL(2,2) = CPRO(2,1)*WT(1,2) + CPRO(2,2)*WT(2,2)

      CFIL(3,1) = CPRO(3,1)*WT(1,1) + CPRO(3,2)*WT(2,1)
      CFIL(3,2) = CPRO(3,1)*WT(1,2) + CPRO(3,2)*WT(2,2)
      CFIL(3,3) = CPRO(3,1)*WT(1,3) + CPRO(3,2)*WT(2,3) + CPRO(3,3)

      CFIL(4,1) = CPRO(4,1)*WT(1,1) + CPRO(4,2)*WT(2,1)
      CFIL(4,2) = CPRO(4,1)*WT(1,2) + CPRO(4,2)*WT(2,2)
      CFIL(4,3) = CPRO(4,1)*WT(1,3) + CPRO(4,2)*WT(2,3) + CPRO(4,3)
      CFIL(4,4) = CPRO(4,1)*WT(1,4) + CPRO(4,2)*WT(2,4) + CPRO(4,4)

      CFIL(5,1) = CPRO(5,1)*WT(1,1) + CPRO(5,2)*WT(2,1)
      CFIL(5,2) = CPRO(5,1)*WT(1,2) + CPRO(5,2)*WT(2,2)
      CFIL(5,3) = CPRO(5,1)*WT(1,3) + CPRO(5,2)*WT(2,3) + CPRO(5,3)
      CFIL(5,4) = CPRO(5,1)*WT(1,4) + CPRO(5,2)*WT(2,4) + CPRO(5,4)
      CFIL(5,5) = CPRO(5,1)*WT(1,5) + CPRO(5,2)*WT(2,5) + CPRO(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.52  by  Girish D. Patel
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKCVXY(CPRO,GMES,CFIL,WT,IERR)
**********************************************************************
*                                                                    *
* Calculate filtered covariance for an x/y measurement               *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 111 ; filtered covariance not positive definite       *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=11)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION CPRO(5,5),GMES(2,2),CFIL(5,5),WT(2,5)

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

      IERR = 0

* Calculate the top two rows of G.CPRO + 1 ...
      GC11 = GMES(1,1)*CPRO(1,1) + GMES(2,1)*CPRO(2,1) + 1.D0
      GC12 = GMES(1,1)*CPRO(2,1) + GMES(2,1)*CPRO(2,2)
      GC13 = GMES(1,1)*CPRO(3,1) + GMES(2,1)*CPRO(3,2)
      GC14 = GMES(1,1)*CPRO(4,1) + GMES(2,1)*CPRO(4,2)
      GC15 = GMES(1,1)*CPRO(5,1) + GMES(2,1)*CPRO(5,2)

      GC21 = GMES(2,1)*CPRO(1,1) + GMES(2,2)*CPRO(2,1)
      GC22 = GMES(2,1)*CPRO(2,1) + GMES(2,2)*CPRO(2,2) + 1.D0
      GC23 = GMES(2,1)*CPRO(3,1) + GMES(2,2)*CPRO(3,2)
      GC24 = GMES(2,1)*CPRO(4,1) + GMES(2,2)*CPRO(4,2)
      GC25 = GMES(2,1)*CPRO(5,1) + GMES(2,2)*CPRO(5,2)

* ... and invert (only the top two rows are non-trivial) ...
      DET = GC11*GC22 - GC12*GC21
      IF (DET.LE.0.) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF
      DET = 1.D0/DET

      GDET22 = GC22*DET
      GDET12 = GC12*DET
      WT(1,1) =  GDET22
      WT(1,2) = -GDET12
      WT(1,3) =  GDET12*GC23 - GC13*GDET22
      WT(1,4) =  GDET12*GC24 - GC14*GDET22
      WT(1,5) =  GDET12*GC25 - GC15*GDET22

      GDET11 = GC11*DET
      GDET21 = GC21*DET
      WT(2,1) = -GDET21
      WT(2,2) =  GDET11
      WT(2,3) =  GC13*GDET21 - GDET11*GC23
      WT(2,4) =  GC14*GDET21 - GDET11*GC24
      WT(2,5) =  GC15*GDET21 - GDET11*GC25

* ... and finally, premultiply by CPRO

      CFIL(1,1) = CPRO(1,1)*WT(1,1) + CPRO(2,1)*WT(2,1)

      CFIL(2,1) = CPRO(2,1)*WT(1,1) + CPRO(2,2)*WT(2,1)
      CFIL(2,2) = CPRO(2,1)*WT(1,2) + CPRO(2,2)*WT(2,2)

      CFIL(3,1) = CPRO(3,1)*WT(1,1) + CPRO(3,2)*WT(2,1)
      CFIL(3,2) = CPRO(3,1)*WT(1,2) + CPRO(3,2)*WT(2,2)
      CFIL(3,3) = CPRO(3,1)*WT(1,3) + CPRO(3,2)*WT(2,3) + CPRO(3,3)

      CFIL(4,1) = CPRO(4,1)*WT(1,1) + CPRO(4,2)*WT(2,1)
      CFIL(4,2) = CPRO(4,1)*WT(1,2) + CPRO(4,2)*WT(2,2)
      CFIL(4,3) = CPRO(4,1)*WT(1,3) + CPRO(4,2)*WT(2,3) + CPRO(4,3)
      CFIL(4,4) = CPRO(4,1)*WT(1,4) + CPRO(4,2)*WT(2,4) + CPRO(4,4)

      CFIL(5,1) = CPRO(5,1)*WT(1,1) + CPRO(5,2)*WT(2,1)
      CFIL(5,2) = CPRO(5,1)*WT(1,2) + CPRO(5,2)*WT(2,2)
      CFIL(5,3) = CPRO(5,1)*WT(1,3) + CPRO(5,2)*WT(2,3) + CPRO(5,3)
      CFIL(5,4) = CPRO(5,1)*WT(1,4) + CPRO(5,2)*WT(2,4) + CPRO(5,4)
      CFIL(5,5) = CPRO(5,1)*WT(1,5) + CPRO(5,2)*WT(2,5) + CPRO(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.26  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKDMQD(DINV,QGAIN,AGAIN)
**********************************************************************
*                                                                    *
* Calculate the smoother gain matrix                                 *
*                                                                    *
* Output is AGAIN = DINV.(1 - QGAIN)                                 *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION DINV(5,5),QGAIN(5,5),AGAIN(5,5)

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

      AGAIN(1,1) = 1.D0      - QGAIN(1,1) - DINV(1,4)*QGAIN(4,1)
     &                                    - DINV(1,5)*QGAIN(5,1)
      AGAIN(1,2) =           - QGAIN(1,2) - DINV(1,4)*QGAIN(4,2)
     &                                    - DINV(1,5)*QGAIN(5,2)
      AGAIN(1,3) = DINV(1,3) - QGAIN(1,3) - DINV(1,4)*QGAIN(4,3)
     &                                    - DINV(1,5)*QGAIN(5,3)
      AGAIN(1,4) = DINV(1,4) - QGAIN(1,4) - DINV(1,4)*QGAIN(4,4)
     &                                    - DINV(1,5)*QGAIN(5,4)
      AGAIN(1,5) = DINV(1,5) - QGAIN(1,5) - DINV(1,4)*QGAIN(4,5)
     &                                    - DINV(1,5)*QGAIN(5,5)

      AGAIN(2,1) =           - QGAIN(2,1) - DINV(2,4)*QGAIN(4,1)
     &                                    - DINV(2,5)*QGAIN(5,1)
      AGAIN(2,2) = 1.D0      - QGAIN(2,2) - DINV(2,4)*QGAIN(4,2)
     &                                    - DINV(2,5)*QGAIN(5,2)
      AGAIN(2,3) = DINV(2,3) - QGAIN(2,3) - DINV(2,4)*QGAIN(4,3)
     &                                    - DINV(2,5)*QGAIN(5,3)
      AGAIN(2,4) = DINV(2,4) - QGAIN(2,4) - DINV(2,4)*QGAIN(4,4)
     &                                    - DINV(2,5)*QGAIN(5,4)
      AGAIN(2,5) = DINV(2,5) - QGAIN(2,5) - DINV(2,4)*QGAIN(4,5)
     &                                    - DINV(2,5)*QGAIN(5,5)

      AGAIN(3,3) = 1.D0

      AGAIN(4,1) =      - QGAIN(4,1)
      AGAIN(4,2) =      - QGAIN(4,2)
      AGAIN(4,3) =      - QGAIN(4,3)
      AGAIN(4,4) = 1.D0 - QGAIN(4,4)
      AGAIN(4,5) =      - QGAIN(4,5)

      AGAIN(5,1) =           - DINV(5,4)*QGAIN(4,1) - QGAIN(5,1)
      AGAIN(5,2) =           - DINV(5,4)*QGAIN(4,2) - QGAIN(5,2)
      AGAIN(5,3) = DINV(5,3) - DINV(5,4)*QGAIN(4,3) - QGAIN(5,3)
      AGAIN(5,4) = DINV(5,4) - DINV(5,4)*QGAIN(4,4) - QGAIN(5,4)
      AGAIN(5,5) = 1.D0      - DINV(5,4)*QGAIN(4,5) - QGAIN(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.26  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKDQA(D,Q,A,C)
**********************************************************************
*                                                                    *
* Optimised matrix transformation (used by the smoother).            *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION D(5,5),Q(5,5),A(5,5),C(5,5)

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

      DQ1 = Q(1,1) + D(1,4)*Q(4,1) + D(1,5)*Q(5,1)
      DQ2 = Q(2,1) + D(1,4)*Q(4,2) + D(1,5)*Q(5,2)
      DQ4 = Q(4,1) + D(1,4)*Q(4,4) + D(1,5)*Q(5,4)
      DQ5 = Q(5,1) + D(1,4)*Q(5,4) + D(1,5)*Q(5,5)

      C(1,1) = C(1,1) + DQ1*A(1,1) + DQ2*A(1,2)
     &                + DQ4*A(1,4) + DQ5*A(1,5)
      C(2,1) = C(2,1) + DQ1*A(2,1) + DQ2*A(2,2)
     &                + DQ4*A(2,4) + DQ5*A(2,5)
      C(4,1) = C(4,1) + DQ1*A(4,1) + DQ2*A(4,2)
     &                + DQ4*A(4,4) + DQ5*A(4,5)
      C(5,1) = C(5,1) + DQ1*A(5,1) + DQ2*A(5,2)
     &                + DQ4*A(5,4) + DQ5*A(5,5)

      DQ1 = Q(2,1) + D(2,4)*Q(4,1) + D(2,5)*Q(5,1)
      DQ2 = Q(2,2) + D(2,4)*Q(4,2) + D(2,5)*Q(5,2)
      DQ4 = Q(4,2) + D(2,4)*Q(4,4) + D(2,5)*Q(5,4)
      DQ5 = Q(5,2) + D(2,4)*Q(5,4) + D(2,5)*Q(5,5)

      C(2,2) = C(2,2) + DQ1*A(2,1) + DQ2*A(2,2)
     &                + DQ4*A(2,4) + DQ5*A(2,5)
      C(4,2) = C(4,2) + DQ1*A(4,1) + DQ2*A(4,2)
     &                + DQ4*A(4,4) + DQ5*A(4,5)
      C(5,2) = C(5,2) + DQ1*A(5,1) + DQ2*A(5,2)
     &                + DQ4*A(5,4) + DQ5*A(5,5)

      C(4,4) = C(4,4) + Q(4,1)*A(4,1) + Q(4,2)*A(4,2)
     &                + Q(4,4)*A(4,4) + Q(5,4)*A(4,5)
      C(5,4) = C(5,4) + Q(4,1)*A(5,1) + Q(4,2)*A(5,2)
     &                + Q(4,4)*A(5,4) + Q(5,4)*A(5,5)

      C(5,5) = C(5,5) + (D(5,4)*Q(4,1) + Q(5,1))*A(5,1)
     &                + (D(5,4)*Q(4,2) + Q(5,2))*A(5,2)
     &                + (D(5,4)*Q(4,4) + Q(5,4))*A(5,4)
     &                + (D(5,4)*Q(5,4) + Q(5,5))*A(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  5.01/08 23/02/94  14.18.18  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.35  by  Stephen Burke
*-- Author :    Stephen Burke   28/08/91
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKEM(IUTIL,IROUT,ISEV,ICODE)
*-----------------------------------------Updates 27/07/93-------
**: FKEM   30907 SB. Change 'error 17' message.
*-----------------------------------------Updates 04/05/92-------
**: FKEM   30907 SB. Severity added to ERRLOG messages.
*-----------------------------------------Updates 27/04/92-------
**: FKEM 30301.SB. New error messages for FKLPAS and FKLPAF.
*-----------------------------------------Updates 24/01/92-------
**: FKEM 30205.SB.   New error code (IOVCV).
**: FKEM 30205.SB.   Message format changed.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Interface to ERRLOG error reporting                                *
*                                                                    *
**********************************************************************

      PARAMETER (NROUT=20,NERR=10)
      CHARACTER*6 CROUT(6)
      CHARACTER*7 CNAME(NROUT,0:1)
      CHARACTER*60 CMESS(NERR,NROUT,0:1),CITER(4),CSTAND(10)
      CHARACTER*2 CNUM
      CHARACTER*60 MESS
      CHARACTER*62 MESS2
      DIMENSION IMESS(NERR,NROUT,0:1)

      SAVE CROUT,CNAME,CMESS,CITER,CSTAND,IMESS,IFIRST

      DATA CROUT/'FKLPRO','FKLFLT','FKLSMO','FKLPRS','FKLPAS','FKLPAF'/

      DATA CNAME/'FKLFIT:','FKLPRO:','FKLFLT:','FKLSMO:','FKLRFL:'
     &,          'FKLWM: ','FKLRSD:','FKLPRS:','FKLPAS:','FKLFTR:'
     &,          'FKLSPR:','FKLFXY:','FKLSSM:','FKLXY: ','FKLXYZ:'
     &,          'FKLPAF:','Unused:','Unused:','Unused:','Unused:'
     &,          'FKCOVP:','FKCOVR:','FKINV: ','FKNORM:','FKRST: '
     &,          'FKQG:  ','FKLOOK:','FKHUNT:','FKCHPR:','FKCHXY:'
     &,          'FKCVXY:','Unused:','Unused:','Unused:','Unused:'
     &,          'Unused:','Unused:','Unused:','Unused:','Unused:'/

      DATA IMESS/1,2,3,4,6*0   ,1,5,8*0         ,1,5,7,7*0 ,1,2,5,7*0
     &,          1,3,4,7,6*0   ,10*0            ,3,9*0   ,1,2,3,4,5,5*0
     &,          1,2,3,4,7,5*0 ,1,2,3,4,8,9,4*0 ,10*0      ,7,9*0
     &,          10*0          ,7,9*0           ,7,9*0     ,1,3,4,7*0
     &,          10*0          ,10*0            ,10*0      ,10*0
     &,          10*0          ,10*0            ,7,9*0     ,10*0
     &,          10*0          ,10*0            ,3,9*0     ,1,3,4,7*0
     &,          1,4,8*0       ,10*0            ,10*0      ,10*0
     &,          10*0          ,10*0            ,10*0      ,10*0
     &,          10*0          ,10*0            ,10*0      ,10*0/

      DATA IFIRST/0/

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

      IF (IFIRST.GT.0) GOTO 1000

      IFIRST = 1

      CMESS(1,1,0) = 'No starting point provided'
      CMESS(2,1,0) = 'Not enough measurements to fit'
      CMESS(3,1,0) = 'Invalid value in MES array'
      CMESS(4,1,0) = 'Invalid value of JSTART, JSTOP or JLAST'

      CMESS(1,2,0) = 'Filtered vector missing'
      CMESS(2,2,0) = 'Projection already done'

      CMESS(1,3,0) = 'Projected vector missing'
      CMESS(2,3,0) = 'Filtering already done'
      CMESS(3,3,0) = 'Failure to invert measurement covariance'

      CMESS(1,4,0) = 'Smoothed vector missing'
      CMESS(2,4,0) = 'Projected vector missing'
      CMESS(3,4,0) = 'Smoothing already done'

      CMESS(1,5,0) = 'Smoothed vector missing'
      CMESS(2,5,0) = 'No measurement to remove'
      CMESS(3,5,0) = 'Invalid value of IFLAG'
      CMESS(4,5,0) = 'Failure to invert measurement covariance'

      CMESS(1,7,0) = 'No measurement'

      CMESS(1,8,0) = 'Smoothed vector missing'
      CMESS(2,8,0) = 'Projected vector missing'
      CMESS(3,8,0) = 'End plane of block was skipped'
      CMESS(4,8,0) = 'LPOINT and LBLOCK both .FALSE.'
      CMESS(5,8,0) = 'Internal error (bad call to FKLSMO)'

      CMESS(1,9,0) = 'Invalid probability cut or '//
     &               'smoothed vector missing'
      CMESS(2,9,0) = 'LMES(JPL) set on entry, but IRJCT(JPL) > 1'
      CMESS(3,9,0) = 'LMES(JPL) not set by FKLOOK or FKHUNT'
      CMESS(4,9,0) = 'Internal error (IFLAG=0 in call to FKLRFL)'
      CMESS(5,9,0) = 'Measurement covariance not positive definite'

      CMESS(1,10,0) = 'No starting point provided'
      CMESS(2,10,0) = 'Not enough measurements to fit'
      CMESS(3,10,0) = 'Invalid value in MES array'
      CMESS(4,10,0) = 'Invalid value of JSTART, JSTOP or JLAST'
      CMESS(5,10,0) = 'Covariance n.p.d. in FKLWM (1st call)'
      CMESS(6,10,0) = 'Covariance n.p.d. in FKLWM (2nd call)'

      CMESS(1,12,0) = 'Failure to invert measurement covariance'

      CMESS(1,14,0) = 'Failure to invert measurement covariance'

      CMESS(1,15,0) = 'Failure to invert measurement covariance'

      CMESS(1,16,0) = 'Invalid probability cut or '//
     &                'projected vector missing'
      CMESS(2,16,0) = 'Invalid value in MES array'
      CMESS(3,16,0) = 'Invalid value in MES array, or internal error'

      CMESS(1,3,1) = 'Measurement covariance not positive definite'

      CMESS(1,7,1) = 'LMES(JPL) already set'

      CMESS(1,8,1) = 'Invalid probability cut'
      CMESS(2,8,1) = 'Invalid value in MES array'
      CMESS(3,8,1) = 'Invalid value in MES array, or internal error'

      CMESS(1,9,1) = 'Invalid probability cut'
      CMESS(2,9,1) = 'Invalid value of NPROB or NFREE'

      CITER(1) = ' iterations in point rejection'
      CITER(2) = ' iterations over fit sections'
      CITER(3) = ' restarts'
      CITER(4) = ' iterations'

      CSTAND(1)  = 'Output covariance not positive definite'
      CSTAND(2)  = 'Covariance of residuals not positive definite'//
     &             ' (chi-sq zero)'
      CSTAND(3)  = 'Covariance element .GT. 10**10'
      CSTAND(4)  = 'Unknown error'
      CSTAND(5)  = 'Unknown error'
      CSTAND(6)  = 'TAN(theta)>10**6, or x or y >10**4 (reset)'
      CSTAND(7)  = 'TAN(theta)>50'
      CSTAND(8)  = 'Unknown error'
      CSTAND(9)  = 'Unknown error'
      CSTAND(10) = 'Unknown error'

 1000 CONTINUE

      ICODE1 = MOD(ICODE,100)

      IF (IUTIL.LT.0 .OR. IUTIL.GT.1 .OR. IROUT.LT.1 .OR.
     &    IROUT.GT.NROUT .OR. ISEV.LT.0 .OR. ISEV.GT.7 .OR.
     &    ICODE1.LT.1 .OR. ICODE1.GT.50 ) THEN
         CALL ERRLOG(1000,'W:FKEM:   Illegal error code')
         RETURN
      ENDIF

      IF (ISEV.GE.2) THEN
         WRITE(CNUM,9000) ICODE1
         MESS = CNAME(IROUT,IUTIL)//' Fatal error '//CNUM//
     &                              ' from '//CROUT(ISEV-1)
      ELSE
         IF (ICODE1.LE.10) THEN
            INDEX = 0
            DO 100 I=1,NERR
               IF (IMESS(I,IROUT,IUTIL).EQ.ICODE1) INDEX = I
 100        CONTINUE
            IF (INDEX.GT.0) THEN
               MESS = CNAME(IROUT,IUTIL)//' '//CMESS(INDEX,IROUT,IUTIL)
            ELSE
               MESS = CNAME(IROUT,IUTIL)//' Unknown error'
            ENDIF
         ELSEIF (ICODE1.LE.20) THEN
            MESS = CNAME(IROUT,IUTIL)//' '//CSTAND(ICODE1-10)
         ELSE
            INUM = MOD(ICODE1,10)
            ICAUSE = ICODE1/10 - 1
            IF (INUM.EQ.0) THEN
               INUM = 10
               ICAUSE = ICAUSE - 1
            ENDIF
            IF (IROUT.EQ.14 .OR. IROUT.EQ.15) ICAUSE = 4
            WRITE(CNUM,9000) INUM
            MESS = CNAME(IROUT,IUTIL)//' '//CNUM//CITER(ICAUSE)
         ENDIF
      ENDIF

      MESS2= 'W:'//MESS
      MESS = MESS2

      CALL ERRLOG(1000+2000*IUTIL+100*IROUT+ICODE1,MESS)

 9000 FORMAT(I2)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.45.09  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKEND
*-----------------------------------------Updates 13/02/92-------
**: FKEND 30205.SB.  Cosmetic change to printout.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Print out statistics on point rejection and errors                 *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKLERR.
      PARAMETER(NROUT=20,NCODE=50)
      COMMON /FKLERR/ NMERR(NCODE,NROUT),NUERR(NCODE,NROUT)
     &,               NFAT,NERR,NOFL,NUFL,IULAST,IRLAST,MAXERR
*KEND.

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

      WRITE(LUN,*)
      WRITE(LUN,*)
      WRITE(LUN,*) '              *** Kalman Filter error summary ***'
      WRITE(LUN,*)
      WRITE(LUN,*)
      WRITE(LUN,*) 'Number of fatal errors     = ',NFAT
      WRITE(LUN,*) 'Total number of errors     = ',NERR
      WRITE(LUN,*)

      IF (NOFL.GT.0) WRITE(LUN,1000) NOFL
      IF (NUFL.GT.0) WRITE(LUN,1100) NUFL

* Printout level set by IPR
      IF (IPR.LT.2) THEN
         ISTEP = 9
      ELSE
         ISTEP = 1
      ENDIF

      IULAST = 0
      DO 200 IROUT=1,NROUT,ISTEP
         IFLAG = 0
         DO 50 ICODE=1,NCODE
            IF (NMERR(ICODE,IROUT).GT.0) IFLAG = 1
 50      CONTINUE
         IF (IFLAG.EQ.1) THEN
            IRLAST = IROUT
            CALL FKPRNT(0,0)
            DO 100 ICODE=1,NCODE
               NUM = NMERR(ICODE,IROUT)
               IF (NUM.GT.0) CALL FKPRNT(NUM,ICODE)
 100        CONTINUE
         ENDIF
 200  CONTINUE

      IF (IPR.LT.4) RETURN

      IULAST = 1
      DO 400 IROUT=1,NROUT
         IFLAG = 0
         DO 250 ICODE=1,NCODE
            IF (NUERR(ICODE,IROUT).GT.0) IFLAG = 1
 250     CONTINUE
         IF (IFLAG.EQ.1) THEN
            IRLAST = IROUT
            CALL FKPRNT(0,0)
            DO 300 ICODE=1,NCODE
               NUM = NUERR(ICODE,IROUT)
               IF (NUM.GT.0) CALL FKPRNT(NUM,ICODE)
 300        CONTINUE
         ENDIF
 400  CONTINUE

 1000 FORMAT(/' *** FKERR called ',I6,' times with routine or error'/
     &        ' *** codes out of range'/)
 1100 FORMAT(/' *** FKERR called ',I6,' times with negative routine'/
     &        ' *** or error codes'/)

* Point rejection statistics
      IF (LPOINT .OR. LBLOCK) CALL FKSTAT

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  3.01/08 24/01/92  12.19.11  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKERR(IUTIL,IROUT,ISEV,ICODE,IERR)
**********************************************************************
*                                                                    *
* Routine to record errors.                                          *
*                                                                    *
**********************************************************************

*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKLERR.
      PARAMETER(NROUT=20,NCODE=50)
      COMMON /FKLERR/ NMERR(NCODE,NROUT),NUERR(NCODE,NROUT)
     &,               NFAT,NERR,NOFL,NUFL,IULAST,IRLAST,MAXERR
*KEND.

      SAVE NMESS
      DATA NMESS/0/

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

* Remember last routine code for printout routine
      IULAST = IUTIL
      IRLAST = IROUT

* Clear counters if error code is zero
      IF (ICODE.EQ.0) THEN
         CALL VZERO(NMERR,NCODE*NROUT)
         CALL VZERO(NUERR,NCODE*NROUT)
         NFAT = 0
         NERR = 0
         NOFL = 0
         NUFL = 0
         IERR = 0
         RETURN
      ENDIF

* Remove old severity code from ICODE
      IERR = MOD(ICODE,100)

* Write error message to ERRLOG
      CALL FKEM(IUTIL,IROUT,ISEV,ICODE)

*
* Deal with bad arguments - there isn't much point passing
* these back as an error!
*
      IF (IROUT.LE.0 .OR. IERR.LE.0) THEN
         NUFL = NUFL + 1
         RETURN
      ELSEIF (IROUT.GT.NROUT .OR. IERR.GT.NCODE) THEN
         NOFL = NOFL + 1
         RETURN
      ENDIF

      IF (IUTIL.EQ.0) THEN
         NMERR(IERR,IROUT) = NMERR(IERR,IROUT) + 1
      ELSE
         NUERR(IERR,IROUT) = NUERR(IERR,IROUT) + 1
      ENDIF
      IF (ISEV.GT.0) NFAT = NFAT + 1
      NERR = NERR + 1

      IERR = 100*ISEV + IERR

      IF (NMESS.GE.MAXERR) RETURN

* Print out a message if requested
      IF (IUTIL.EQ.0 .AND. (IROUT.EQ.1 .OR. IROUT.EQ.10)) THEN
         IFLAG = 10
      ELSEIF (IUTIL.EQ.0) THEN
         IFLAG = 14
      ELSE
         IFLAG = 18
      ENDIF
      IF (ISEV.GT.0) IFLAG = IFLAG - 2

      IF (IPR.LT.IFLAG) RETURN

      CALL FKPRNT(-1,IERR)

      NMESS = NMESS + 1

      IF (NMESS.NE.MAXERR) RETURN

      WRITE(LUN,*)
      WRITE(LUN,*) '*** Kalman filter - max error count exceeded ***'
      WRITE(LUN,*)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  7.02/11 30/10/95  17.38.09  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.51  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKHIST(LUN,ID,PCT,PMAX)
**********************************************************************
*                                                                    *
* Print a simple histogram (a row of stars)                          *
*                                                                    *
* Print 100*PCT/PMAX stars (max 100) to LUN with id # ID             *
*                                                                    *
**********************************************************************

      CHARACTER*100 STARS
      DATA INIT/0/

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

      IF (INIT.EQ.0) THEN
         INIT=1
         DO 100 I=1,100
            STARS(I:I) = '*'
 100     CONTINUE
      ENDIF

      NSTAR = 100.D0*PCT/PMAX
      IF (NSTAR.GT.100) NSTAR = 100

      IF (NSTAR.GT.0) THEN
         WRITE(LUN,1000) ID,PCT,STARS(1:NSTAR)
 1000    FORMAT(' ',I4,'  ',F5.1,'  ',A)
      ELSE
         WRITE(LUN,1100) ID,PCT
 1100    FORMAT(' ',I4,'  ',F5.1)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  2.01/03 18/02/91  10.52.11  by  Stephen Burke
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKINIT
**********************************************************************
*                                                                    *
* Initialise counters for errors and points rejected                 *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKTRUE.
*KEEP,FKFTVX.
      DOUBLE PRECISION DTHMAX,DPHMAX
      COMMON /FKFTVX/ DTHMAX,DPHMAX
*KEEP,FKINT.
*KEEP,FKLERR.
      PARAMETER(NROUT=20,NCODE=50)
      COMMON /FKLERR/ NMERR(NCODE,NROUT),NUERR(NCODE,NROUT)
     &,               NFAT,NERR,NOFL,NUFL,IULAST,IRLAST,MAXERR
*KEND.

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

* Set parameter defaults
      LFIRST = .TRUE.
      LPOINT = .FALSE.
      LBLOCK = .FALSE.
      LPRINI = .FALSE.
      LRPRO  = .FALSE.
      LRFIL  = .FALSE.
      LRSMT  = .TRUE.
      LTRUE  = .FALSE.

      DO 100 JPL=1,NPL
* It would be possible to set up the ZPL and RADL arrays here
         NBLOCK(JPL) = 0
         LWIRE(JPL)  = .FALSE.
         LRAD(JPL)   = .FALSE.
 100  CONTINUE

* Default printout is full summary + fatal errors during execution
      IPR    = 8
      LUN    = 6
      ITR    = 0
      MAXERR = 100

* These defaults are meant to be overridden
      X2PCUT = 0.001D0
      X2CUTB = 0.001D0
      X2CUTA = 0.1D0
      X2CUTN = 0.1D0
      X2PCTI = 0.00001D0
      X2CTBI = 0.00001D0
      X2CTAI = 0.1D0
      X2CTNI = 0.1D0
      DTHMAX = 0.01
      DPHMAX = 0.01

* Set error counts to zero
      CALL FKERR(0,0,0,0,IERR)

* Set rejected-point counts to zero
      CALL VZERO(NNEWP,NPL)
      CALL VZERO(NBADP,NPL)
      CALL VZERO(NBADB,NPL)
      CALL VZERO(NUNRJP,NPL)
      CALL VZERO(NUNRJB,NPL)
      CALL VZERO(NRERJP,NPL)
      CALL VZERO(NFAILP,NPL)
      CALL VZERO(NFAILB,NPL)

      NCPAS = 0
      NCPRS = 0
      NBPRS = 0

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.48  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKINV(MES,CMES,GMES,IERR)
**********************************************************************
*                                                                    *
* Invert the measurement covariance matrix                           *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 107 ; measurement covariance not positive definite    *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=3)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION CMES(2,2),GMES(2,2)

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

      IERR = 0

      IF (MES.EQ.2) THEN
         DET = (CMES(1,1)*CMES(2,2) - CMES(2,1)*CMES(2,1))
         IF (DET.LE.0.D0) THEN
            CALL FKERR(IUTIL,IROUT,IFATAL,IMCV,IERR)
            RETURN
         ENDIF
         DET = 1.D0/DET
         GMES(1,1) =  CMES(2,2)*DET
         GMES(2,1) = -CMES(2,1)*DET
         GMES(2,2) =  CMES(1,1)*DET
      ELSE
         IF (CMES(1,1).LE.0.D0) THEN
            CALL FKERR(IUTIL,IROUT,IFATAL,IMCV,IERR)
            RETURN
         ENDIF
         GMES(1,1) = 1.D0/CMES(1,1)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  2.01/03 18/02/91  10.43.48  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLFIT(IERR)
**********************************************************************
*                                                                    *
* KALMAN Filter + Smoother applied to the full Forward Tracker       *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*                                                                    *
*       IERR =        0 ; normal termination                         *
*   ->  IERR =      101 ; no starting point was provided             *
*   ->  IERR =      102 ; not enough measurements to fit             *
*   ->  IERR =      103 ; invalid value in MES array                 *
*   ->  IERR =      104 ; invalid value of JSTART, JSTOP or JLAST    *
*       IERR =  20 +  n ; 1 < n < 10 iterations in point rejection   *
*   ->  IERR =      130 ; 10 iterations in point rejection           *
*   ->  IERR = 200 + ee ; fatal error ee from FKLPRO                 *
*   ->  IERR = 300 + ee ; fatal error ee from FKLFIL                 *
*   ->  IERR = 400 + ee ; fatal error ee from FKLSMO                 *
*   ->  IERR = 500 + ee ; fatal error ee from FKLPRS                 *
*   ->  IERR = 600 + ee ; fatal error ee from FKLPAS                 *
*   ->  IERR = 600 + ee ; fatal error ee from FKLPAF                 *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=1)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*
* Common block definitions
*
*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKPROJ.
*KEEP,FKFILT.
*KEEP,FKSMTH.
*KEEP,FKTRUE.
*KEEP,FKRSID.
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKINT.
*KEND.

**********************************************************************
*
* Initialisation and checks .........
*

      IERR = 0

*
* Check that the start and stop positions are sensible
*
      JMIN = MIN(JSTART,JSTOP,JLAST)
      JMAX = MAX(JSTART,JSTOP,JLAST)
      IF (JMIN.LE.0 .OR. JMAX.GT.NPL .OR.
     &            (JLAST.GT.JMIN .AND. JLAST.LT.JMAX)) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINV,IERR)
         RETURN
      ENDIF

      IF (.NOT.LPRO(JSTART)) THEN
* Starting point does not exist
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF1,IERR)
         RETURN
      ENDIF

*
* Set the steps between planes according to the direction
*
      IF (JLAST.GE.JSTART) THEN
         JSTEP = 1
      ELSE
         JSTEP = -1
      ENDIF

*
* Are there enough measurements (ignoring the starting point which has
* zero weight) to do the 5 parameter fit?
*
      NMES = 0
      JHWM = 0
      DO 100 JPL=JSTART,JLAST,JSTEP
         IF (LMES(JPL)) THEN
            IF (MES(JPL).LE.0 .OR. MES(JPL).GT.2) THEN
* Can only deal with 1 or 2 measurements per plane
               CALL FKERR(IUTIL,IROUT,IFATAL,IINF3,IERR)
               RETURN
            ENDIF
            NMES = NMES + MES(JPL)
            JHWM = JPL
         ENDIF
 100  CONTINUE
      IF (NMES.LT.5) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF2,IERR)
         RETURN
      ENDIF

*
* Calculate plane spacing according to direction.
* Be careful about edge effects!
*
      DO 200 JPL=JMIN-(JSTEP-1)/2,JMAX-(JSTEP+1)/2
         DZPL(JPL) = ZPL(JPL+JSTEP) - ZPL(JPL)
 200  CONTINUE

* If point rejection is on, the smoothed residuals must be calculated
      IF (LPOINT .OR. LBLOCK) LRSMT = .TRUE.

      NPASS  = 0
      LSTART = JSTART
      LSTOP  = JSTOP

* Re-entry point
 3000 CONTINUE

      NPASS = NPASS + 1
      IF (NPASS.GE.10) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IFREE1,IERR)
         RETURN
      ENDIF

*
* Reset all flags ...
*
      LFIL(LSTART) = .FALSE.
      DO 300 JPL=LSTART+JSTEP,JLAST,JSTEP
         LPRO(JPL) = .FALSE.
         LFIL(JPL) = .FALSE.
 300  CONTINUE
      DO 400 JPL=LSTOP,JLAST,JSTEP
         LSMT(JPL) = .FALSE.
 400  CONTINUE

*
* End of initialisation and checks.
*
**********************************************************************
*

      DO 1000 JPL=LSTART,JLAST,JSTEP
         IPL = JPL
* If we're past the last measurement, look for a new one
         IF ((LPOINT .OR. LBLOCK) .AND. JSTEP*(JPL-JHWM).GT.0) THEN
            CALL FKLPAF(JPL,IFAIL)
            IF (IFAIL.GT.100) THEN
               CALL FKERR(IUTIL,IROUT,IFPAF,IFAIL,IERR)
               RETURN
            ENDIF
            IF (LMES(JPL)) JHWM = JPL
         ENDIF
* Filter at plane JPL
         CALL FKLFLT(JPL,IFAIL)
         IF (IFAIL.GT.100) THEN
            CALL FKERR(IUTIL,IROUT,IFFLT,IFAIL,IERR)
            RETURN
         ENDIF
         IF (JPL.NE.JLAST) THEN
* Project to plane JPL+JSTEP (except if we're at the end)
            CALL FKLPRO(JPL,IFAIL)
            IF (IFAIL.GT.100) THEN
               CALL FKERR(IUTIL,IROUT,IFPRO,IFAIL,IERR)
               RETURN
            ENDIF
         ENDIF
 1000 CONTINUE

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

      NDROP = 0
      LLAST = JLAST

 1500 CONTINUE

      DO 2000 JPL=LLAST,LSTOP,-JSTEP
         IPL = JPL
* Smooth from plane JPL+JSTEP to plane JPL ...
         CALL FKLSMO(JPL,IFAIL)
         IF (IFAIL.GT.100) THEN
            CALL FKERR(IUTIL,IROUT,IFSMO,IFAIL,IERR)
            RETURN
         ENDIF
* Set the rejection flag to 0 on the first pass
         IF (LFIRST .AND. NPASS.EQ.1) IRJCT(JPL) = 0
         IF (LPOINT .OR. LBLOCK) THEN
* Reject bad points (do this on all planes, as they may be in a block)
            CALL FKLPRS(JPL,NDROP,IFAIL)
            IF (IFAIL.GT.100) THEN
               CALL FKERR(IUTIL,IROUT,IFPRS,IFAIL,IERR)
               RETURN
            ENDIF
*
* If there isn't a measurement, look for one.
* FKLPAS can be called even if LMES is .TRUE., but whether
* it's useful depends on FKHUNT, which hasn't been written yet.
* If JPL is above the high water mark FKLPAF will already have
* looked for a new point, so there's no point in doing it again.
*
            IF (.NOT.LMES(JPL) .AND. JSTEP*(JPL-JHWM).LE.0) THEN
               CALL FKLPAS(JPL,NDROP,IFAIL)
               IF (IFAIL.GT.100) THEN
                  CALL FKERR(IUTIL,IROUT,IFPAS,IFAIL,IERR)
                  RETURN
               ENDIF
            ENDIF
         ENDIF
 2000 CONTINUE

* If we've changed a point on this pass, we must smooth back to JSTOP
      IF (LSTOP.NE.JSTOP .AND. NDROP.GT.0) THEN
         LLAST = LSTOP - JSTEP
         LSTOP = JSTOP
         DO 500 JPL=LSTOP,LLAST,JSTEP
            LSMT(JPL) = .FALSE.
 500     CONTINUE
         GOTO 1500
      ENDIF

*
* Have any planes been rejected during smoothing?
* If so, re-filter outwards from plane NDROP, and smooth back to NDROP+1
*
      IF (NDROP.GT.0) THEN
         LSTART = NDROP
         LSTOP  = NDROP + JSTEP
         GOTO 3000
      ENDIF

      IF (NPASS.GT.2) CALL FKERR(IUTIL,IROUT,IWARN,IFREE+NPASS,IERR)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.23  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLFLT(JPL,IERR)
**********************************************************************
*                                                                    *
* Kalman Filter at plane JPL using the weighted mean formalism.      *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 101 ; no projection at JPL - filter terminated        *
*       IERR =   5 ; filtering at JPL already done - but continue    *
*   ->  IERR = 107 ; failure to invert measurement covariance        *
*   ->  IERR = 111 ; failure to invert filtered covariance           *
*       IERR =  12 ; covariance of filtered residuals n.p.d.         *
*   ->  IERR = 116 ; theta > pi/2: reset to pi/4                     *
*       IERR =  17 ; theta > 1 (warning)                             *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* NB Error 12 is not considered fatal, but the chi-sq will be zero   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=3)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*
* Common block definitions
*
*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKPROJ.
*KEEP,FKFILT.
*KEEP,FKRSID.
*KEND.

**********************************************************************
*
* Local arrays ...
*
      DIMENSION WT(2,5),GMES(2,2),HGW(2)

**********************************************************************
*
* Initialisation and checks ...
*
      IERR = 0

* has projection to JPL been done ...... if not, terminate!
      IF (.NOT.LPRO(JPL)) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF1,IERR)
         RETURN
      ENDIF

* Has filtering already been done at this plane? Continue anyway .... !?
      IF (LFIL(JPL)) CALL FKERR(IUTIL,IROUT,IWARN,IDONE,IERR)

**********************************************************************
*
* If no measurement has been made at JPL, then the filtered vector and
* its covariance are the same as the projected vector and covariance.
* The residuals, covariances and chi-squared are set to zero. This is
* not strictly necessary, but it makes things neater.
*
      IF (.NOT.LMES(JPL)) THEN
         CALL UCOPY(SPRO(1,JPL),SFIL(1,JPL),10)
         CALL FKCOPY(CPRO(1,1,JPL),CFIL(1,1,JPL))
         IF (LRPRO) THEN
            CALL VZERO(RPRO(1,JPL),4)
            CALL VZERO(CRPRO(1,1,JPL),8)
         ENDIF
         IF (LRFIL) THEN
            CALL VZERO(RFIL(1,JPL),4)
            CALL VZERO(CRFIL(1,1,JPL),8)
            CHIFIL(JPL) = 0.D0
         ENDIF
         LFIL(JPL) = .TRUE.
         RETURN
      ENDIF

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

* Invert CMES
      CALL FKINV(MES(JPL),CMES(1,1,JPL),GMES,IFAIL)
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IMCV,IERR)
         RETURN
      ENDIF

* Compute the filtered (weighted average) covariance
      IF (MES(JPL).EQ.1) THEN
         CALL FKCOVP(CPRO(1,1,JPL),HMES(1,1,JPL),GMES,
     &               CFIL(1,1,JPL),WT,IFAIL)
      ELSE
         CALL FKCOVR(CPRO(1,1,JPL),HMES(1,1,JPL),GMES,
     &               CFIL(1,1,JPL),WT,IFAIL)
      ENDIF
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF

* Compute the filtered state vector
      CALL FKWMES(MES(JPL),HMES(1,1,JPL),GMES,WMES(1,JPL),HGW)
      CALL FKWVEC(SPRO(1,JPL),WT,CFIL(1,1,JPL),HGW,SFIL(1,JPL))
      CALL FKNORM(SFIL(1,JPL),IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GT.100) RETURN

* Calculate the residuals of the prediction
      IF (LRPRO) CALL FKLRSD(JPL,SPRO(1,JPL),CPRO(1,1,JPL),2,
     &                       RPRO(1,JPL),CRPRO(1,1,JPL),CHIPRO,IFAIL)

* Calculate the filtered residuals
      IF (LRFIL) THEN
         CALL FKLRSD(JPL,SFIL(1,JPL),CFIL(1,1,JPL),-3,
     &               RFIL(1,JPL),CRFIL(1,1,JPL),CHIFIL(JPL),IFAIL)
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
      ENDIF

* Set the flag to show filter has been done
      LFIL(JPL) = .TRUE.

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  2.07/01 18/07/91  00.17.48  by  Stephen Burke
*-- Author : S Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLFTR(IERR)
**********************************************************************
*                                                                    *
* Kalman fit with removal of the initial state vector                *
*                                                                    *
* Calling sequence is as for FKLFIT                                  *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*                                                                    *
*       IERR =   0      ; normal termination                         *
*   ->  IERR = 101      ; no starting point was provided             *
*   ->  IERR = 102      ; not enough measurements to fit             *
*   ->  IERR = 103      ; invalid value in MES array                 *
*   ->  IERR = 104      ; invalid value of JSTART, JSTOP or JLAST    *
*       IERR =   8      ; covariance n.p.d. in FKLWM (1st call)      *
*       IERR =   9      ; covariance n.p.d. in FKLWM (2nd call)      *
*       IERR =  20 +  n ; 2 < n < 10 iterations in point rejection   *
*   ->  IERR = 130      ; 10 iterations in point rejection           *
*       IERR =  30 +  n ; 2 < n < 10 iterations over fit sections    *
*   ->  IERR = 140      ; 10 iterations over fit sections            *
*       IERR =  40 +  n ; 1 < n < 10 restarts                        *
*   ->  IERR = 150      ; 10 restarts                                *
*   ->  IERR = 200 + ee ; fatal error ee from FKLPRO                 *
*   ->  IERR = 300 + ee ; fatal error ee from FKLFIL                 *
*   ->  IERR = 400 + ee ; fatal error ee from FKLSMO                 *
*   ->  IERR = 500 + ee ; fatal error ee from FKLPRS                 *
*   ->  IERR = 600 + ee ; fatal error ee from FKLPAS                 *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=10)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKPROJ.
*KEEP,FKFILT.
*KEEP,FKSMTH.
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKTRUE.
*KEEP,FKINT.
*KEND.

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

      LOGICAL LFIXUP
      DIMENSION STEMP(5),CTEMP(5,5)

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

      IERR = 0

* Remember values of parameters which will be changed
      KSTART = JSTART
      KSTOP  = JSTOP
      KLAST  = JLAST
      CALL UCOPY(SPRO(1,JSTART),STEMP,10)
      CALL FKCOPY(CPRO(1,1,JSTART),CTEMP)

* Initialise flags
      LFIRST = .TRUE.
      LFIXUP = .FALSE.
      NTRY   = 1

* Re-entry point for re-starts
 1000 CONTINUE

* These need to be re-set for each pass
      NSEC   = 1
      JEND   = JLAST
      JBEGIN = JSTOP

* Set the stop point to the start point
      JSTOP = JSTART

* Switch off residuals and point rejection for the first pass
      CALL FKPRSV(1)
      CALL FKLFIT(IFAIL)
      CALL FKPRSV(-1)
* Check errors
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GT.100) GOTO 7000

* If this is getting too complicated, start again from scratch!
      IF (LFIXUP .AND. NPASS.GT.1) GOTO 9000

* Now loop over the two sections until no points are altered
      ISEC = 1
 2000 CONTINUE
      ISEC = -ISEC

* Remove the initial vector (to create a FILTERED vector)
      CALL FKLWM(-1,SSMT(1,JSTART),CSMT(1,1,JSTART),SPRO(1,JSTART),
     &        CPRO(1,1,JSTART),SFIL(1,JSTART),CFIL(1,1,JSTART),IFAIL)

* If the vector can't be removed we have a serious problem
      IF (IFAIL.GT.100) THEN
         CALL FKERR(IUTIL,IROUT,IWARN,IOCV+(ISEC-5)/2,IERR)
* If we've rejected some points, start again from the beginning
         IF (NSEC.GT.2) GOTO 9000
* First part is OK, so do half of the filter the other way round
         IF (ISEC.EQ.1) GOTO 8000
* If it happens at the start, leave the initial vector in and carry on
         CALL UCOPY(SSMT(1,JSTART),SFIL(1,JSTART),10)
         CALL FKCOPY(CSMT(1,1,JSTART),CFIL(1,1,JSTART))
      ENDIF

* Change direction
      JSTEP = -JSTEP

* We've filtered at this point, so project into the other section
      LPRO(JSTART+JSTEP) = .FALSE.
      DZPL(JSTART) = ZPL(JSTART+JSTEP) - ZPL(JSTART)
      CALL FKLPRO(JSTART,IFAIL)
      IF (IFAIL.GT.100) THEN
         CALL FKERR(IUTIL,IROUT,IFPRO,IFAIL,IERR)
         GOTO 7000
      ENDIF

* Flip the start and end points, and filter the other section
      IF (ISEC.EQ.1) THEN
         JLAST = JEND
      ELSE
         JLAST = JBEGIN
      ENDIF
      JSTART = JSTART + JSTEP
      JSTOP  = JSTART

      CALL FKLFIT(IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GT.100) GOTO 7000

* We've been once over every plane, so don't zero IRJCT again
      LFIRST = .FALSE.

* If NPASS is > 1 we rejected some points, so quit and start again
      IF (LFIXUP .AND. NPASS.GT.1) GOTO 9000

* If no point was rejected, and this isn't the first time, that's all
      IF (LFIXUP) THEN
* Don't change error code
         IF (NTRY.GT.1) CALL FKERR(IUTIL,IROUT,IWARN,IFREE2+NTRY,IER)
* Restore the saved vectors
         CALL FKSAVE(-1,JBEGIN,JSTART-JSTEP)
      ELSEIF (NPASS.EQ.1 .AND. NSEC.GT.1) THEN
* Pass back code 11 if it occurred
         IER = 0
         IF (NSEC.GT.2) CALL FKERR(IUTIL,IROUT,IWARN,IFREE1+NSEC,IER)
         IF (NTRY.GT.1) CALL FKERR(IUTIL,IROUT,IWARN,IFREE2+NTRY,IER)
         IF (IERR.NE.IOCV .AND. IER.GT.0) IERR = IER
      ELSE
         NSEC = NSEC + 1
         IF (NSEC.LT.10) GOTO 2000
         IF (NTRY.GT.1) CALL FKERR(IUTIL,IROUT,IWARN,IFREE2+NTRY,IERR)
         CALL FKERR(IUTIL,IROUT,IFATAL,IFREE2,IERR)
      ENDIF

 7000 CONTINUE

* Reset the end-point flags so we don't screw up the calling routine
      JSTART = KSTART
      JSTOP  = KSTOP
      JLAST  = KLAST

      RETURN

 8000 CONTINUE

*
* We get here if FKLWM fails on the second removal
* The fixup is to do half of the filter the other way round
*

      LFIXUP = .TRUE.

* Save the smoothed vectors/residuals between JSTART and JLAST
      CALL FKSAVE(1,JSTART,JLAST)

* Reset the starting values, and start again
      JSTART = KSTART
      JSTOP  = KLAST
      JLAST  = KSTOP

      GOTO 1000

* This resets everything and starts again
 9000 CONTINUE

      NTRY = NTRY + 1
      IF (NTRY.GE.10) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IFREE3,IERR)
         GOTO 7000
      ENDIF

      CALL UCOPY(STEMP,SPRO(1,JSTART),10)
      CALL FKCOPY(CTEMP,CPRO(1,1,JSTART))
      LFIXUP = .FALSE.

      JSTART = KSTART
      JSTOP  = KSTOP
      JLAST  = KLAST

      GOTO 1000

      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.30  by  Stephen Burke
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLFXY(SPRO,CPRO,WMES,CMES,SFIL,CFIL,CHISQ,IERR)
**********************************************************************
*                                                                    *
* Kalman Filter an x/y point                                         *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 107 ; failure to invert measurement covariance        *
*   ->  IERR = 111 ; failure to invert filtered covariance           *
*       IERR =  12 ; covariance of filtered residuals n.p.d.         *
*   ->  IERR = 116 ; x, y or theta has silly value                   *
*       IERR =  17 ; tan(theta) > 1 (warning)                        *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* NB Error 12 is not considered fatal, but the chi-sq will be zero   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=12)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION SPRO(5),CPRO(5,5),WMES(2),CMES(2,2),SFIL(5),CFIL(5,5)
      DIMENSION GMES(2,2),WT(2,5),GW(2)

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

      IERR = 0

* Invert CMES
      DET = (CMES(1,1)*CMES(2,2) - CMES(2,1)*CMES(2,1))
      IF (DET.LE.0.D0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IMCV,IERR)
         RETURN
      ENDIF
      DET = 1.D0/DET
      GMES(1,1) =  CMES(2,2)*DET
      GMES(2,1) = -CMES(2,1)*DET
      GMES(2,2) =  CMES(1,1)*DET

* Compute the filtered (weighted average) covariance
      CALL FKCVXY(CPRO,GMES,CFIL,WT,IFAIL)
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF

* Compute the filtered state vector
      GW(1) = GMES(1,1)*WMES(1) + GMES(2,1)*WMES(2)
      GW(2) = GMES(2,1)*WMES(1) + GMES(2,2)*WMES(2)
      CALL FKWVEC(SPRO,WT,CFIL,GW,SFIL)
      CALL FKNORM(SFIL,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

* Calculate the chi**2
      CHISQ = FKCHXY(WMES,CMES,SFIL,CFIL,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.45.11  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      LOGICAL FUNCTION FKLOOK(JPL,S,C,IERR)
*-----------------------------------------Updates 07/02/92-------
**: FKLOOK 30205.SB. Initialise IFAIL1 to please UNDEF.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Look at a point we've already rejected, to see whether it now fits *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ; normal termination                             *
*   ->  IERR = 103  ; LMES(JPL) already set                          *
*       IERR =  12  ; covariance of residuals n.p.d.                 *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
* Note that both errors cause .FALSE. to be returned as the          *
* function value, and no changes to be made to the measurement       *
* arrays.                                                            *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=7)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEND.

      DIMENSION S(5),C(5,5),RES(2),CRES(2,2)

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

      IERR   = 0
      FKLOOK = .FALSE.

* If LMES is still set we don't want to add it again
      IF (LMES(JPL)) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF3,IERR)
         RETURN
      ENDIF

* This point was previously rejected; see if we want to put it back
      LMES(JPL) = .TRUE.
      IFAIL  = 0
      IFAIL1 = 0
      CALL FKLRSD(JPL,S,C,3,RES,CRES,CHISQ,IFAIL)
* NB IFAIL1 not currently checked
      IF (IFAIL.NE.0 .OR. CHISQ.GE.FKCHPR(3,MES(JPL),IFAIL1)) THEN
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
         LMES(JPL) = .FALSE.
         RETURN
      ENDIF

* Record the statistics
      IF (IRJCT(JPL).EQ.3) THEN
         NUNRJB(JPL) = NUNRJB(JPL) + 1
      ELSE
         NUNRJP(JPL) = NUNRJP(JPL) + 1
      ENDIF

* Flag point so that it won't be tried again
      IRJCT(JPL) = -1

      FKLOOK = .TRUE.

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  3.03/01 27/04/92  16.17.41  by  Stephen Burke
*-- Author : Stephen Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLPAF(JPL,IERR)
*-----------------------------------------Updates 27/04/92-------
**: FKLPAF.......SB. Error message description updated.
*-----------------------------------------Updates 07/02/92-------
**: FKLPAF 30205.SB. Initialise IFAIL to please UNDEF.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Point acquisition during filtering (at plane JPL)                  *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ; normal termination                             *
*   ->  IERR =   1  ; projected vector missing or invalid prob cut   *
*   ->  IERR =   3  ; invalid value in MES array                     *
*   ->  IERR =   4  ; invalid value in MES array, or internal error  *
*       IERR =  12  ; covariance of residuals not positive definite  *
*                                                                    *
*   ->  `Fatal' error                                                *
*                                                                    *
* `Fatal' means that a serious problem occurred, but all errors      *
* are recoverable as no changes are made.                            *
*                                                                    *
* Error codes from FKHUNT are passed back unchanged, but these are   *
* not yet defined.                                                   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FKHUNT

      PARAMETER (IUTIL=0,IROUT=16)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKPROJ.
*KEND.

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

      IERR = 0

      IF (.NOT.LPRO(JPL)) THEN
         CALL FKERR(IUTIL,IROUT,IWARN,IINF1,IERR)
         RETURN
      ENDIF

      NCPAS = NCPAS + 1

* See if there's a new digi
      IFAIL = 0
      IF (FKHUNT(JPL,SPRO(1,JPL),CPRO(1,1,JPL),IFAIL))
     &                            NNEWP(JPL) = NNEWP(JPL) + 1
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.50  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLPAS(JPL,NDROP,IERR)
**********************************************************************
*                                                                    *
* Point acquisition during smoothing (at plane JPL)                  *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ; normal termination                             *
*   ->  IERR =   1  ; smoothed vector missing                        *
*   ->  IERR =   2  ; LMES(JPL) set on entry, but IRJCT(JPL) > 1     *
*   ->  IERR =   3  ; LMES(JPL) not set by FKLOOK or FKHUNT          *
*   ->  IERR =   4  ; internal error (IFLAG=0 in call to FKLRFL)     *
*       IERR =   7  ; measurement covariance n.p.d. (not added)      *
*       IERR =  11  ; smoothed covariance n.p.d. (not added)         *
*       IERR =  12  ; covariance of smoothed residuals n.p.d.        *
*       IERR =  16  ; theta > pi/2 (reset to pi/4)                   *
*       IERR =  17  ; theta > 1 (warning)                            *
*                                                                    *
*   ->  `Fatal' error                                                *
*                                                                    *
* `Fatal' means that a serious problem occurred, but all errors      *
* are recoverable as no changes are made.                            *
*                                                                    *
* Error codes from FKHUNT are passed back unchanged, but these are   *
* not yet defined.                                                   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL FKLOOK,FKHUNT

      PARAMETER (IUTIL=0,IROUT=9)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEND.

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

      IERR = 0

      IF (.NOT.LSMT(JPL)) THEN
         CALL FKERR(IUTIL,IROUT,IWARN,IINF1,IERR)
         RETURN
      ENDIF

      NCPAS = NCPAS + 1

*
* See if there's a new digi - first look for a completely new one ...
* (If there's already a measurement, there may be a problem. FKHUNT
* should check for this, and unhook the existing measurement if
* necessary.)
*
      IFAIL = 0
      IF (.NOT.FKHUNT(JPL,SSMT(1,JPL),CSMT(1,1,JPL),IFAIL)) THEN
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
*
* No luck, so if a point was previously rejected here, see if it
* can go back again (but don't try more than once).
* If NDROP = JPL we just rejected this point, so don't try to
* put it back!
*
         IF (NDROP.EQ.JPL .OR. IRJCT(JPL).LE.1) RETURN
* LMES(JPL) should not be set if IRJCT(JPL) is positive
         IF (LMES(JPL)) THEN
            CALL FKERR(IUTIL,IROUT,IWARN,IINF3,IERR)
            RETURN
         ENDIF
         IF (.NOT.FKLOOK(JPL,SSMT(1,JPL),CSMT(1,1,JPL),IFAIL)) RETURN
      ENDIF

      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
* This shouldn't happen!
      IF (IFAIL.GT.100) RETURN

*
* A new point has been found, so put it in
*
      CALL FKLRFL(JPL,2,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

      IF (LRSMT) THEN
         CALL FKLRSD(JPL,SSMT(1,JPL),CSMT(1,1,JPL),-3,
     &               RSMT(1,JPL),CRSMT(1,1,JPL),CHISMT(JPL),IFAIL)
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
      ENDIF

      IF (LTRUE) THEN
         CALL FKRST(JPL,IFAIL)
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
      ENDIF

* Only count a genuinely new point
      IF (IRJCT(JPL).EQ.0) NNEWP(JPL) = NNEWP(JPL) + 1

      NDROP = JPL

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  2.01/03 18/02/91  10.45.16  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLPRO(JPL,IERR)
**********************************************************************
*                                                                    *
* Project the state vector and its covariance from plane JPL to      *
* plane JPL+1, including multiple scattering.                        *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 101 ; no filtered vector at JPL                       *
*       IERR =   5 ; projection to JPL+1 already done                *
*   ->  IERR = 111 ; failure to invert projected covariance          *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=2)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*
* Common block definitions
*
*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKPROJ.
*KEEP,FKFILT.
*KEEP,FKINT.
*KEND.

**********************************************************************
*
* Local arrays etc ...
*
      DIMENSION D(5,5)

**********************************************************************
*
* Initialisation and checks ....
*
      IERR = 0

      IF (.NOT.LFIL(JPL)) THEN
* no filtered data at plane JPL ... terminate!
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF1,IERR)
         RETURN
      ENDIF

* Number of next plane
      JPLN = JPL + JSTEP

* Projection has already been made .... but do it anyway!
      IF (LPRO(JPLN)) CALL FKERR(IUTIL,IROUT,IWARN,IDONE,IERR)

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

* Transform the state vector and covariance from JPL to JPL+1 ...
      CALL FKTRAN(DZPL(JPL),ZPL(JPL),SFIL(1,JPL),SPRO(1,JPLN),D)
      CALL FKMUL(CFIL(1,1,JPL),D,CPRO(1,1,JPLN))

* RADL and LRAD are defined in an asymmetrical way
      JPLR = JPL + (JSTEP-1)/2

      IF (LRAD(JPLR)) THEN
* Compute the MS matrix
         CALL FKSCAT(DZPL(JPL),SFIL(1,JPL),RADL(JPLR),D,QPRO(1,1,JPL))
* ... and add to the projected error matrix
         CALL FKQADD(CPRO(1,1,JPLN),QPRO(1,1,JPL))
* Calculate QGAIN for the smoother
         CALL FKQG(CPRO(1,1,JPLN),QPRO(1,1,JPL),QGAIN(1,1,JPL),IFAIL)
         IF (IFAIL.NE.0) THEN
            CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
            RETURN
         ENDIF
      ENDIF

* Projection is complete
      LPRO(JPLN) = .TRUE.

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.49  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLPRS(JPL,NDROP,IERR)
**********************************************************************
*                                                                    *
* Point rejection during smoothing (at plane JPL)                    *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ; normal termination                             *
*  (->) IERR = 101  ; smoothed vector missing                        *
*   ->  IERR = 102  ; projected vector missing                       *
*       IERR =   3  ; end plane of block was skipped                 *
*       IERR =   4  ; LPOINT and LBLOCK both .FALSE.                 *
*       IERR =   5  ; internal error (bad call to FKLSMO)            *
*       IERR =  11  ; smoothed covariance n.p.d.                     *
*       IERR =  12  ; covariance of smoothed residuals n.p.d.        *
*       IERR =  16  ; theta > pi/2 (reset to pi/4)                   *
*       IERR =  17  ; theta > 1 (warning)                            *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
* Error code 1 is only fatal if generated in FKLSMO during the       *
* removal of a block of points. It can also be generated in FKLRFL,  *
* but is treated as a warning in this case.                          *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=8)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEND.

      SAVE JBPL
      DATA JBPL/0/

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

      IERR = 0

      IF (.NOT.LPOINT .AND. .NOT.LBLOCK) THEN
         CALL FKERR(IUTIL,IROUT,IWARN,IINV,IERR)
         RETURN
      ENDIF

*
* Just count calls on the first pass (not quite right, but closer than
* counting all calls)
*
      IF (NPASS.EQ.1) NCPRS = NCPRS + 1

*
* If smoothed residual has poor chisquared, reject the plane ...
* (but only if this has been requested)
* Also try again to get rid of it if it was flagged on a previous pass.
* This clause is a bit of a monster, but I think it's all needed!
* The error condition from FKCHPR is not currently checked; an error
* can only occur if X2PCUT has a silly value, in which case every point
* will be kept.
*
      IFAIL = 0
      IF (((LPOINT .OR. LWIRE(JPL)) .AND. LMES(JPL) .AND.
     &                  CHISMT(JPL).GT.FKCHPR(1,MES(JPL),IFAIL))
     &                     .OR. IRJCT(JPL).LE.-2) THEN
         CALL FKLRFL(JPL,-2,IFAIL)
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
         IF (IFAIL.LT.100) THEN
            IF (IRJCT(JPL).LT.0) THEN
* We've tried this one before
               IF (IRJCT(JPL).EQ.-1) THEN
                  NRERJP(JPL) = NRERJP(JPL) + 1
               ELSEIF (IRJCT(JPL).EQ.-2) THEN
                  NFAILP(JPL) = NFAILP(JPL) - 1
                  NBADP(JPL) = NBADP(JPL) + 1
               ELSE
                  NFAILB(JPL) = NFAILB(JPL) - 1
                  NBADB(JPL) = NBADB(JPL) + 1
               ENDIF
               IRJCT(JPL) = ABS(IRJCT(JPL))
            ELSE
               IRJCT(JPL) = 2
               NBADP(JPL) = NBADP(JPL) + 1
            ENDIF
            NDROP = JPL
            LMES(JPL) = .FALSE.
            CALL VZERO(RSMT(1,JPL),4)
            CALL VZERO(CRSMT(1,1,JPL),8)
            CHISMT(JPL) = 0.D0
            IF (LTRUE) THEN
               CALL FKRST(JPL,IFAIL)
               IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
            ENDIF
         ELSEIF (IRJCT(JPL).GE.0) THEN
            IRJCT(JPL) = -2
            NFAILP(JPL) = NFAILP(JPL) + 1
         ENDIF
      ENDIF

      IF (.NOT.LBLOCK) RETURN

*
* Accumulate the chi-sq and ndf for a block of planes
*

      IF (NBLOCK(JPL).GT.0) THEN
* This is the start of a block
         JBPL = JPL
         NBPRS = NBPRS + 1
         IF (LMES(JPL)) THEN
            CHITOT(JPL) = CHISMT(JPL)
            NDF(JPL) = MES(JPL)
         ELSE
            CHITOT(JPL) = 0.D0
            NDF(JPL) = 0
         ENDIF
         RETURN
      ENDIF

* Is this wire in a block?
      IF (JBPL.LE.0) RETURN

      IF (NPASS.EQ.1) NBPRS = NBPRS + 1

* Increment the chisq
      IF (LMES(JPL)) THEN
         CHITOT(JBPL) = CHITOT(JBPL) + CHISMT(JPL)
         NDF(JBPL) = NDF(JBPL) + MES(JPL)
      ENDIF

* Check for last wire
      IF (NBLOCK(JBPL).GT.ABS(JBPL-JPL)) RETURN

* This is the end, so unset JBPL (but the value is still needed)
      KBPL = JBPL
      JBPL = 0

      IF (NBLOCK(KBPL).LT.ABS(KBPL-JPL)) THEN
* Some kind of error - we've gone past the end of the block
         CALL FKERR(IUTIL,IROUT,IWARN,IINF3,IERR)
         RETURN
      ENDIF

* Check against chi-squared cut
      IF (NDF(KBPL).LE.0 .OR.
     &            CHITOT(KBPL).LT.FKCHPR(2,NDF(KBPL),IFAIL)) RETURN

* Remove the block
      DO 200 LPL=KBPL,JPL,-JSTEP
         IF (LMES(LPL)) THEN
            CALL FKLRFL(LPL,-2,IFAIL)
            IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
            IF (IFAIL.LT.100) THEN
               IF (IRJCT(LPL).EQ.-1) THEN
                  NRERJP(LPL) = NRERJP(LPL) + 1
                  IRJCT(LPL)  = 1
               ELSE
                  IRJCT(LPL)  = 3
                  NBADB(LPL)  = NBADB(LPL) + 1
               ENDIF
               NDROP     = LPL
               LMES(LPL) = .FALSE.
            ELSEIF (IRJCT(LPL).GE.0) THEN
               NDROP      = LPL
               NBADB(LPL) = NBADB(LPL) + 1
               LMES(LPL)  = .FALSE.
            ELSE
               IRJCT(JPL)  = -3
               NFAILB(LPL) = NFAILB(LPL) + 1
            ENDIF
         ENDIF
* Re-smooth
         IF (LPL.NE.JPL) THEN
            LSMT(LPL-JSTEP)=.FALSE.
            CALL FKLSMO(LPL-JSTEP,IFAIL)
            IF (IFAIL.NE.0)
     &         CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
            IF (IERR.GT.100) RETURN
         ELSE
            CALL VZERO(RSMT(1,JPL),4)
            CALL VZERO(CRSMT(1,1,JPL),8)
            CHISMT(JPL) = 0.D0
            IF (LTRUE) THEN
               CALL FKRST(JPL,IFAIL)
               IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
            ENDIF
         ENDIF
 200  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.24  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.28  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLRFL(JPL,IFLAG,IERR)
**********************************************************************
*                                                                    *
* Reverse Kalman Filter used to add or remove a measurement          *
* at plane JPL                                                       *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 101 ; no smoothed vector at JPL                       *
*   ->  IERR = 103 ; no measurement at JPL                           *
*   ->  IERR = 104 ; invalid value of IFLAG                          *
*   ->  IERR = 107 ; failure to invert measurement covariance        *
*   ->  IERR = 111 ; failure to invert filtered covariance           *
*   ->  IERR = 116 ; theta > pi/2 (reset to pi/4)                    *
*       IERR =  17 ; theta > 1 (warning)                             *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* NB All fatal errors result in the update not being made, and are   *
* therefore recoverable                                              *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=5)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*
* Common block definitions
*
*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKSMTH.
*KEND.

**********************************************************************
*
* Local arrays ...
*
      DIMENSION HGW(2),WT(2,5),GMES(2,2)

**********************************************************************
*
* Initialisation and checks ...
*
      IERR = 0

* Has smoothing to JPL been done ...... if not, terminate!
      IF (.NOT.LSMT(JPL)) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF1,IERR)
         RETURN
      ENDIF

* If no measurement has been made at JPL, then terminate
      IF (.NOT.LMES(JPL)) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF3,IERR)
         RETURN
      ENDIF

* IFLAG should not be zero
      IF (IFLAG.EQ.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINV,IERR)
         RETURN
      ENDIF

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

* Invert CMES ...
      CALL FKINV(MES(JPL),CMES(1,1,JPL),GMES,IFAIL)
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IMCV,IERR)
         RETURN
      ENDIF

*
* If IFLAG is negative the point is being filtered out, so
* negate the (inverse of the) measurement covariance
*
      IF (IFLAG.LT.0) THEN
         GMES(1,1) = -GMES(1,1)
         GMES(2,1) = -GMES(2,1)
         GMES(2,2) = -GMES(2,1)
      ENDIF

*
* Compute the covariance
*
      IF (MES(JPL).EQ.1) THEN
         CALL FKCOVP(CSMT(1,1,JPL),HMES(1,1,JPL),GMES,
     &               CSMTR(1,1,JPL),WT,IFAIL)
      ELSE
         CALL FKCOVR(CSMT(1,1,JPL),HMES(1,1,JPL),GMES,
     &               CSMTR(1,1,JPL),WT,IFAIL)
      ENDIF
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF

* Compute the filtered state vector
      CALL FKWMES(MES(JPL),HMES(1,1,JPL),GMES,WMES(1,JPL),HGW)
      CALL FKWVEC(SSMT(1,JPL),WT,CSMTR(1,1,JPL),HGW,SSMTR(1,JPL))
      CALL FKNORM(SSMTR(1,JPL),IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

      IF (ABS(IFLAG).GT.1) THEN
* Copy the filtered vector and its covariance back into /FKSMTH/
         CALL UCOPY(SSMTR(1,JPL),SSMT(1,JPL),10)
         CALL FKCOPY(CSMTR(1,1,JPL),CSMT(1,1,JPL))
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.45.12  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLRSD(JPL,S,C,IFLAG,RES,CRES,CHI,IERR)
*-----------------------------------------Updates 24/01/92-------
**: FKLRSD 30205.SB. Trap overflows.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Calculate residuals and chi-squared                                *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*       IERR =   3 ; no measurement at this plane                    *
*   ->  IERR = 112 ; CRES not positive definite                      *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=7)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*
* Common block definitions
*
*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEND.

**********************************************************************
*
* Local arrays ...
*
      DIMENSION S(5),C(5,5),RES(2),CRES(2,2)

**********************************************************************
*
* Initialisation and checks ...
*
      IERR=0

      CHI = 0.D0

      IF (.NOT.LMES(JPL)) THEN
         CALL VZERO(RES,4)
         CALL VZERO(CRES,8)
         CALL FKERR(IUTIL,IROUT,IWARN,IINF3,IERR)
         RETURN
      ENDIF

**********************************************************************
*
* Calculate the residuals
*
      RES(1) = WMES(1,JPL) - HMES(1,1,JPL)*S(1)
     &                     - HMES(1,2,JPL)*S(2)
      IF (MES(JPL).EQ.2) RES(2) = WMES(2,JPL) - HMES(2,1,JPL)*S(1)
     &                                        - HMES(2,2,JPL)*S(2)

      IF (ABS(IFLAG).LE.1) RETURN

*
* and the covariance
*
      IF (IFLAG.GT.0) THEN
         SIGN = 1.D0
      ELSE
         SIGN = 0.D0
C         SIGN=-1.D0
      ENDIF

      A = CMES(1,1,JPL) + SIGN*((HMES(1,1,JPL)*C(1,1)
     &                      + 2.*HMES(1,2,JPL)*C(2,1))*HMES(1,1,JPL)
     &                      +    HMES(1,2,JPL)*C(2,2) *HMES(1,2,JPL))
      CRES(1,1) = A
      IF (MES(JPL).EQ.2) THEN
         HC1 = HMES(2,1,JPL)*C(1,1) + HMES(2,2,JPL)*C(2,1)
         HC2 = HMES(2,1,JPL)*C(2,1) + HMES(2,2,JPL)*C(2,2)
         B = CMES(2,1,JPL)
     &     + SIGN*(HC1*HMES(1,1,JPL) + HC2*HMES(1,2,JPL))
         D = CMES(2,2,JPL)
     &     + SIGN*(HC1*HMES(2,1,JPL) + HC2*HMES(2,2,JPL))
         CRES(2,1) = B
         CRES(1,2) = B
         CRES(2,2) = D
      ENDIF

      IF (ABS(IFLAG).LE.2) RETURN

*
* and the chi-squared
*

      IF (ABS(A).GT.1.0D10.OR.ABS(B).GT.1.0D10.OR.ABS(D).GT.1.0D10) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IRCV,IERR)
         RETURN
      ENDIF

      IF (MES(JPL).EQ.1) THEN
         DET = A
      ELSE
         DET = (A*D-B*B)
      ENDIF
      IF (A.GT.0.D0 .AND. DET.GT.0.D0) THEN
         IF (MES(JPL).EQ.1) THEN
            CHI = RES(1)**2/DET
         ELSE
            CHI = (RES(1)*(D*RES(1) - 2*B*RES(2)) + A*RES(2)**2)/DET
         ENDIF
      ELSE
         CALL FKERR(IUTIL,IROUT,IFATAL,IRCV,IERR)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  2.01/03 18/02/91  10.50.39  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLSMO(JPL,IERR)
**********************************************************************
*                                                                    *
* Kalman Smoothing from plane JPL+1 to plane JPL.                    *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ;  normal termination                            *
*   ->  IERR = 101  ;  no smoothed data at plane JPL+1               *
*   ->  IERR = 102  ;  no projected data at plane JPL+1              *
*       IERR =   5  ;  smoothing already done ... but continue       *
*       IERR =  11  ;  smoothed covariance matrix n.p.d.             *
*       IERR =  12  ;  covariance of smoothed residuals n.p.d.       *
*       IERR = 116  ;  theta > pi/2: reset to pi/4                   *
*       IERR =  17  ;  theta > 1 (warning)                           *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* NB Error 12 is not considered fatal, but the chi-sq will be zero   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=4)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*
* Common block definitions
*
*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKTRUE.
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKPROJ.
*KEEP,FKFILT.
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKINT.
*KEND.

**********************************************************************
*
* Local arrays etc ...
*
      DIMENSION SADJ(5),DINV(5,5),AGAIN(5,5)

**********************************************************************
*
* Initialisation and checks ...
*
      IERR = 0

* If JPL=JLAST then Smoothed is same as Filtered ...
      IF (JPL.EQ.JLAST) THEN
* Does filtered data exist at plane JPL ?
         IF (.NOT.LFIL(JPL)) THEN
            CALL FKERR(IUTIL,IROUT,IFATAL,IINF1,IERR)
            RETURN
         ENDIF
         CALL UCOPY(SFIL(1,JPL),SSMT(1,JPL),10)
         CALL FKCOPY(CFIL(1,1,JPL),CSMT(1,1,JPL))
         GOTO 600
      ENDIF

* Number of next plane
      JPLN = JPL + JSTEP

* Does smoothed data exist at previous plane?
      IF (.NOT.LSMT(JPLN)) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF1,IERR)
         RETURN
      ENDIF

* RADL and LRAD are defined in an asymmetrical way
      JPLR = JPL + (JSTEP-1)/2

* Does projected data exist at previous plane? (only needed with MS)
      IF (LRAD(JPLR) .AND. .NOT.LPRO(JPLN)) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IINF2,IERR)
         RETURN
      ENDIF

* Has smoothing to JPL already been done? Continue anyway ..... !?
      IF (LSMT(JPL)) CALL FKERR(IUTIL,IROUT,IWARN,IDONE,IERR)

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

      IF (LRAD(JPLR)) THEN
*
* Update the smoothed state vector at plane JPL+1 by removing the
* estimated multiple scattering between planes JPL and JPL+1;
* I think that this is probably the most `correct' way to do it.
* If there is no multiple scattering QGAIN is zero, so this can be
* skipped. Then transform the adjusted state vector from JPL+1 to JPL.
*
         CALL FKADJ(SSMT(1,JPLN),SPRO(1,JPLN),QGAIN(1,1,JPL),SADJ)
         CALL FKNORM(SADJ,IFAIL)
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
         IF (IFAIL.GE.100) RETURN
         CALL FKTRAN(-DZPL(JPL),ZPL(JPLN),SADJ,SSMT(1,JPL),DINV)
*
* Compute the smoothed covariance. This may be numerically unstable if
* the multiple scattering is large (probably not the case).
*
         CALL FKDMQD(DINV,QGAIN(1,1,JPL),AGAIN)
         CALL FKMXM(CSMT(1,1,JPLN),AGAIN,CSMT(1,1,JPL))
         CALL FKDQA(DINV,QPRO(1,1,JPL),AGAIN,CSMT(1,1,JPL))
      ELSE
* If there is no MS, smoothing is just back-extrapolation
* Transform the state vector and covariance from JPL to JPL+1 ...
         CALL FKTRAN(-DZPL(JPL),ZPL(JPLN),SSMT(1,JPLN),
     &                                    SSMT(1,JPL),DINV)
         CALL FKMUL(CSMT(1,1,JPLN),DINV,CSMT(1,1,JPL))
      ENDIF

      CALL FKNORM(SSMT(1,JPL),IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

  600 CONTINUE

      IF (LTRUE) THEN
         CALL FKRST(JPL,IFAIL)
         IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
      ENDIF

      IF (LRSMT) THEN
         IF (LMES(JPL)) THEN
            CALL FKLRSD(JPL,SSMT(1,JPL),CSMT(1,1,JPL),-3,
     &               RSMT(1,JPL),CRSMT(1,1,JPL),CHISMT(JPL),IFAIL)
            IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
         ELSE
            CALL VZERO(RSMT(1,JPL),4)
            CALL VZERO(CRSMT(1,1,JPL),8)
            CHISMT(JPL) = 0.D0
         ENDIF
      ENDIF

* Set flag to show smoothing is done
      LSMT(JPL) = .TRUE.

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.52  by  Girish D. Patel
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLSPR(SFIL,CFIL,Z,DZ,RADL,QPRO,QGAIN,SPRO,CPRO,IERR)
**********************************************************************
*                                                                    *
* Translate a state vector and its covariance, including multiple    *
* scattering (simple version of FKLPRO)                              *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 111 ; failure to invert projected covariance          *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=11)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION SFIL(5),CFIL(5,5),QPRO(5,5),QGAIN(5,5)
     &,         SPRO(5),CPRO(5,5)
      DIMENSION DTRAN(5,5)

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

      IERR = 0

* Transform the state vector and covariance from Z to Z+DZ
      CALL FKTRAN(DZ,Z,SFIL,SPRO,DTRAN)
      CALL FKMUL(CFIL,DTRAN,CPRO)

* Compute the MS matrix and add to the projected error matrix
      CALL FKSCAT(DZ,SFIL,RADL,DTRAN,QPRO)
      CALL FKQADD(CPRO,QPRO)

* Calculate QGAIN for the smoother
      CALL FKQG(CPRO,QPRO,QGAIN,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.45.13  by  Curtis A. Meyer
*-- Author : Stephen Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLSSM(Z,DZ,SVEC,CVEC,SPRO,QGAIN,QPRO,SSMT,CSMT,IERR)
*-----------------------------------------Updates 07/02/92-------
**: FKLSSM 30205.SB. Remove unused FKECODE sequence.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Simple Kalman Smoothing                                            *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*       IERR = 116 ; x, y or theta has silly value                   *
*       IERR =  17 ; tan(theta) > 1 (warning)                        *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=13)

      DIMENSION SVEC(5),CVEC(5,5),SPRO(5),QGAIN(5,5),QPRO(5,5)
     &,         SSMT(5),CSMT(5,5)
      DIMENSION SADJ(5),DINV(5,5),AGAIN(5,5)

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

      IERR = 0

* Adjust the old smoothed vector to allow for MS ...
      CALL FKADJ(SVEC,SPRO,QGAIN,SADJ)
      CALL FKNORM(SADJ,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

* ... translate to the new position ...
      CALL FKTRAN(DZ,Z,SADJ,SSMT,DINV)
      CALL FKNORM(SSMT,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

* ... and calculate the new covariance
      CALL FKDMQD(DINV,QGAIN,AGAIN)
      CALL FKMXM(CVEC,AGAIN,CSMT)
      CALL FKDQA(DINV,QPRO,AGAIN,CSMT)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.19  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLWM(IFL,S1,C1,S2,C2,S3,C3,IERR)
**********************************************************************
*                                                                    *
* Take the weighted mean of two state vectors                        *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ; normal termination                             *
*   ->  IERR = 111  ; failure to invert output covariance            *
*       IERR =  16  ; output theta > pi/2 (reset to pi/4)            *
*       IERR =  17  ; output theta > 1 (warning)                     *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=6)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION S1(5),C1(5,5),S2(5),C2(5,5),W(5,5),S3(5),C3(5,5),S4(5)

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

      IERR = 0

*
* compute the inverse of the weighted average covariance ...
*
      IF (IFL.GE.0) THEN
         CALL FKADD(C1,C2,C3)
         CALL FKDIFF(S2,S1,S4)
      ELSE
         CALL FKSUB(C2,C1,C3)
         CALL FKDIFF(S1,S2,S4)
      ENDIF
      CALL DSINV(5,C3,5,IFAIL)
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF

      CALL FKMLT(C1,C3,W)
      CALL FKMLT2(W,C2,C3)

*
* compute the weighted average state vector ...
*
      DO 400 J1=1,5
         S3(J1) = S1(J1)
         DO 300 J2=1,5
            S3(J1) = S3(J1) + W(J1,J2)*S4(J2)
 300     CONTINUE
 400  CONTINUE

      CALL FKNORM(S3,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  5.01/06 19/08/94  14.12.56  by  Stephen Burke
*CMZ :  2.04/00 10/05/91  18.36.52  by  Gregorio Bernardi
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLXY(XY,CXY,DDZ,SP,CP,SF,CF,CHISQ,IERR)
**********************************************************************
*                                                                    *
* Kalman Filter an x/y point with errors on z                        *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =        0 ; normal termination                         *
*   ->  IERR =      107 ; failure to invert measurement covariance   *
*   ->  IERR =      111 ; failure to invert filtered covariance      *
*       IERR =       17 ; tan(theta) > 1 (warning)                   *
*       IERR =       12 ; covariance of filtered residuals n.p.d.    *
*       IERR =  20 +  n ; 2 < n < 10 iterations                      *
*   ->  IERR =      130 ; 10 iterations                              *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* NB Error 12 is not considered fatal, but the chi-sq will be zero   *
*                                                                    *
* Note that after an error 130 the output vectors are defined, but   *
* are not guaranteed to be correct.                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=14)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      REAL XY(2),CXY(2,2),DDZ
      DIMENSION SP(5),CP(5,5),SF(5),CF(5,5),SS(5)
      DIMENSION WMES(2),CMES(2,2)
      LOGICAL LFLAG

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFTVX.
      DOUBLE PRECISION DTHMAX,DPHMAX
      COMMON /FKFTVX/ DTHMAX,DPHMAX
*KEND.

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

      IERR  = 0
      NPASS = 0

      WMES(1) = XY(1)
      WMES(2) = XY(2)

      CALL UCOPY(SP,SS,10)
      SPHI  = DSIN(SP(5))
      CPHI  = DCOS(SP(5))
      TTHDZ = SP(4)*DDZ
      TTHDZ = TTHDZ*TTHDZ

 100  CONTINUE

      CMES(1,1) = CXY(1,1) + CPHI*CPHI*TTHDZ
      CMES(2,1) = CXY(2,1) + CPHI*SPHI*TTHDZ
      CMES(2,2) = CXY(2,2) + SPHI*SPHI*TTHDZ

      CALL FKLFXY(SP,CP,WMES,CMES,SF,CF,CHISQ,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

      LFLAG = .FALSE.
      IF (DABS(SF(4)-SS(4)).GT.DTHMAX) LFLAG = .TRUE.
      IF (DABS(SF(5)-SS(5)).GT.DPHMAX) LFLAG = .TRUE.

      IF (LFLAG) THEN
         CALL UCOPY(SF,SS,10)
         TTHDZ = SF(4)*DDZ
         TTHDZ = TTHDZ*TTHDZ
         SPHI  = DSIN(SF(5))
         CPHI  = DCOS(SF(5))
         NPASS = NPASS + 1
         IF (NPASS.LT.10) GOTO 100
         CALL FKERR(IUTIL,IROUT,IFATAL,IFREE1,IERR)
         RETURN
      ENDIF

      IF (NPASS.GT.2) CALL FKERR(IUTIL,IROUT,IWARN,IFREE+NPASS,IERR)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZ :  5.01/06 22/08/94  12.00.54  by  Gaby Raedel
*CMZU:  3.04/01 02/06/92  16.07.24  by  Stephen Burke
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKLXYZ(XY,CXYZ,SP,CP,SF,CF,CHISQ,IERR)
*-----------------------------------------Updates 02/06/92-------
**: FKLXYZ 50106 SB. Protect against divide by 0.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Kalman Filter an x/y point with errors on z                        *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =        0 ; normal termination                         *
*   ->  IERR =      107 ; failure to invert measurement covariance   *
*   ->  IERR =      111 ; failure to invert filtered covariance      *
*       IERR =       17 ; tan(theta) > 1 (warning)                   *
*       IERR =       12 ; covariance of filtered residuals n.p.d.    *
*       IERR =  20 +  n ; 2 < n < 10 iterations                      *
*   ->  IERR =      130 ; 10 iterations                              *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* NB Error 12 is not considered fatal, but the chi-sq will be zero   *
*                                                                    *
* Note that after an error 130 the output vectors are defined, but   *
* are not guaranteed to be correct.                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=0,IROUT=15)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      REAL XY(2),CXYZ(3,3)
      DIMENSION SP(5),CP(5,5),SF(5),CF(5,5)
      DIMENSION WMES(2),CMES(2,2)
      LOGICAL LFLAG

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFTVX.
      DOUBLE PRECISION DTHMAX,DPHMAX
      COMMON /FKFTVX/ DTHMAX,DPHMAX
*KEND.

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

      IERR = 0
      NPASS = 0

      WMES(1) = XY(1)
      WMES(2) = XY(2)

      SPHI = DSIN(SP(5))
      CPHI = DCOS(SP(5))
      IF (ABS(CPHI).GT.1.0D-15) THEN
         TANPHI = SPHI/CPHI
      ELSE
         TANPHI = SIGN(1.0D15,CPHI)*SPHI
      ENDIF
      IF (ABS(TANPHI).GT.1.0D-15) THEN
         COTPHI = 1.D0/TANPHI
      ELSE
         COTPHI = SIGN(1.0D15,TANPHI)
      ENDIF
      TTHDZ = SP(4)**2*CXYZ(3,3)

 100  CONTINUE

      CMES(1,1) = CXYZ(1,1) + CPHI*(CPHI*TTHDZ + 2.D0*CXYZ(3,1)
     &                                        + 2.D0*COTPHI*CXYZ(3,2))
      CMES(2,1) = CXYZ(2,1) + CPHI*SPHI*TTHDZ  + 2.D0*SPHI*CXYZ(3,1)
     &                                        + 2.D0*CPHI*CXYZ(3,2)
      CMES(2,2) = CXYZ(2,2) + SPHI*(SPHI*TTHDZ + 2.D0*CXYZ(3,2)
     &                                        + 2.D0*TANPHI*CXYZ(3,1))

      CALL FKLFXY(SP,CP,WMES,CMES,SF,CF,CHISQ,IFAIL)
      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL/100,IFAIL,IERR)
      IF (IFAIL.GE.100) RETURN

      LFLAG = .FALSE.
      IF (DABS(SF(4)-SP(4)).GT.DTHMAX) THEN
         LFLAG = .TRUE.
         TTHDZ = SP(4)**2*CXYZ(3,3)
      ENDIF
      IF (DABS(SF(5)-SP(5)).GT.DPHMAX) THEN
         LFLAG = .TRUE.
         SPHI  = DSIN(SP(5))
         CPHI  = DCOS(SP(5))
         IF (ABS(CPHI).GT.1.0D-15) THEN
            TANPHI = SPHI/CPHI
         ELSE
            TANPHI = SIGN(1.0D15,CPHI)*SPHI
         ENDIF
         IF (ABS(TANPHI).GT.1.0D-15) THEN
            COTPHI = 1.D0/TANPHI
         ELSE
            COTPHI = SIGN(1.0D15,TANPHI)
         ENDIF
      ENDIF

      IF (LFLAG) THEN
         NPASS = NPASS + 1
         IF (NPASS.LT.10) GOTO 100
         CALL FKERR(IUTIL,IROUT,IFATAL,IFREE1,IERR)
         RETURN
      ENDIF

      IF (NPASS.GT.2) CALL FKERR(IUTIL,IROUT,IWARN,IFREE+NPASS,IERR)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.48  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKMUL(Q1,D,Q)
**********************************************************************
*                                                                    *
* Project error matrix                                               *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKINT.
*KEND.

      DIMENSION Q1(5,5),D(5,5),Q(5,5)

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

      DQ14 = Q1(4,1) + D(1,4)*Q1(4,4) + D(1,5)*Q1(5,4)
      DQ15 = Q1(5,1) + D(1,4)*Q1(5,4) + D(1,5)*Q1(5,5)

      DQ24 = Q1(4,2) + D(2,4)*Q1(4,4) + D(2,5)*Q1(5,4)
      DQ25 = Q1(5,2) + D(2,4)*Q1(5,4) + D(2,5)*Q1(5,5)

      IF (IAPROX.LE.2) THEN
         Q(1,1) = Q1(1,1) + D(1,4)*(Q1(4,1)+DQ14)
     &                    + D(1,5)*(Q1(5,1)+DQ15)
         Q(2,1) = Q1(2,1) + D(1,4)*Q1(4,2) + D(1,5)*Q1(5,2)
     &                    + D(2,4)*DQ14    + D(2,5)*DQ15
         Q(2,2) = Q1(2,2) + D(2,4)*(Q1(4,2)+DQ24)
     &                    + D(2,5)*(Q1(5,2)+DQ25)
         Q(4,1) = DQ14
         Q(4,2) = DQ24
      ENDIF

      Q(3,3) = Q1(3,3)

      Q(4,3) = Q1(4,3)
      Q(4,4) = Q1(4,4)

      IF (IAPROX.EQ.1) THEN
         Q(3,1) = Q1(3,1) + D(1,4)*Q1(4,3) + D(1,5)*Q1(5,3)
         Q(3,2) = Q1(3,2) + D(2,4)*Q1(4,3) + D(2,5)*Q1(5,3)
         Q(4,1) = DQ14
         Q(4,2) = DQ24
         Q(5,1) = DQ15
         Q(5,2) = DQ25
         Q(5,3) = Q1(5,3)
         Q(5,4) = Q1(5,4)
         Q(5,5) = Q1(5,5)
         RETURN
      ENDIF

      DQ13 = Q1(3,1) + D(1,4)*Q1(4,3) + D(1,5)*Q1(5,3)
      DQ23 = Q1(3,2) + D(2,4)*Q1(4,3) + D(2,5)*Q1(5,3)

      IF (IAPROX.GE.3) THEN
         DQ13 = DQ13 + D(1,3)*Q1(3,3)
         DQ14 = DQ14 + D(1,3)*Q1(4,3)
         DQ15 = DQ15 + D(1,3)*Q1(5,3)
         DQ23 = DQ23 + D(2,3)*Q1(3,3)
         DQ24 = DQ24 + D(2,3)*Q1(4,3)
         DQ25 = DQ25 + D(2,3)*Q1(5,3)
         Q(1,1) = Q1(1,1) + D(1,4)*(Q1(4,1)+DQ14)
     &                    + D(1,5)*(Q1(5,1)+DQ15)
     &                    + D(1,3)*(Q1(3,1)+DQ13)
         Q(2,1) = Q1(2,1) + D(1,4)*Q1(4,2) + D(1,5)*Q1(5,2)
     &                    + D(2,4)*DQ14    + D(2,5)*DQ15
     &                    + D(1,3)*Q1(3,2) + D(2,3)*DQ13
         Q(2,2) = Q1(2,2) + D(2,4)*(Q1(4,2)+DQ24)
     &                    + D(2,5)*(Q1(5,2)+DQ25)
     &                    + D(2,3)*(Q1(3,2)+DQ23)
         Q(4,1) = DQ14
         Q(4,2) = DQ24
      ENDIF

      DQ53 = Q1(5,3) + D(5,3)*Q1(3,3) + D(5,4)*Q1(4,3)
      DQ54 = Q1(5,4) + D(5,3)*Q1(4,3) + D(5,4)*Q1(4,4)

      Q(3,1) = DQ13
      Q(3,2) = DQ23

      Q(5,1) =    DQ13*D(5,3) +    DQ14*D(5,4) +  DQ15
      Q(5,2) =    DQ23*D(5,3) +    DQ24*D(5,4) +  DQ25
      Q(5,3) = Q1(3,3)*D(5,3) + Q1(4,3)*D(5,4) +  Q1(5,3)
      Q(5,4) = Q1(4,3)*D(5,3) + Q1(4,4)*D(5,4) +  Q1(5,4)
      Q(5,5) = Q1(5,5) + (Q1(5,3)+DQ53)*D(5,3) + (Q1(5,4)+DQ54)*D(5,4)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.49  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKMXM(X,G,Q)
**********************************************************************
*                                                                    *
* Optimised matrix transformation.                                   *
* Used to calculate the smoothed covariance matrix; the gain matrix  *
* (G) is known to have G(3,x)=delta(3,x).                            *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION X(5,5),G(5,5),Q(5,5)

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

      DO 200 J1=1,5
* First work out (G*X)j1 k2 for each k2 (contracting over k1).
         IF (J1.NE.3) THEN
            GX1 = G(J1,1)*X(1,1)
     &          + G(J1,2)*X(2,1)
     &          + G(J1,3)*X(3,1)
     &          + G(J1,4)*X(4,1)
     &          + G(J1,5)*X(5,1)
            GX2 = G(J1,1)*X(2,1)
     &          + G(J1,2)*X(2,2)
     &          + G(J1,3)*X(3,2)
     &          + G(J1,4)*X(4,2)
     &          + G(J1,5)*X(5,2)
            GX3 = G(J1,1)*X(3,1)
     &          + G(J1,2)*X(3,2)
     &          + G(J1,3)*X(3,3)
     &          + G(J1,4)*X(4,3)
     &          + G(J1,5)*X(5,3)
            GX4 = G(J1,1)*X(4,1)
     &          + G(J1,2)*X(4,2)
     &          + G(J1,3)*X(4,3)
     &          + G(J1,4)*X(4,4)
     &          + G(J1,5)*X(5,4)
            GX5 = G(J1,1)*X(5,1)
     &          + G(J1,2)*X(5,2)
     &          + G(J1,3)*X(5,3)
     &          + G(J1,4)*X(5,4)
     &          + G(J1,5)*X(5,5)
         ELSE
            GX1 = X(3,1)
            GX2 = X(3,2)
            GX3 = X(3,3)
            GX4 = X(4,3)
            GX5 = X(5,3)
         ENDIF
* Then do: (Q)j1 j2 = Sum(k2) (G*Q)j1 k2 * (G)j2 k2
         DO 100 J2=J1,5
            IF (J2.NE.3) THEN
               Q(J2,J1) = GX1*G(J2,1)
     &                  + GX2*G(J2,2)
     &                  + GX3*G(J2,3)
     &                  + GX4*G(J2,4)
     &                  + GX5*G(J2,5)
            ELSE
               Q(3,J1) = GX3
            ENDIF
 100     CONTINUE
 200  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.45.13  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKPRHS(LUN,CMESS,NUM,NPL)
*-----------------------------------------Updates 07/02/92-------
**: FKPRHS 30205.SB. Change FKISUM to subroutine to please UNDEF.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Print out point rejection histograms                               *
*                                                                    *
**********************************************************************

      DIMENSION NUM(NPL)

      CHARACTER*(*) CMESS

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

      CALL FKISUM(NUM,NPL,NTOT,MAX)

      IF (NTOT.LE.0) RETURN

      WRITE(LUN,*)
      WRITE(LUN,*) CMESS
      WRITE(LUN,*)

      PMAX = 200.D0*MAX/NTOT
      DO 100 JPL=1,NPL
         PCT = 100.D0*NUM(JPL)/NTOT
C         IF (NUM(JPL).GT.0) CALL FKHIST(LUN,JPL,PCT,PMAX)
* Probably better to print them all
         CALL FKHIST(LUN,JPL,PCT,PMAX)
 100  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  7.00/04 26/04/95  17.44.27  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.51  by  Girish D. Patel
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKPRNT(NUM,ICODE)
**********************************************************************
*                                                                    *
* Print out an error report                                          *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKLERR.
      PARAMETER(NROUT=20,NCODE=50)
      COMMON /FKLERR/ NMERR(NCODE,NROUT),NUERR(NCODE,NROUT)
     &,               NFAT,NERR,NOFL,NUFL,IULAST,IRLAST,MAXERR
*KEND.

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

      CHARACTER*6 CMROUT(NROUT),CUROUT(NROUT),CROUT

      DATA CMROUT/'FKLFIT','FKLPRO','FKLFLT','FKLSMO','FKLRFL'
     &,           'FKLWM ','FKLRSD','FKLPRS','FKLPAS','FKLFTR'
     &,           'FKLSPR','FKLFXY','FKLSSM','FKLXY ','FKLXYZ'
     &,           'FKLPAF','Unused','Unused','Unused','Unused'/

      DATA CUROUT/'FKCOVR','FKCOVP','FKINV ','FKNORM','FKRST '
     &,           'FKQG  ','FKLOOK','FKHUNT','FKCHPR','FKCHXY'
     &,           'FKCVXY','Unused','Unused','Unused','Unused'
     &,           'Unused','Unused','Unused','Unused','Unused'/

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

      IF (IULAST.EQ.0) THEN
         CROUT=CMROUT(IRLAST)
      ELSE
         CROUT=CUROUT(IRLAST)
      ENDIF

      IF (NUM.EQ.0) THEN
         WRITE(LUN,*)
         WRITE(LUN,*) 'Routine ',CROUT
         WRITE(LUN,*)
      ELSEIF (NUM.LT.0 .AND. ICODE.GT.100) THEN
         WRITE(LUN,1000) ICODE,CROUT,IPL,ITR,JSTEP
      ELSEIF (NUM.LT.0) THEN
         WRITE(LUN,1100) ICODE,CROUT,IPL,ITR,JSTEP
      ELSE
         WRITE(LUN,1200) ICODE,NUM
      ENDIF

 1000 FORMAT(' *** Fatal error ',I4,' in routine ',A6,
     &                ': Plane =',I3,' Track =',I10,' JSTEP =',I3)
 1100 FORMAT('     Error       ',I4,' in routine ',A6,
     &                ': Plane =',I3,' Track =',I10,' JSTEP =',I3)
 1200 FORMAT(' Count for error code ',I4,' =',I6)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.46  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKPRSV(IFLAG)
**********************************************************************
*                                                                    *
* Save/restore point-rejection status                                *
*                                                                    *
* Save if IFLAG is >= 0; restore otherwise                           *
*                                                                    *
* Note that the only form of error checking for a restore is that    *
* values have been saved at least once.                              *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKTRUE.
*KEND.

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

      LOGICAL LFLAGS(5),LTEMP(5),LTTRUE
      DIMENSION XCUTS(4),XCUTSI(4),XTEMP(4)
      EQUIVALENCE (LFLAGS,LRPRO),(XCUTS,X2PCUT),(XCUTSI,X2PCTI)

      SAVE LTEMP,LTTRUE,XTEMP,ILIM

      DATA ILIM/0/

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

      IF (IFLAG.LT.0) GOTO 1000

*
* Switch off residuals and point rejection, or leave point rejection on,
* but with a larger cut
*
      IF (LPRINI) THEN
         CALL UCOPY(XCUTS,XTEMP,8)
         CALL UCOPY(XCUTSI,XCUTS,8)
         ILIM = 3
      ELSE
         ILIM = 5
      ENDIF

      DO 100 I=1,ILIM
         LTEMP(I)  = LFLAGS(I)
         LFLAGS(I) = .FALSE.
 100  CONTINUE

      LTTRUE = LTRUE
      LTRUE  = .FALSE.

      RETURN

 1000 CONTINUE

      IF (ILIM.LE.0) RETURN

* Switch on residuals and PR as appropriate
      IF (ILIM.EQ.3) CALL UCOPY(XTEMP,XCUTS,8)

      DO 200 I=1,ILIM
         LFLAGS(I) = LTEMP(I)
 200  CONTINUE

      LTRUE = LTTRUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.22  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKQADD(C,Q)
**********************************************************************
*                                                                    *
* Add a multiple scattering matrix to a covariance matrix            *
*                                                                    *
* Output is C = C + Q, lower half only, where Q(3,x) = Q(x,3) = 0    *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION C(5,5),Q(5,5)

      C(1,1) = C(1,1) + Q(1,1)
      C(2,1) = C(2,1) + Q(2,1)
      C(4,1) = C(4,1) + Q(4,1)
      C(5,1) = C(5,1) + Q(5,1)
      C(2,2) = C(2,2) + Q(2,2)
      C(4,2) = C(4,2) + Q(4,2)
      C(5,2) = C(5,2) + Q(5,2)
      C(4,4) = C(4,4) + Q(4,4)
      C(5,4) = C(5,4) + Q(5,4)
      C(5,5) = C(5,5) + Q(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.23  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKQG(CPRO,Q,QGAIN,IERR)
**********************************************************************
*                                                                    *
* Calculate QGAIN for smoother                                       *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 111 ; failure to invert projected covariance          *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=6)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION CPRO(5,5),Q(5,5),QGAIN(5,5),CINV(5,5)

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

      IERR = 0

      CALL FKCOPY(CPRO,CINV)
      CALL DSINV(5,CINV,5,IFAIL)
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
         RETURN
      ENDIF

      DO 100 J=1,5
         QGAIN(1,J) = Q(1,1)*CINV(1,J) + Q(2,1)*CINV(2,J)
     &              + Q(4,1)*CINV(4,J) + Q(5,1)*CINV(5,J)
         QGAIN(2,J) = Q(2,1)*CINV(1,J) + Q(2,2)*CINV(2,J)
     &              + Q(4,2)*CINV(4,J) + Q(5,2)*CINV(5,J)
         QGAIN(4,J) = Q(4,1)*CINV(1,J) + Q(4,2)*CINV(2,J)
     &              + Q(4,4)*CINV(4,J) + Q(5,4)*CINV(5,J)
         QGAIN(5,J) = Q(5,1)*CINV(1,J) + Q(5,2)*CINV(2,J)
     &              + Q(5,4)*CINV(4,J) + Q(5,5)*CINV(5,J)
 100  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.50  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKRST(JPL,IERR)
**********************************************************************
*                                                                    *
* Calculate residuals and chi-squared between the smoothed and true  *
* vectors at plane JPL                                               *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0  ; normal termination                             *
*   ->  IERR = 111  ; smoothed covariance not positive definite      *
*                                                                    *
*   ->  Fatal error                                                  *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=5)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKTRUE.
*KEEP,FKSMTH.
*KEND.

      DIMENSION CT(5,5)

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

      IERR = 0

*
* Calculate the residuals ...
*
      CALL FKDIFF(TRUE(1,JPL),SSMT(1,JPL),RTRUE(1,JPL))

*
* ... and the chi-squared
*
      CALL UCOPY(CSMT(1,1,JPL),CT,50)
      CALL DSINV(5,CT,5,IFAIL)
      CHITRU(JPL) = 0.D0
      IF (IFAIL.NE.0) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,IOCV,IERR)
      ELSE
         DO 200 I1=1,5
         DO 200 I2=1,5
            CHITRU(JPL) = CHITRU(JPL)
     &                    + RTRUE(I1,JPL)*CT(I1,I2)*RTRUE(I2,JPL)
 200     CONTINUE
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.46  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKSAVE(IFLAG,JFIRST,JLAST)
**********************************************************************
*                                                                    *
* Save/restore smoothed vector (+ residuals) from JFIRST to          *
* JLAST (inclusive)                                                  *
*                                                                    *
* Save if IFLAG is >= 0; restore otherwise                           *
*                                                                    *
* Note that there is NO error checking.                              *
*                                                                    *
* Also note that this does not save the entire status (i.e.          *
* projected and filtered vectors).                                   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEND.

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

      DIMENSION SSAVE(5,NPL),CSAVE(5,5,NPL)
     &,         SRSAVE(2,NPL),CRSAVE(2,2,NPL),CHSAVE(NPL)
     &,         RTSAVE(5,NPL),CTSAVE(NPL)

      SAVE SSAVE,CSAVE,SRSAVE,CRSAVE,CHSAVE,RTSAVE,CTSAVE

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

      JMIN  = MIN(JFIRST,JLAST)
      JDIFF = ABS(JLAST-JFIRST) + 1

      IF (IFLAG.GE.0) THEN
         CALL UCOPY(SSMT(1,JMIN),SSAVE,10*JDIFF)
         CALL UCOPY(CSMT(1,1,JMIN),CSAVE,50*JDIFF)
         IF (LRSMT) THEN
            CALL UCOPY(RSMT(1,JMIN),SRSAVE,4*JDIFF)
            CALL UCOPY(CRSMT(1,1,JMIN),CRSAVE,8*JDIFF)
            CALL UCOPY(CHISMT(JMIN),CHSAVE,2*JDIFF)
         ENDIF
         IF (LTRUE) THEN
            CALL UCOPY(RTRUE(1,JMIN),RTSAVE,10*JDIFF)
            CALL UCOPY(CHITRU(JMIN),CTSAVE,2*JDIFF)
         ENDIF
         RETURN
      ENDIF

      CALL UCOPY(SSAVE,SSMT(1,JMIN),10*JDIFF)
      CALL UCOPY(CSAVE,CSMT(1,1,JMIN),50*JDIFF)
      IF (LRSMT) THEN
         CALL UCOPY(SRSAVE,RSMT(1,JMIN),4*JDIFF)
         CALL UCOPY(CRSAVE,CRSMT(1,1,JMIN),8*JDIFF)
         CALL UCOPY(CHSAVE,CHISMT(JMIN),2*JDIFF)
      ENDIF
      IF (LTRUE) THEN
         CALL UCOPY(RTSAVE,RTRUE(1,JMIN),10*JDIFF)
         CALL UCOPY(CTSAVE,CHITRU(JMIN),2*JDIFF)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  2.03/03 28/03/91  15.14.10  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKSCAT(DZ,S,X0,D,Q)
**********************************************************************
*                                                                    *
* Compute the Multiple Scattering Matrix, Q, for transformation of   *
* State Vector, S, from Z to Z+DZ.                                   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION S(5),Q(5,5),D(5,5)

* TT2MIN sets the lower limit allowed for tan**2(theta) (arbitrary)
      PARAMETER (TT2MIN=1.D-20)
      PARAMETER (G=0.5D0,G2=1.0D0/3.0D0,PSCALE=0.0141)

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

*
* Test for finite step length and non-zero radiation length ....
*
      IF (DZ.EQ.0.D0 .OR. X0.LE.0.D0) THEN
         CALL VZERO(Q,50)
         RETURN
      ENDIF

* Fix for apparent singularity ... this should be checked further
      TT2 = S(4)*S(4)
      IF (TT2.LT.TT2MIN) TT2 = TT2MIN
      CT2I = 1.D0 + TT2
      ST2I = 1.D0/TT2 + 1.D0

* Compute path length in medium = X ....
      X = DABS(DZ*DSQRT(CT2I))

*
* compute the mean square scattering angle (SQMA) assuming Beta=1 ...
* (this is the projection onto plane)
*
      SQMA   = (X/X0)*(PSCALE*S(3))**2

      G2SQMA = G2*SQMA
      G2SQ54 = G2SQMA*D(5,4)
      GSQMA  = G*SQMA
      GSQC2I = GSQMA*CT2I
      GSQS2I = GSQMA*ST2I

*
* First compute the diagonal terms ...
*
      Q(1,1) = G2SQMA*(D(1,4)*D(1,4) + D(1,5)*D(1,5)*ST2I)
      Q(2,2) = G2SQMA*(D(2,4)*D(2,4) + D(2,5)*D(2,5)*ST2I)
      Q(4,4) = SQMA*CT2I*CT2I
      Q(5,5) = G2SQ54*D(5,4) + SQMA*ST2I

*
* Now the off-diagonal terms ...
*
      Q(2,1) = G2SQMA*(D(1,4)*D(2,4) + D(1,5)*D(2,5)*ST2I)
      Q(4,1) = GSQC2I*D(1,4)
      Q(5,1) = G2SQ54*D(1,4) + GSQS2I*D(1,5)

      Q(4,2) = GSQC2I*D(2,4)
      Q(5,2) = G2SQ54*D(2,4) + GSQS2I*D(2,5)

      Q(5,4) = GSQC2I*D(5,4)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.45.14  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKSTAT
*-----------------------------------------Updates 07/02/92-------
**: FKSTAT 30205.SB. Change FKISUM to subroutine to please UNDEF.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Print out statistics on point rejection                            *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEND.

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

      CALL FKISUM(NBADP,NPL,NBP,NBPMAX)
      CALL FKISUM(NBADB,NPL,NBB,NBBMAX)
      CALL FKISUM(NNEWP,NPL,NNP,NNPMAX)
      CALL FKISUM(NUNRJP,NPL,NUP,NUPMAX)
      CALL FKISUM(NUNRJB,NPL,NUB,NUBMAX)
      CALL FKISUM(NRERJP,NPL,NRP,NRPMAX)
      CALL FKISUM(NFAILP,NPL,NFP,NFPMAX)
      CALL FKISUM(NFAILB,NPL,NFB,NFBMAX)

      WRITE(LUN,*)
      WRITE(LUN,*)
      WRITE(LUN,*) '              General point rejection statistics'
      WRITE(LUN,*)
      WRITE(LUN,*) '# single points removed     = ',NBP,' out of',NCPRS
      WRITE(LUN,*) '# points removed in blocks  = ',NBB,' out of',NBPRS
      WRITE(LUN,*) '# new points                = ',NNP,' out of',NCPAS
      WRITE(LUN,*) '# single points re-accepted = ',NUP
      WRITE(LUN,*) '# block points re-accepted  = ',NUB
      WRITE(LUN,*) '# points rejected twice     = ',NRP
      WRITE(LUN,*) '# single point failures     = ',NFP
      WRITE(LUN,*) '# block point failures      = ',NFB
      WRITE(LUN,*)

      WRITE(LUN,*)
      WRITE(LUN,*) 'Chi-squared probability cuts were:'
      WRITE(LUN,*)

      WRITE(LUN,1000) X2PCUT,X2CUTB,X2CUTA,X2CUTN
      IF (LPRINI) WRITE(LUN,2000) X2PCTI,X2CTBI,X2CTAI,X2CTNI

 1000 FORMAT(' X2PCUT = ',F6.4/' X2CUTB = ',F6.4/
     &       ' X2CUTA = ',F6.4/' X2CUTN = ',F6.4/)
 2000 FORMAT(' X2PCTI = ',F6.4/' X2CTBI = ',F6.4/
     &       ' X2CTAI = ',F6.4/' X2CTNI = ',F6.4/)

      IF (IPR.LT.6) RETURN

      IF (NBP.GT.0) THEN
         WRITE(LUN,*)
         WRITE(LUN,*) 'Single points removed (percentage by plane)'
         WRITE(LUN,*)
         PMAX = 200.D0*NBPMAX/NBP
         DO 100 JPL=1,NPL
            IF (LPOINT .OR. LWIRE(JPL)) THEN
               PCT = 100.D0*NBADP(JPL)/NBP
               CALL FKHIST(LUN,JPL,PCT,PMAX)
            ENDIF
 100     CONTINUE
      ENDIF

      IF (NBB.GT.0) THEN
         WRITE(LUN,*)
         WRITE(LUN,*) 'Points in blocks removed (percentage by plane)'
         WRITE(LUN,*)
         PMAX = 200.D0*NBBMAX/NBB
         DO 200 JPL=1,NPL
            PCT = 100.D0*NBADB(JPL)/NBB
            CALL FKHIST(LUN,JPL,PCT,PMAX)
 200     CONTINUE
      ENDIF

      CALL FKPRHS(LUN,'New points, % by plane',NNEWP,NPL)
      CALL FKPRHS(LUN,'Single points re-accepted, % by plane',
     &                                                    NUNRJP,NPL)
      CALL FKPRHS(LUN,'Block points re-accepted, % by plane',
     &                                                    NUNRJB,NPL)
      CALL FKPRHS(LUN,'Points rejected twice, % by plane',NRERJP,NPL)
      CALL FKPRHS(LUN,'Single point failures, % by plane',NFAILP,NPL)
      CALL FKPRHS(LUN,'Block point failures, % by plane',NFAILB,NPL)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.25  by  Stephen Burke
*CMZU:  4.00/01 21/09/93  16.21.33  by  Stephen Burke
*CMZU:  2.04/00 23/04/91  15.33.16  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
*-----------------------------------------Updates 21/09/92-------
**: FKTRAN.......SB. Cope better (?) with zero field.
*-----------------------------------------Updates----------------
      SUBROUTINE FKTRAN(DZ,Z1,S1,S2,D)
**********************************************************************
*                                                                    *
*  Transform track vector (S1) through DZ to (S2) in magnetic field. *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKINT.
*KEND.

      REAL B(3),R(3),B2(3),R2(3),DB(3)
      DIMENSION S1(5),S2(5),D(5,5)

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

      PARAMETER (BFACT=2.997886E-4)

**********************************************************************
*
* Thresholds for various approximations (*** UNOPTIMISED ***)
*

* Max z step over which field is assumed constant
      PARAMETER (DZMAX=1.0D0)
* If Dphi <E-3 errors in sin/cos are <E-6, and in dx/dy are <1 micron
      PARAMETER (DPHMAX=1.0D-2,DPHMX2=1.0D-4)
* Minimum significant changes in x/y and phi for straight line approx
      PARAMETER (DXYMIN=1.0D-3,DPHMIN=0.0D0)
* BMAX is the (absolute) maximum field value in T/3E-3 (i.e. 1.2T)
      PARAMETER (BMAX=3.6D-3)
* Min change in tan(theta) which is considered significant
      PARAMETER (DTTMIN=1.0D-4)

**********************************************************************
*
* Some parameters are remembered, as they may not need recalculating
*

      SAVE PHIR,CPHIR,SPHIR
      SAVE TTR,OPTSQ,CTSQ,STCT,SECT

      DATA PHIR/0.D0/,CPHIR/1.D0/,SPHIR/0.D0/
      DATA TTR/0.D0/,OPTSQ/1.D0/,CTSQ/1.D0/,STCT/0.D0/,SECT/1.D0/

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

* S2 = S1 + corrections ...
      S2(1) = S1(1)
      S2(2) = S1(2)
      S2(3) = S1(3)
      S2(4) = S1(4)
      S2(5) = S1(5)

* Diagonal elements of D are always 1
      D(1,1) = 1.D0
      D(2,2) = 1.D0
      D(3,3) = 1.D0
      D(4,4) = 1.D0
      D(5,5) = 1.D0

      IF (DZ.EQ.0.D0) THEN
* Trivial
         IAPROX = 0
         D(1,3) = 0.D0
         D(1,4) = 0.D0
         D(1,5) = 0.D0
         D(2,3) = 0.D0
         D(2,4) = 0.D0
         D(2,5) = 0.D0
         D(5,3) = 0.D0
         D(5,4) = 0.D0
         RETURN
      ENDIF

* Work out cos/sin phi, using remembered value if appropriate
      DPHI = S1(5) - PHIR
      IF (DABS(DPHI).LT.DPHMX2) THEN
* Change in phi is negligible
         CPHI1 = CPHIR
         SPHI1 = SPHIR
      ELSEIF (DABS(DPHI).LT.DPHMAX) THEN
* Small angle approximations for cos and sin (to order DPHI**2)
         CDPHI = 1.D0 - 0.5D0*DPHI*DPHI
         SPHI1 = SPHIR*CDPHI + CPHIR*DPHI
         CPHI1 = CPHIR*CDPHI - SPHIR*DPHI
      ELSE
* Full expressions
         CPHI1 = DCOS(S1(5))
         SPHI1 = DSQRT(1.D0 - CPHI1*CPHI1)
         IF (S1(5).GT.PI) SPHI1 = -SPHI1
* Remember values
         PHIR  = S1(5)
         CPHIR = CPHI1
         SPHIR = SPHI1
      ENDIF

* See whether we need to calculate various functions of theta
      IF (DABS(S1(4)-TTR).LT.DTTMIN) THEN
* Old values will do
         DZSECT = DZ*SECT
         IF (DABS(DZSECT*S1(3)).LT.DPHMIN/BMAX) THEN
* DPHI is negligible
            IAPROX = 1
         ELSE
* Must recalculate DPHI, and hence field
            IAPROX = 2
         ENDIF
* If theta has changed, just work out upper bound on DPHI
      ELSEIF (DABS(DZ*S1(3)*(1.D0 + S1(4))).LT.DPHMIN/BMAX) THEN
         IAPROX = 1
      ELSE
* Theta has changed and DPHI is non-negligible, so must recalculate
         OPTSQ  = 1.D0 + S1(4)*S1(4)
         CTSQ   = 1.D0/OPTSQ
         STCT   = CTSQ*S1(4)
         SECT   = SQRT(OPTSQ)
         DZSECT = DZ*SECT
         TTR    = S1(4)
         IAPROX = 2
      ENDIF

      IF (IAPROX.GE.2) THEN
* Get the field
         R(1) = S1(1)
         R(2) = S1(2)
         R(3) = Z1
         CALL GUFLD(R,B)
         IF (ABS(B(3)).LT.0.01) B(3) = SIGN(0.01,B(3))
* Work out Delta phi (don't re-order these lines!)
         D(5,3) = -DZSECT*B(3)*BFACT
         DPHI   = D(5,3)*S1(3)
         D(5,4) = DPHI*STCT
         S2(5)  = S2(5) + DPHI
* Choose the order of approximation
         IF (DABS(DZ).GT.DZMAX) THEN
* Must consider change in field over DZ
            IAPROX = 5
         ELSEIF (DABS(DZ*DPHI).GT.DXYMIN) THEN
* Must take helix (x and y affected by dphi)
            IAPROX = 4
         ENDIF
      ELSE
* Ignore DPHI
         D(5,3) = 0.D0
         D(5,4) = 0.D0
      ENDIF

      IF (IAPROX.LE.2) THEN
* Ignore change in phi for DX and DY
         D(1,3) = 0.D0
         D(2,3) = 0.D0
         D(1,4) = DZ*CPHI1
         D(2,4) = DZ*SPHI1
         D(1,5) = -D(2,4)*S1(4)
         D(2,5) = D(1,4)*S1(4)
         S2(1)  = S2(1) + D(2,5)
         S2(2)  = S2(2) - D(1,5)
* End of straight line approx
         IF (IAPROX.EQ.2) GOTO 9100
         GOTO 9200
      ENDIF

      IF (DABS(DPHI).LT.DPHMAX) THEN
* Small angle approximations for cos and sin (to order DPHI**2)
         DPHI2 = 0.5D0*DPHI
         CDPHI = 1.D0 - DPHI2*DPHI
         SPHI2 = SPHI1*CDPHI + CPHI1*DPHI
         CPHI2 = CPHI1*CDPHI - SPHI1*DPHI
         DXOTT = DZ*(CPHI1 - SPHI1*DPHI2)
         DYOTT = DZ*(SPHI1 + CPHI1*DPHI2)
      ELSE
* Full expressions
         CPHI2 = DCOS(S2(5))
         SPHI2 = DSIN(S2(5))
         FAC   = DZ/DPHI
         DXOTT = FAC*(SPHI2 - SPHI1)
         DYOTT = FAC*(CPHI1 - CPHI2)
* Remember values
         PHIR  = S2(5)
         CPHIR = CPHI2
         SPHIR = SPHI2
      ENDIF

* Change in x and y
      DX    = DXOTT*S1(4)
      DY    = DYOTT*S1(4)
      S2(1) = S2(1) + DX
      S2(2) = S2(2) + DY

      D(1,5) = -DY
      D(2,5) = DX

* Some more abbreviations ...
      IF (DABS(S1(3)).GT.1.0D-10) THEN
         POQ = 1.D0/S1(3)
      ELSE
         POQ = SIGN(1.0D10,S1(3))
      ENDIF
      DXDY   = DZ*S1(4)
      DXDYC2 = DXDY*CPHI2
      DXDYS2 = DXDY*SPHI2

* ... and the remaining differential coefficients
      D(1,3) = POQ*(DXDYC2 - DX)
      D(1,4) = DXOTT*CTSQ + DXDYC2*STCT

      D(2,3) = POQ*(DXDYS2 - DY)
      D(2,4) = DYOTT*CTSQ + DXDYS2*STCT

* Are corrections for Bx and By required?
      IF (IAPROX.LT.4) GOTO 9100

*
* Apply 1st order corrections assuming that Bx and By are
* small but non-zero ........ (Bx,By,Bz) is still assumed
* to be constant across DZ ......
*

      DPHIOB = DZSECT*S1(3)*BFACT
      CON1   = DPHIOB*DZ*0.5D0
      CON2   = DPHIOB*OPTSQ
      IF (S1(4).NE.0.D0) THEN
         CON3 = DPHIOB/S1(4)
      ELSE
* If theta = 0, phi is undefined, so CON3 can be set to any value
         CON3 = 0.D0
      ENDIF

      S2(1) = S2(1) - CON1*B(2)
      S2(2) = S2(2) + CON1*B(1)
      S2(4) = S2(4) + CON2*(B(1)*SPHI1 - B(2)*CPHI1)
      S2(5) = S2(5) + CON3*(B(1)*CPHI1 + B(2)*SPHI1)

* Are corrections for field variation required?
      IF (IAPROX.LT.5) GOTO 9000

* Get field at end point ...
      R2(1) = S2(1)
      R2(2) = S2(2)
      R2(3) = Z1 + DZ
      CALL GUFLD(R2,B2)
      IF (ABS(B2(3)).LT.0.01) B2(3) = SIGN(0.01,B2(3))
      DB(1) = 0.5*(B2(1) - B(1))
      DB(2) = 0.5*(B2(2) - B(2))
      DB(3) = 0.5*(B2(3) - B(3))

*
* DB is the mean difference from the assumed field along the trajectory,
* assuming the field components vary linearly with Z over DZ.
* ie B and dB/dZ are non-zero but  d2B/dZ2  etc are assumed zero.
*

      DBZTT = DB(3)*S1(4)

      S2(1) = S2(1) + CON1*(DBZTT*SPHI1 - DB(2))
      S2(2) = S2(2) + CON1*(DB(1) - DBZTT*CPHI1)
      S2(4) = S2(4) + CON2*(DB(1)*SPHI1 - DB(2)*CPHI1)
      S2(5) = S2(5) + CON3*(DB(1)*CPHI1 + DB(2)*SPHI1) - DPHIOB*DB(3)

 9000 CONTINUE

      IF (S2(4).LT.0.D0) THEN
         S2(4) = DABS(S2(4))
         S2(5) = S2(5) + PI
      ENDIF

 9100 CONTINUE

      IF (DABS(S2(5)).GT.TWOPI) S2(5)=DMOD(S2(5),TWOPI)
      IF (S2(5).LT.0.D0) S2(5) = S2(5) + TWOPI

 9200 CONTINUE

* Stop values getting too large (i.e. stop overflows)
      IF (ABS(S2(1)).GT.1.D4) S2(1) = SIGN(1.D4,S2(1))
      IF (ABS(S2(2)).GT.1.D4) S2(2) = SIGN(1.D4,S2(2))
      IF (S2(4).GT.1.D6) S2(4) = 1.D6

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.25  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKWMES(MES,HMES,GMES,W,HGW)
**********************************************************************
*                                                                    *
* Compute a measurement vector weighted by the inverse of its        *
* covariance, and transformed into state vector space                *
*                                                                    *
* Output is HGW = HMES.GMES.W (MES is the number of measurements)    *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION HMES(2,2),GMES(2,2),W(2),HGW(2)

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

      IF (MES.EQ.1) THEN
         HGW(1) = HMES(1,1)*GMES(1,1)*W(1)
         HGW(2) = HMES(1,2)*GMES(1,1)*W(1)
      ELSE
         HGW(1) = HMES(1,1)*GMES(1,1)*W(1) + HMES(1,1)*GMES(2,1)*W(2)
     &          + HMES(2,1)*GMES(2,1)*W(1) + HMES(2,1)*GMES(2,2)*W(2)
         HGW(2) = HMES(1,2)*GMES(1,1)*W(1) + HMES(1,2)*GMES(2,1)*W(2)
     &          + HMES(2,2)*GMES(2,1)*W(1) + HMES(2,2)*GMES(2,2)*W(2)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.25  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKWVEC(SPRO,WT,CFIL,HGW,SFIL)
**********************************************************************
*                                                                    *
* Calculate a filtered state vector - a weighted measurement         *
* multiplied by the total covariance, and added to the weighted      *
* projected vector.                                                  *
*                                                                    *
* Output is SFIL = CFIL.HGW + WT.SPRO                                *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION SPRO(5),WT(2,5),CFIL(5,5),HGW(2),SFIL(5)

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

      SFIL(1) = WT(1,1)*SPRO(1)  + WT(2,1)*SPRO(2)
     &        + CFIL(1,1)*HGW(1) + CFIL(2,1)*HGW(2)

      SFIL(2) = WT(1,2)*SPRO(1)  + WT(2,2)*SPRO(2)
     &        + CFIL(2,1)*HGW(1) + CFIL(2,2)*HGW(2)

      SFIL(3) = WT(1,3)*SPRO(1)  + WT(2,3)*SPRO(2)  + SPRO(3)
     &        + CFIL(3,1)*HGW(1) + CFIL(3,2)*HGW(2)

      SFIL(4) = WT(1,4)*SPRO(1)  + WT(2,4)*SPRO(2)  + SPRO(4)
     &        + CFIL(4,1)*HGW(1) + CFIL(4,2)*HGW(2)

      SFIL(5) = WT(1,5)*SPRO(1)  + WT(2,5)*SPRO(2)  + SPRO(5)
     &        + CFIL(5,1)*HGW(1) + CFIL(5,2)*HGW(2)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.36  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKADD(C1,C2,C3)
**********************************************************************
*                                                                    *
* Adds two 5*5 symmetric matrices                                    *
*                                                                    *
* Output is C3 = C1 + C2 (lower half only)                           *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C1(5,5),C2(5,5),C3(5,5)

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

      C3(1,1) = C1(1,1) + C2(1,1)
      C3(2,1) = C1(2,1) + C2(2,1)
      C3(3,1) = C1(3,1) + C2(3,1)
      C3(4,1) = C1(4,1) + C2(4,1)
      C3(5,1) = C1(5,1) + C2(5,1)

      C3(2,2) = C1(2,2) + C2(2,2)
      C3(3,2) = C1(3,2) + C2(3,2)
      C3(4,2) = C1(4,2) + C2(4,2)
      C3(5,2) = C1(5,2) + C2(5,2)

      C3(3,3) = C1(3,3) + C2(3,3)
      C3(4,3) = C1(4,3) + C2(4,3)
      C3(5,3) = C1(5,3) + C2(5,3)

      C3(4,4) = C1(4,4) + C2(4,4)
      C3(5,4) = C1(5,4) + C2(5,4)

      C3(5,5) = C1(5,5) + C2(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKCOPY(C1,C2)
**********************************************************************
*                                                                    *
* Copy a 5*5 covariance matrix from C1 to C2, lower half only        *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION C1(5,5),C2(5,5)

      C2(1,1) = C1(1,1)
      C2(2,1) = C1(2,1)
      C2(3,1) = C1(3,1)
      C2(4,1) = C1(4,1)
      C2(5,1) = C1(5,1)
      C2(2,2) = C1(2,2)
      C2(3,2) = C1(3,2)
      C2(4,2) = C1(4,2)
      C2(5,2) = C1(5,2)
      C2(3,3) = C1(3,3)
      C2(4,3) = C1(4,3)
      C2(5,3) = C1(5,3)
      C2(4,4) = C1(4,4)
      C2(5,4) = C1(5,4)
      C2(5,5) = C1(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.34  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKCVPT(LUN,S,C,IERR)
**********************************************************************
*                                                                    *
* Print out a state vector and covariance matrix; off-diagonal       *
* elements printed as correlations                                   *
*                                                                    *
* IERR = 1 if the matrix is not positive definite, and a message     *
* is also printed, but this is NOT a full test for positive          *
* definiteness.                                                      *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION S(5),C(5,5),CTEMP(5,5)

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

      IERR = 0

      CALL FKCOPY(C,CTEMP)

      DO 200 I=1,4
         DO 100 J=I+1,5
            VARIJ = CTEMP(I,I)*CTEMP(J,J)
            IF (VARIJ.LE.0) THEN
               IERR = 1
               CTEMP(J,I) = 0.D0
            ELSE
               CTEMP(J,I) = CTEMP(J,I)/DSQRT(VARIJ)
               IF (DABS(CTEMP(J,I)).GT.1.D0) IERR = 1
            ENDIF
 100     CONTINUE
 200  CONTINUE

      CALL FKFILL(CTEMP)

      WRITE(LUN,1000) S
 1000 FORMAT(/' ',5(D10.3,4X))

      WRITE(LUN,2000) CTEMP
 2000 FORMAT(/5(' ',5(D10.3,4X)/)/)

      IF (IERR.EQ.1) THEN
         WRITE(LUN,*)
         WRITE(LUN,*) '*** This matrix is not positive definite ***'
         WRITE(LUN,*)
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.53  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKDIFF(S1,S2,S3)
**********************************************************************
*                                                                    *
*  S3 = S1 - S2 (takes care of phi range)                            *
*                                                                    *
*  Delta phi is in the range -pi to pi                               *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION S1(5),S2(5),S3(5)

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

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

      S3(1) = S1(1) - S2(1)
      S3(2) = S1(2) - S2(2)
      S3(3) = S1(3) - S2(3)
      S3(4) = S1(4) - S2(4)
      S3(5) = S1(5) - S2(5)

      IF (DABS(S3(5)).LT.PI) RETURN

      IF (S3(5).GT.0.D0) THEN
         S3(5) = S3(5) - TWOPI
      ELSE
         S3(5) = S3(5) + TWOPI
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.53  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      DOUBLE PRECISION FUNCTION FKDPHI(PHI1,PHI2)
**********************************************************************
*                                                                    *
* Compute FKDPHI = PHI1-PHI2 , where PHI1 and PHI2 are in the range  *
* zero to twopi.                                                     *
* FKDPHI is between -pi and +pi                                      *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

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

      FKDPHI = PHI1 - PHI2

      IF (DABS(FKDPHI).LT.PI) RETURN

      IF (FKDPHI.GT.0.D0) THEN
         FKDPHI = FKDPHI - TWOPI
      ELSE
         FKDPHI = FKDPHI + TWOPI
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  4.00/01 21/09/93  16.21.33  by  Stephen Burke
*CMZU:  2.04/00 19/04/91  13.38.06  by  Stephen Burke
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
*-----------------------------------------Updates 21/09/92-------
**: FKETOI.......SB. Cope better (?) with zero field.
*-----------------------------------------Updates----------------
      SUBROUTINE FKETOI(EXT,SINT,CINT)
**********************************************************************
*                                                                    *
* Convert an `external' state vector to an `internal' vector         *
* and covariance.                                                    *
*                                                                    *
* External: 1/r, phi, theta, x, y, z, IPTYPE, covariance             *
* Internal: x, y, q/p, tan(theta), phi                               *
*                                                                    *
* The `external' covariance is packed with COVCP.                    *
*                                                                    *
**********************************************************************

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

      PARAMETER (BCONV=-0.0002998)

      DOUBLE PRECISION SINT(5),CINT(5,5),SEC2TH,DIFF1,DIFF3
      DIMENSION EXT(16),B(3),COV(15)

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

* Get the field
      CALL GUFLD(EXT(4),B)

* Trap zero field problems
      IF (ABS(B(3)).LT.1.0E-2) B(3) = SIGN(12.0,B(3))

* Transform the state vector
      SINT(1) = EXT(4)
      SINT(2) = EXT(5)
      SINT(3) = EXT(1)*DSIN(DBLE(EXT(3)))/(BCONV*B(3))
      SINT(4) = DTAN(DBLE(EXT(3)))
      SINT(5) = EXT(2)
      IF (SINT(5).LT.0.D0) SINT(5) = SINT(5) + TWOPI

* Trap more zero-field problems
      IF (ABS(SINT(3)).GT.1.0D4) SINT(3) = SIGN(1.0D4,SINT(3))

* Differential coefficients
      SEC2TH = (1.D0 + SINT(4)*SINT(4))
      IF (EXT(1).NE.0.) THEN
         DIFF1 = SINT(3)/EXT(1)
      ELSE
         DIFF1 = DSIN(DBLE(EXT(3)))/(BCONV*B(3))
      ENDIF
      DIFF3 = SINT(3)*SINT(4)

* Unpack the covariance ...
      CALL COVCP(5,COV,EXT(8),2)

* ... and transform it
      CINT(1,1) = COV(10)

      CINT(2,1) = COV(14)
      CINT(2,2) = COV(15)

      CINT(3,1) = COV(7) *DIFF1 + COV(9) *DIFF3
      CINT(3,2) = COV(11)*DIFF1 + COV(13)*DIFF3
      CINT(3,3) = COV(1)*DIFF1*DIFF1 + 2.D0*COV(4)*DIFF1*DIFF3
     &          + COV(6)*DIFF3*DIFF3

* Trap more zero-field problems
      IF (CINT(3,3).GT.1.0D6) CINT(3,3) = 1.0D6

      CINT(4,1) = COV(9)*SEC2TH
      CINT(4,2) = COV(13)
      CINT(4,3) = (COV(4)*DIFF1 + COV(6)*DIFF3)*SEC2TH
      CINT(4,4) = COV(6)*SEC2TH*SEC2TH

      CINT(5,1) = COV(8)
      CINT(5,2) = COV(12)
      CINT(5,3) = COV(2)*DIFF1 + COV(5)*DIFF3
      CINT(5,4) = COV(5)*SEC2TH
      CINT(5,5) = COV(3)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKFILL(C)
**********************************************************************
*                                                                    *
* Fill the upper half of a 5*5 covariance matrix from the lower half *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION C(5,5)

      DO 100 J=1,5
      DO 100 I=J,5
         C(J,I) = C(I,J)
 100  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.46.09  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKISUM(IVEC,N,ISUM,MAX)
*-----------------------------------------Updates 07/02/92-------
**: FKISUM 30205.SB. Change from function to subroutine to please UNDEF.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Integer version of VSUM; also returns MAX as the largest element   *
*                                                                    *
**********************************************************************

      DIMENSION IVEC(N)

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

      ISUM = 0
      MAX  = 0
      DO 100 I=1,N
         IF (IVEC(I).GT.MAX) MAX = IVEC(I)
         ISUM = ISUM + IVEC(I)
 100  CONTINUE

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKMLT(C1,C2,C3)
**********************************************************************
*                                                                    *
* Multiplies two 5*5 symmetric matrices                              *
*                                                                    *
* Output is C3 = C1.C2 (note that C3 is NOT symmetric!!!)            *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C1(5,5),C2(5,5),C3(5,5)

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

      C3(1,1) = C1(1,1)*C2(1,1) + C1(2,1)*C2(2,1) + C1(3,1)*C2(3,1)
     &        + C1(4,1)*C2(4,1) + C1(5,1)*C2(5,1)
      C3(2,1) = C1(2,1)*C2(1,1) + C1(2,2)*C2(2,1) + C1(3,2)*C2(3,1)
     &        + C1(4,2)*C2(4,1) + C1(5,2)*C2(5,1)
      C3(3,1) = C1(3,1)*C2(1,1) + C1(3,2)*C2(2,1) + C1(3,3)*C2(3,1)
     &        + C1(4,3)*C2(4,1) + C1(5,3)*C2(5,1)
      C3(4,1) = C1(4,1)*C2(1,1) + C1(4,2)*C2(2,1) + C1(4,3)*C2(3,1)
     &        + C1(4,4)*C2(4,1) + C1(5,4)*C2(5,1)
      C3(5,1) = C1(5,1)*C2(1,1) + C1(5,2)*C2(2,1) + C1(5,3)*C2(3,1)
     &        + C1(5,4)*C2(4,1) + C1(5,5)*C2(5,1)

      C3(1,2) = C1(1,1)*C2(2,1) + C1(2,1)*C2(2,2) + C1(3,1)*C2(3,2)
     &        + C1(4,1)*C2(4,2) + C1(5,1)*C2(5,2)
      C3(2,2) = C1(2,1)*C2(2,1) + C1(2,2)*C2(2,2) + C1(3,2)*C2(3,2)
     &        + C1(4,2)*C2(4,2) + C1(5,2)*C2(5,2)
      C3(3,2) = C1(3,1)*C2(2,1) + C1(3,2)*C2(2,2) + C1(3,3)*C2(3,2)
     &        + C1(4,3)*C2(4,2) + C1(5,3)*C2(5,2)
      C3(4,2) = C1(4,1)*C2(2,1) + C1(4,2)*C2(2,2) + C1(4,3)*C2(3,2)
     &        + C1(4,4)*C2(4,2) + C1(5,4)*C2(5,2)
      C3(5,2) = C1(5,1)*C2(2,1) + C1(5,2)*C2(2,2) + C1(5,3)*C2(3,2)
     &        + C1(5,4)*C2(4,2) + C1(5,5)*C2(5,2)

      C3(1,3) = C1(1,1)*C2(3,1) + C1(2,1)*C2(3,2) + C1(3,1)*C2(3,3)
     &        + C1(4,1)*C2(4,3) + C1(5,1)*C2(5,3)
      C3(2,3) = C1(2,1)*C2(3,1) + C1(2,2)*C2(3,2) + C1(3,2)*C2(3,3)
     &        + C1(4,2)*C2(4,3) + C1(5,2)*C2(5,3)
      C3(3,3) = C1(3,1)*C2(3,1) + C1(3,2)*C2(3,2) + C1(3,3)*C2(3,3)
     &        + C1(4,3)*C2(4,3) + C1(5,3)*C2(5,3)
      C3(4,3) = C1(4,1)*C2(3,1) + C1(4,2)*C2(3,2) + C1(4,3)*C2(3,3)
     &        + C1(4,4)*C2(4,3) + C1(5,4)*C2(5,3)
      C3(5,3) = C1(5,1)*C2(3,1) + C1(5,2)*C2(3,2) + C1(5,3)*C2(3,3)
     &        + C1(5,4)*C2(4,3) + C1(5,5)*C2(5,3)

      C3(1,4) = C1(1,1)*C2(4,1) + C1(2,1)*C2(4,2) + C1(3,1)*C2(4,3)
     &        + C1(4,1)*C2(4,4) + C1(5,1)*C2(5,4)
      C3(2,4) = C1(2,1)*C2(4,1) + C1(2,2)*C2(4,2) + C1(3,2)*C2(4,3)
     &        + C1(4,2)*C2(4,4) + C1(5,2)*C2(5,4)
      C3(3,4) = C1(3,1)*C2(4,1) + C1(3,2)*C2(4,2) + C1(3,3)*C2(4,3)
     &        + C1(4,3)*C2(4,4) + C1(5,3)*C2(5,4)
      C3(4,4) = C1(4,1)*C2(4,1) + C1(4,2)*C2(4,2) + C1(4,3)*C2(4,3)
     &        + C1(4,4)*C2(4,4) + C1(5,4)*C2(5,4)
      C3(5,4) = C1(5,1)*C2(4,1) + C1(5,2)*C2(4,2) + C1(5,3)*C2(4,3)
     &        + C1(5,4)*C2(4,4) + C1(5,5)*C2(5,4)

      C3(1,5) = C1(1,1)*C2(5,1) + C1(2,1)*C2(5,2) + C1(3,1)*C2(5,3)
     &        + C1(4,1)*C2(5,4) + C1(5,1)*C2(5,5)
      C3(2,5) = C1(2,1)*C2(5,1) + C1(2,2)*C2(5,2) + C1(3,2)*C2(5,3)
     &        + C1(4,2)*C2(5,4) + C1(5,2)*C2(5,5)
      C3(3,5) = C1(3,1)*C2(5,1) + C1(3,2)*C2(5,2) + C1(3,3)*C2(5,3)
     &        + C1(4,3)*C2(5,4) + C1(5,3)*C2(5,5)
      C3(4,5) = C1(4,1)*C2(5,1) + C1(4,2)*C2(5,2) + C1(4,3)*C2(5,3)
     &        + C1(4,4)*C2(5,4) + C1(5,4)*C2(5,5)
      C3(5,5) = C1(5,1)*C2(5,1) + C1(5,2)*C2(5,2) + C1(5,3)*C2(5,3)
     &        + C1(5,4)*C2(5,4) + C1(5,5)*C2(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKMLT2(W,C2,C3)
**********************************************************************
*                                                                    *
* Multiplies a 5*5 non-symmetric weight matrix by a 5*5 symmetric    *
* matrix to give a symmetric result (this is not necessarily the     *
* case).                                                             *
*                                                                    *
* Output is C3 = W.C2 (lower half only)                              *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION W(5,5),C2(5,5),C3(5,5)

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

      C3(1,1) = W(1,1)*C2(1,1) + W(1,2)*C2(2,1) + W(1,3)*C2(3,1)
     &        + W(1,4)*C2(4,1) + W(1,5)*C2(5,1)
      C3(2,1) = W(2,1)*C2(1,1) + W(2,2)*C2(2,1) + W(2,3)*C2(3,1)
     &        + W(2,4)*C2(4,1) + W(2,5)*C2(5,1)
      C3(3,1) = W(3,1)*C2(1,1) + W(3,2)*C2(2,1) + W(3,3)*C2(3,1)
     &        + W(3,4)*C2(4,1) + W(3,5)*C2(5,1)
      C3(4,1) = W(4,1)*C2(1,1) + W(4,2)*C2(2,1) + W(4,3)*C2(3,1)
     &        + W(4,4)*C2(4,1) + W(4,5)*C2(5,1)
      C3(5,1) = W(5,1)*C2(1,1) + W(5,2)*C2(2,1) + W(5,3)*C2(3,1)
     &        + W(5,4)*C2(4,1) + W(5,5)*C2(5,1)

      C3(2,2) = W(2,1)*C2(2,1) + W(2,2)*C2(2,2) + W(2,3)*C2(3,2)
     &        + W(2,4)*C2(4,2) + W(2,5)*C2(5,2)
      C3(3,2) = W(3,1)*C2(2,1) + W(3,2)*C2(2,2) + W(3,3)*C2(3,2)
     &        + W(3,4)*C2(4,2) + W(3,5)*C2(5,2)
      C3(4,2) = W(4,1)*C2(2,1) + W(4,2)*C2(2,2) + W(4,3)*C2(3,2)
     &        + W(4,4)*C2(4,2) + W(4,5)*C2(5,2)
      C3(5,2) = W(5,1)*C2(2,1) + W(5,2)*C2(2,2) + W(5,3)*C2(3,2)
     &        + W(5,4)*C2(4,2) + W(5,5)*C2(5,2)

      C3(3,3) = W(3,1)*C2(3,1) + W(3,2)*C2(3,2) + W(3,3)*C2(3,3)
     &        + W(3,4)*C2(4,3) + W(3,5)*C2(5,3)
      C3(4,3) = W(4,1)*C2(3,1) + W(4,2)*C2(3,2) + W(4,3)*C2(3,3)
     &        + W(4,4)*C2(4,3) + W(4,5)*C2(5,3)
      C3(5,3) = W(5,1)*C2(3,1) + W(5,2)*C2(3,2) + W(5,3)*C2(3,3)
     &        + W(5,4)*C2(4,3) + W(5,5)*C2(5,3)

      C3(4,4) = W(4,1)*C2(4,1) + W(4,2)*C2(4,2) + W(4,3)*C2(4,3)
     &        + W(4,4)*C2(4,4) + W(4,5)*C2(5,4)
      C3(5,4) = W(5,1)*C2(4,1) + W(5,2)*C2(4,2) + W(5,3)*C2(4,3)
     &        + W(5,4)*C2(4,4) + W(5,5)*C2(5,4)

      C3(5,5) = W(5,1)*C2(5,1) + W(5,2)*C2(5,2) + W(5,3)*C2(5,3)
     &        + W(5,4)*C2(5,4) + W(5,5)*C2(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  5.01/08 23/02/94  14.19.05  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKNORM(S,IERR)
*-----------------------------------------Updates 27/07/93-------
**: FKNORM 30907 SB. Error 17 now tan(theta)>5.
**********************************************************************
*                                                                    *
* Normalise the theta and phi components of the state vector S       *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*       IERR =   0 ; normal termination                              *
*       IERR = 116 ; tan(theta) > 10**6: reset to 10**6              *
*                  | x or y > 10**4: reset to 10**4                  *
*       IERR =  17 ; tan(theta) > 50                                 *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=4)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

      DIMENSION S(5)

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

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

      IERR = 0

      IF (S(4).LT.0.D0) THEN
         S(4) = DABS(S(4))
         S(5) = S(5) + PI
      ENDIF

      IF (S(4).GT.1.D6) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,ITHGP2,IERR)
         S(4) = 1.D6
      ELSEIF (S(4).GT.50.D0) THEN
         CALL FKERR(IUTIL,IROUT,IWARN,ITHG1,IERR)
      ENDIF

      IF (DABS(S(5)).GT.TWOPI) S(5) = DMOD(S(5),TWOPI)
      IF (S(5).LT.0.D0) S(5) = S(5) + TWOPI

      IF (ABS(S(1)).GT.1.D4) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,ITHGP2,IERR)
         S(1) = SIGN(1.D4,S(1))
      ENDIF

      IF (ABS(S(2)).GT.1.D4) THEN
         CALL FKERR(IUTIL,IROUT,IFATAL,ITHGP2,IERR)
         S(2) = SIGN(1.D4,S(2))
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.46.09  by  Curtis A. Meyer
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      DOUBLE PRECISION FUNCTION FKPROB(CHISQ,NFREE)
*-----------------------------------------Updates 07/02/92-------
**: FKPROB 30205.SB. Change to avoid UNDEF warning.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Double precision version of CERNLIB PROB function                  *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION CHISQ
      REAL CHI2

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

      CHI2   = SNGL(CHISQ)
      CHPROB = PROB(CHI2,NFREE)
      FKPROB = DBLE(CHPROB)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKRPXY(SIN,CIN,SOUT,COUT)
**********************************************************************
*                                                                    *
* Transform a state vector and covariance from (R,PHI) to (x,y)      *
*                                                                    *
* Both are assumed to be at fixed z.                                 *
*                                                                    *
*                        *** NOT TESTED ***                          *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION SIN(5),CIN(5,5),SOUT(5),COUT(5,5)

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

      CALL UCOPY(SIN(3),SOUT(3),6)
      CALL UCOPY(CIN(3,3),COUT(3,3),26)

      CPHI = COS(SIN(2))
      C2PHI = CPHI*CPHI
      S2PHI = 1.D0 - C2PHI
      SPHI = SQRT(S2PHI)
      CSPHI = CPHI*SPHI
      R = SIN(1)
      R2 = R*R

      X = R*CPHI
      Y = R*SPHI
      SOUT(1) = X
      SOUT(2) = Y

      CRR = CIN(1,1)
      CRP = CIN(2,1)
      CPP = CIN(2,2)

      COUT(1,1) = C2PHI*CRR - 2.D0*Y*CPHI*CRP + Y*Y*CPP
      COUT(2,1) = CSPHI*CRR + (C2PHI - S2PHI)*R*CRP - X*Y*CPP
      COUT(3,1) = CPHI*CIN(3,1) - Y*CIN(3,2)
      COUT(4,1) = CPHI*CIN(4,1) - Y*CIN(4,2)
      COUT(5,1) = CPHI*CIN(5,1) - Y*CIN(5,2)

      COUT(2,2) = S2PHI*CRR + 2.D0*X*SPHI*CRP + X*X*CPP
      COUT(3,2) = SPHI*CIN(3,1) + X*CIN(3,2)
      COUT(4,2) = SPHI*CIN(4,1) + X*CIN(4,2)
      COUT(5,2) = SPHI*CIN(5,1) + X*CIN(5,2)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKRTOZ(SIN,CIN,BZ,COUT)
**********************************************************************
*                                                                    *
* Transform a covariance matrix from fixed R to fixed z              *
*                                                                    *
* Assumed to be in terms of (R,PHI)                                  *
*                                                                    *
*                        *** NOT TESTED ***                          *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION SIN(5),CIN(5,5),COUT(5,5)

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

      CPMP = COS(SIN(5) - SIN(2))
      SPMP = SQRT(1.D0 - CPMP*CPMP)

      DR = SIN(4)*CPMP
      DPHI = SIN(4)*SPMP/(SIN(1)*DR)
      DP = (SIN(3)*BZ*SQRT(1.D0 + SIN(4)*SIN(4)))/DR

      DR2 = CIN(1,1)*DR*DR
      DPHI2 = DPHI*DPHI
      DP2 = DP*DP

      CALL UCOPY(CIN(3,2),COUT(3,2),38)

      COUT(1,1) = DR2
      COUT(2,1) = DPHI*DR2
      COUT(3,1) = 0.D0
      COUT(4,1) = 0.D0
      COUT(5,1) = DP*DR2

      COUT(2,2) = COUT(2,2) + DPHI2*DR2
      COUT(5,2) = COUT(5,2) + DPHI*DP*DR2

      COUT(5,5) = COUT(5,5) + DP2*DR2

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.36  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKSUB(C1,C2,C3)
**********************************************************************
*                                                                    *
* Subtracts two 5*5 symmetric matrices                               *
*                                                                    *
* Output is C3 = C1 - C2 (lower half only)                           *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C1(5,5),C2(5,5),C3(5,5)

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

      C3(1,1) = C1(1,1) - C2(1,1)
      C3(2,1) = C1(2,1) - C2(2,1)
      C3(3,1) = C1(3,1) - C2(3,1)
      C3(4,1) = C1(4,1) - C2(4,1)
      C3(5,1) = C1(5,1) - C2(5,1)

      C3(2,2) = C1(2,2) - C2(2,2)
      C3(3,2) = C1(3,2) - C2(3,2)
      C3(4,2) = C1(4,2) - C2(4,2)
      C3(5,2) = C1(5,2) - C2(5,2)

      C3(3,3) = C1(3,3) - C2(3,3)
      C3(4,3) = C1(4,3) - C2(4,3)
      C3(5,3) = C1(5,3) - C2(5,3)

      C3(4,4) = C1(4,4) - C2(4,4)
      C3(5,4) = C1(5,4) - C2(5,4)

      C3(5,5) = C1(5,5) - C2(5,5)

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.53  by  Girish D. Patel
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKXYRP(SIN,CIN,SOUT,COUT)
**********************************************************************
*                                                                    *
* Transform a state vector and covariance from (x,y) to (R,PHI)      *
*                                                                    *
* Both are assumed to be at fixed z.                                 *
*                                                                    *
*                        *** NOT TESTED ***                          *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION SIN(5),CIN(5,5),SOUT(5),COUT(5,5)

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

      CALL UCOPY(SIN(3),SOUT(3),6)
      CALL UCOPY(CIN(3,3),COUT(3,3),26)

      X = SIN(1)
      Y = SIN(2)
      X2 = X*X
      Y2 = Y*Y
      XY = X*Y
      XI = 1.D0/X
      X2I = XI*XI
      YXI = Y*XI

      SOUT(1) = SQRT(X2 + Y2)
      SOUT(2) = ATAN2(Y,X)

      RI = 1.D0/SOUT(1)
      R2I = RI*RI
      CPHI = COS(SOUT(2))
      C2PHI = CPHI*CPHI

      CXX = CIN(1,1)
      CYY = CIN(2,2)
      CXY = CIN(2,1)

      COUT(1,1) = (X2*CXX + 2.D0*XY*CXY + Y2*CYY)*R2I
      COUT(2,1) = (Y*(CXX + CYY) + (X + Y2*XI)*CXY)*CPHI*RI*XI
      COUT(3,1) = (X*CIN(3,1) + Y*CIN(3,2))*RI
      COUT(4,1) = (X*CIN(4,1) + Y*CIN(4,2))*RI
      COUT(5,1) = (X*CIN(5,1) + Y*CIN(5,2))*RI

      COUT(2,2) = (Y2*X2I*CXX - 2.D0*YXI*CXY + CYY)*C2PHI*X2I
      COUT(3,2) = (YXI*CIN(3,1) + CIN(3,2))*CPHI*XI
      COUT(4,2) = (YXI*CIN(4,1) + CIN(4,2))*CPHI*XI
      COUT(5,2) = (YXI*CIN(5,1) + CIN(5,2))*CPHI*XI

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  2.01/03 13/02/91  16.06.35  by  Stephen Burke
*-- Author : S.Burke / J.V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKZTOR(SIN,CIN,BZ,COUT)
**********************************************************************
*                                                                    *
* Transform a covariance matrix from fixed z to fixed R              *
*                                                                    *
* Assumed to be in terms of (R,PHI)                                  *
*                                                                    *
*                        *** NOT TESTED ***                          *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION SIN(5),CIN(5,5),COUT(5,5)

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

      CPMP = COS(SIN(5) - SIN(2))
      SPMP = (1.D0 - CPMP*CPMP)

      DR = SIN(4)*CPMP
      DPHI = SIN(4)*SPMP/SIN(1)
      DP = SIN(3)*BZ*SQRT(1.D0 + SIN(4)*SIN(4))

      DZ2 = CIN(1,1)/(DR*DR)
      DPHI2 = DPHI*DPHI
      DP2 = DP*DP

      CALL UCOPY(CIN(2,2),COUT(2,2),38)

      COUT(1,1) = DZ2
      COUT(2,1) = DPHI*DZ2
      COUT(3,1) = 0.D0
      COUT(4,1) = 0.D0
      COUT(5,1) = DP*DZ2

      COUT(2,2) = COUT(2,2) + DPHI2*DZ2
      COUT(5,2) = COUT(5,2) + DPHI*DP*DZ2

      COUT(5,5) = COUT(5,5) + DP2*DZ2

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZ :  4.03/13 15/04/94  12.12.06  by  Gaby Raedel
*CMZU:  4.00/01 21/09/93  16.21.34  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.03  by  Stephen Burke
*CMZU:  3.06/02 31/08/92  16.51.33  by  Stephen Burke
*-- Author : S.Burke
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKITOE(Z,SINT,CINT,EXT)
*-----------------------------------------Updates 21/09/92-------
**: FKITOE.......SB. Cope better (?) with zero field.
*-----------------------------------------Updates 07/09/93-------
**: FKITOE 40000 SB. Only print field warning in production run.
*-----------------------------------------Updates 15/04/94-------
**: FKITOE 40313.GR. only 10 printouts if zero field
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Convert an `internal' vector and covariance to an `external'       *
* state vector.                                                      *
*                                                                    *
* External: 1/r, phi, theta, x, y, z, IPTYPE, covariance             *
* Internal: x, y, q/p, tan(theta), phi                               *
*                                                                    *
* The `external' covariance is packed with COVCP.                    *
*                                                                    *
**********************************************************************

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

      PARAMETER (BCONV=-0.0002998)

      DOUBLE PRECISION Z,SINT(5),CINT(5,5),COS2TH,DIFF3,DIFF4
      DIMENSION EXT(16),R(3),B(3),COV(15)
      DATA  NPRMF/0/

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

* Get the field
      R(1) = SINT(1)
      R(2) = SINT(2)
      R(3) = Z
      CALL GUFLD(R,B)

* Trap zero field problems
      IF (ABS(B(3)).LT.1.0E-2) B(3) = SIGN(1.0E-2,B(3))

      IF (ABS(B(3)).LT.5. .OR. ABS(B(3)).GT.15.) THEN
         CALL ERRLOG(334,'S:FKITOE: Bad magnetic field')
         CALL H1ENVI(JS,JP,NP)
         IF (JS.NE.0.AND.NPRMF.LT.10)THEN
           WRITE(6,*) '*** Magnetic field is ',B(3),' ***'
           NPRMF=NPRMF+1
         ENDIF
      ENDIF

* Transform the state vector
      IF (ABS(SINT(4)).GT.1.0D-6) THEN
         EXT(1) = SINT(3)*BCONV*B(3)*DSQRT(1.D0/SINT(4)**2 + 1.D0)
      ELSE
         EXT(1) = SINT(3)*BCONV*B(3)*1.0E6
      ENDIF
      EXT(2) = SINT(5)
      IF (EXT(2).GT.PI) EXT(2) = EXT(2) - TWOPI
      EXT(3) = DATAN(SINT(4))
      EXT(4) = SINT(1)
      EXT(5) = SINT(2)
      EXT(6) = Z
      IPTYPE = 2
      CALL UCOPY(IPTYPE,EXT(7),1)

* Differential coefficients
      COS2TH = 1.D0/(1.D0 + SINT(4)**2)
      IF (ABS(SINT(3)).GT.1.0D-10) THEN
         DIFF3 = EXT(1)/SINT(3)
      ELSEIF (ABS(SINT(4)).GT.1.0D-6) THEN
         DIFF3 = BCONV*B(3)*DSQRT(1.D0/SINT(4)**2 + 1.D0)
      ELSE
         DIFF3 = BCONV*B(3)*1.0E6
      ENDIF
      IF (ABS(SINT(4)).GT.1.0D-6) THEN
         DIFF4 = -EXT(1)*COS2TH/SINT(4)
      ELSE
         DIFF4 = -EXT(1)*COS2TH*1.0E6
      ENDIF

* Transform the covariance ...
      COV(1)  = CINT(3,3)*DIFF3**2 + 2.D0*CINT(4,3)*DIFF3*DIFF4
     &        + CINT(4,4)*DIFF4**2

      COV(2)  = CINT(5,3)*DIFF3 + CINT(5,4)*DIFF4
      COV(3)  = CINT(5,5)

      COV(4)  = (CINT(4,3)*DIFF3 + CINT(4,4)*DIFF4)*COS2TH
      COV(5)  = CINT(5,4)*COS2TH
      COV(6)  = CINT(4,4)*COS2TH**2

      COV(7)  = CINT(3,1)*DIFF3 + CINT(4,1)*DIFF4
      COV(8)  = CINT(5,1)
      COV(9)  = CINT(4,1)*COS2TH
      COV(10) = CINT(1,1)

      COV(11) = CINT(3,2)*DIFF3 + CINT(4,2)*DIFF4
      COV(12) = CINT(5,2)
      COV(13) = CINT(4,2)*COS2TH
      COV(14) = CINT(2,1)
      COV(15) = CINT(2,2)

* ... and pack
      CALL COVCP(5,COV,EXT(8),-2)

      RETURN
      END
*CMZ :  8.05/01 07/10/96  17.19.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.26  by  Stephen Burke
*CMZU:  5.01/08 28/06/94  10.46.13  by  Stephen Burke
*CMZU:  3.04/04 06/08/92  16.58.21  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill various HBOOK histograms to analyse the Kalman filter output.
*
*HTMLI     : Describe the Input variables to the routine
*
* JPL   - the current z plane number (1 to 72), or 0 for general histograms
* RES   - residuals (REAL*8 2-vector)
* CHISQ - chi-squared (REAL*8)
* NPS   - the number of planar segments
* NRS   - the number of radial segments
*
* Information in various common blocks
*
*HTMLO     : Describe the Output of the routine
*
* Histograms are filled
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKANAL(JPL,RES,CHISQ,NPS,NRS)
*-----------------------------------------Updates 06/08/92-------
**: FKANAL.......SB. Minor bug fixed.
*-----------------------------------------Updates 24/01/92-------
**: FKANAL 30205.SB. Digi with wrong drift sign counts as a bad hit.
**: FKANAL 30205.SB. Phi histograms added.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Analyse the KF output                                              *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION RES(2),CHISQ,FKDPHI

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKTRUE.
*KEEP,FKPROJ.
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKHIST.
      DIMENSION IPLANE(12)
      SAVE IPLANE
      DATA IPLANE/1,12,13,24,25,36,37,48,49,60,61,72/
*KEEP,FKDBG.
*KEND.

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

      CALL HCDIR('//PAWC/'//CKDBG,' ')

      IF (JPL.GT.0) THEN
         IF (LTRPL(JPL) .AND. LTRPLD(JPL)) THEN
            IBASE = 315
         ELSE
            IBASE = 325
         ENDIF
         CALL HFILL(IBASE+1+5*IRP(JPL),SNGL(RES(1)),0.,1.)
         IF (MES(JPL).EQ.2) CALL HFILL(IBASE+12,SNGL(RES(2)),0.,1.)
         CALL HFILL(IBASE+5+5*IRP(JPL),SNGL(CHISQ),0.,1.)
         RETURN
      ENDIF

* Decode steering
      IDIFF = MOD(IHFK,10)
      IRES  = MOD(IHFK/10,10)
      IPLN  = MOD(IHFK/100,10)

      IF (LTRUE .AND. IDIFF.GT.0) THEN
         IF (CSMT(1,1,JSTART).GT.0.0D0)
     &       CALL HFILL(101,SNGL((SSMT(1,JSTART)-TRUE(1,JSTART))/
     &                       DSQRT(CSMT(1,1,JSTART))),0.,1.)
         IF (CSMT(2,2,JSTART).GT.0.0D0)
     &       CALL HFILL(102,SNGL((SSMT(2,JSTART)-TRUE(2,JSTART))/
     &                       DSQRT(CSMT(2,2,JSTART))),0.,1.)
         IF (CSMT(3,3,JSTART).GT.0.0D0)
     &       CALL HFILL(103,SNGL((SSMT(3,JSTART)-TRUE(3,JSTART))/
     &                       DSQRT(CSMT(3,3,JSTART))),0.,1.)
         IF (CSMT(4,4,JSTART).GT.0.0D0)
     &       CALL HFILL(104,SNGL((SSMT(4,JSTART)-TRUE(4,JSTART))/
     &                       DSQRT(CSMT(4,4,JSTART))),0.,1.)
         IF (CSMT(5,5,JSTART).GT.0.0D0)
     &       CALL HFILL(105,SNGL((SSMT(5,JSTART)-TRUE(5,JSTART))/
     &                       DSQRT(CSMT(5,5,JSTART))),0.,1.)
         IF (TRUE(3,JSTART).EQ.0.0D0) TRUE(3,JSTART) = 1.0D-20
         PLOG   = -DLOG10(DABS(TRUE(3,JSTART)))
         THETA  = DATAN(TRUE(4,JSTART))
         PHI    = TRUE(5,JSTART)
C         D1OP   = DABS(SSMT(3,JSTART)) - DABS(TRUE(3,JSTART))
         D1OP   = SSMT(3,JSTART) - TRUE(3,JSTART)
         DTHETA = DATAN(SSMT(4,JSTART)) - THETA
         DPHI   = FKDPHI(SSMT(5,JSTART),TRUE(5,JSTART))
         IF (PLOG.LT.0. .AND. PLOG.GT.-0.3) THEN
            CALL HFILL(230,FLOAT(NPS+NRS),D1OP,1.)
         ELSEIF (PLOG.LT.0.5) THEN
            CALL HFILL(231,FLOAT(NPS+NRS),D1OP,1.)
         ELSEIF (PLOG.GE.0.5) THEN
            CALL HFILL(232,FLOAT(NPS+NRS),D1OP,1.)
         ENDIF
         CALL HFILL(233,PLOG,D1OP,1.)
         CALL HFILL(234,PLOG,DTHETA,1.)
         CALL HFILL(235,PLOG,DPHI,1.)
         CALL HFILL(243,THETA,D1OP,1.)
         CALL HFILL(244,THETA,DTHETA,1.)
         CALL HFILL(245,THETA,DPHI,1.)
         CALL HFILL(253,PHI,D1OP,1.)
         CALL HFILL(254,PHI,DTHETA,1.)
         CALL HFILL(255,PHI,DPHI,1.)
      ENDIF

      IF (IRES.GT.0) THEN
         DO 100 KPL=1,JPLMAX
            IF (LMES(KPL)) THEN
               IF (LTRPL(KPL) .AND. LTRPLD(KPL)) THEN
                  IBASE = 295
               ELSE
                  IBASE = 305
               ENDIF
               CALL HFILL(IBASE+1+5*IRP(KPL),SNGL(RSMT(1,KPL)),0.,1.)
               IF (MES(KPL).EQ.2)
     &            CALL HFILL(IBASE+12,SNGL(RSMT(2,KPL)),0.,1.)
               CALL HFILL(IBASE+5+5*IRP(KPL),SNGL(CHISMT(KPL)),0.,1.)
            ENDIF
 100     CONTINUE
      ENDIF

      IF (IPLN.GT.0) THEN
         DO 200 I=1,12
            KPL = JFTPL(IPLANE(I))
            IF (LMES(KPL) .AND. KPL.GT.0) THEN
               CHPROB=PROB(SNGL(CHIFIL(KPL)),MES(KPL))
               CALL HFILL(KPL+500,CHPROB,0.,1.)
               CHPROB=PROB(SNGL(CHISMT(KPL)),MES(KPL))
               CALL HFILL(KPL+600,CHPROB,0.,1.)
               IF (LTRUE) THEN
                  CHPROB=PROB(SNGL(CHITRU(KPL)),5)
                  CALL HFILL(KPL+700,CHPROB,0.,1.)
               ENDIF
               CALL HFILL(KPL+800,SNGL(RSMT(1,KPL)),0.,1.)
               IF (MES(KPL).EQ.2)
     &            CALL HFILL(KPL+900,SNGL(RSMT(2,KPL)),0.,1.)
            ENDIF
 200     CONTINUE
      ENDIF

      RETURN
      END
*CMZ :  8.05/01 07/10/96  17.19.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.27  by  Stephen Burke
*CMZU:  5.01/08 21/06/94  19.05.09  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.48.18  by  Curtis A. Meyer
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Book diagnostic histograms for the Kalman filter.
*
*HTMLI     : Describe the Input variables to the routine
*
* Steering parameters in various common blocks
*
*HTMLO     : Describe the Output of the routine
*
* Booked histograms in area //PAWC/FKDBG
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKHBK
*-----------------------------------------Updates 24/01/92-------
**: FKHBK 30205.SB.  Phi histograms added.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Book diagnostic histograms                                         *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKTRUE.
*KEEP,FKHIST.
      DIMENSION IPLANE(12)
      SAVE IPLANE
      DATA IPLANE/1,12,13,24,25,36,37,48,49,60,61,72/
*KEEP,FKDBG.
*KEND.

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

      CALL HCDIR('//PAWC',' ')
      CALL HMDIR(CKDBG,'S')

* Decode steering
      IDIFF = MOD(IHFK,10)
      IRES  = MOD(IHFK/10,10)
      IPLN  = MOD(IHFK/100,10)

      LRSMT = .TRUE.

      IF (LTRUTH .AND. IDIFF.GT.0) THEN
         CALL HBOOK1(101,'PULL ON X$',60,-6.,6.,0.)
         CALL HBOOK1(102,'PULL ON Y$',60,-6.,6.,0.)
         CALL HBOOK1(103,'PULL ON Q/P$',60,-6.,6.,0.)
         CALL HBOOK1(104,'PULL ON TAN(THETA)$',60,-6.,6.,0.)
         CALL HBOOK1(105,'PULL ON PHI$',60,-6.,6.,0.)
         CALL HBOOK2(230,'DELTA(1/P) VS NSEG (LOW p)$',10,0.,10.,
     &               100,-1.0,1.0,0.)
         CALL HBOOK2(231,'DELTA(1/P) VS NSEG (MED P)$',10,0.,10.,
     &               100,-1.0,1.0,0.)
         CALL HBOOK2(232,'DELTA(1/P) VS NSEG (HIGH P)$',10,0.,10.,
     &               100,-1.0,1.0,0.)
         CALL HBOOK2(233,'DELTA(1/P) VS LOG(P)$',60,-3.,3.,
     &               100,-1.0,1.0,0.)
         CALL HBOOK2(234,'DELTA(THETA) VS LOG(P)$',60,-3.,3.,
     &               60,-0.06,0.06,0.)
         CALL HBOOK2(235,'DELTA(PHI) VS LOG(P)$',60,-3.,3.,
     &               60,-0.06,0.06,0.)
         CALL HBOOK2(243,'DELTA(1/P) VS THETA$',80,0.,0.4,
     &               60,-0.6,0.6,0.)
         CALL HBOOK2(244,'DELTA(THETA) VS THETA$',80,0.,0.4,
     &               60,-0.06,0.06,0.)
         CALL HBOOK2(245,'DELTA(PHI) VS THETA$',80,0.,0.4,
     &               60,-0.06,0.06,0.)
         CALL HBOOK2(253,'DELTA(1/P) VS PHI$',64,0.,6.4,
     &               60,-0.6,0.6,0.)
         CALL HBOOK2(254,'DELTA(THETA) VS PHI$',64,0.,6.4,
     &               60,-0.06,0.06,0.)
         CALL HBOOK2(255,'DELTA(PHI) VS PHI$',64,0.,6.4,
     &               60,-0.06,0.06,0.)
      ENDIF

      IF (IRES.GT.0) THEN
         CALL HBOOK1(301,'DRIFT RESID FOR OLD TRUE POINTS (PLANAR)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(305,'CHISQ FOR OLD TRUE POINTS (PLANAR)$'
     &,              100,0.,10.,0.)
         CALL HBOOK1(306,'DRIFT RESID FOR OLD TRUE POINTS (RADIAL)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(307,'RADIUS RESID FOR OLD TRUE POINTS (RADIAL)$'
     &,              100,-25.,25.,0.)
         CALL HBOOK1(310,'CHISQ FOR OLD TRUE POINTS (RADIAL)$'
     &,              100,0.,10.,0.)
      ENDIF

      IF (LTRUTH .AND. IRES.GT.0) THEN
         CALL HBOOK1(311,'DRIFT RESID FOR OLD WRONG POINTS (PLANAR)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(315,'CHISQ FOR OLD WRONG POINTS (PLANAR)$'
     &,              100,0.,10.,0.)
         CALL HBOOK1(316,'DRIFT RESID FOR OLD WRONG POINTS (RADIAL)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(317,'RADIUS RESID FOR OLD WRONG POINTS (RADIAL)$'
     &,              100,-25.,25.,0.)
         CALL HBOOK1(320,'CHISQ FOR OLD WRONG POINTS (RADIAL)$'
     &,              100,0.,10.,0.)
      ENDIF

      IF (LPOINT .AND. IRES.GT.0) THEN
         CALL HBOOK1(321,'DRIFT RESID FOR NEW TRUE POINTS (PLANAR)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(325,'CHISQ FOR NEW TRUE POINTS (PLANAR)$'
     &,              100,0.,10.,0.)
         CALL HBOOK1(326,'DRIFT RESID FOR NEW TRUE POINTS (RADIAL)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(327,'RADIUS RESID FOR NEW TRUE POINTS (RADIAL)$'
     &,              100,-25.,25.,0.)
         CALL HBOOK1(330,'CHISQ FOR NEW TRUE POINTS (RADIAL)$'
     &,              100,0.,10.,0.)
      ENDIF

      IF (LPOINT .AND. LTRUTH .AND. IRES.GT.0) THEN
         CALL HBOOK1(331,'DRIFT RESID FOR NEW WRONG POINTS (PLANAR)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(335,'CHISQ FOR NEW WRONG POINTS (PLANAR)$'
     &,              100,0.,10.,0.)
         CALL HBOOK1(336,'DRIFT RESID FOR NEW WRONG POINTS (RADIAL)$'
     &,              100,-0.25,0.25,0.)
         CALL HBOOK1(337,'RADIUS RESID FOR NEW WRONG POINTS (RADIAL)$'
     &,              100,-25.,25.,0.)
         CALL HBOOK1(340,'CHISQ FOR NEW WRONG POINTS (RADIAL)$'
     &,              100,0.,10.,0.)
      ENDIF

      IF (IPLN.GT.0) THEN
         LRFIL = .TRUE.
         DO 100 I=1,12
            IPL = IPLANE(I)
            CALL HBOOK1(IPL+500,'FILTERED PROB$',100,0.,1.,0.)
            CALL HBOOK1(IPL+600,'SMOOTHED PROB$',100,0.,1.,0.)
            IF (LTRUTH) CALL HBOOK1(IPL+700,'SMOOTHED PROB (TRUE)$'
     &,                             100,0.,1.,0.)
            CALL HBOOK1(IPL+800,'DRIFT RESIDUALS$',100,-0.1,0.1,0.)
            CALL HBOOK1(IPL+900,'RADIAL RESIDUALS$',100,-10.,10.,0.)
 100     CONTINUE
      ENDIF

      CALL HBPRO(0,0.)
      CALL HMINIM(0,0.)
      CALL HIDOPT(0,'INTE')

      CALL HCDIR('//PAWC',' ')

      RETURN
      END
*CMZ :  8.05/01 07/10/96  17.19.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.27  by  Stephen Burke
*CMZU:  3.02/07 27/03/92  10.48.18  by  Curtis A. Meyer
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Print diagnostic histograms.
*
*HTMLI     : Describe the Input variables to the routine
*
* Steering information in various common blocks
*
*HTMLO     : Describe the Output of the routine
*
* Histograms are printed (with HPRINT)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FKHPR
*-----------------------------------------Updates 07/02/92-------
**: FKHPR 30205.SB.  Remove unused FKMEAS sequence.
*-----------------------------------------Updates 24/01/92-------
**: FKHPR 30205.SB.  Print histograms only if they exist.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Print diagnostic histograms                                        *
*                                                                    *
**********************************************************************

      LOGICAL HEXIST

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKTRUE.
*KEEP,FKHIST.
      DIMENSION IPLANE(12)
      SAVE IPLANE
      DATA IPLANE/1,12,13,24,25,36,37,48,49,60,61,72/
*KEEP,FKDBG.
*KEND.

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

      CALL HCDIR('//PAWC/'//CKDBG,' ')

      DO 100 I=101,105
         IF (HEXIST(I)) CALL HPRINT(I)
 100  CONTINUE

      DO 200 I=211,255
         IF (HEXIST(I)) CALL HPRINT(I)
 200  CONTINUE

      DO 300 I=301,340
         IF (HEXIST(I)) CALL HPRINT(I)
 300  CONTINUE

      DO 400 I=1,12
         IPL = IPLANE(I)
         IF (JFTPL(IPL).LE.0) GOTO 400
         IF (HEXIST(IPL+500)) CALL HPRINT(IPL+500)
         IF (HEXIST(IPL+600)) CALL HPRINT(IPL+600)
         IF (HEXIST(IPL+700)) CALL HPRINT(IPL+700)
         IF (HEXIST(IPL+800)) CALL HPRINT(IPL+800)
         IF (HEXIST(IPL+900) .AND. HSUM(IPL+900).GT.0)
     &      CALL HPRINT(IPL+900)
 400  CONTINUE

      CALL HCDIR('//PAWC',' ')

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  3.08/03 04/03/93  13.48.04  by  Stephen J. Maxfield
*-- Author : S.Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Calculate a particle charge from a PDG code
*
*HTMLI     : Describe the Input variables to the routine
*
* IPDG - PDG code
*
*HTMLO     : Describe the Output of the routine
*
* The return value is the signed charge (zero for unknown values)
*
*HTMLE     : Terminates the HTML documentation
*
      INTEGER FUNCTION FFCHG(IPDG)
*-----------------------------------------Updates 03/03/93-------
**: FFCHG .......SB. Protect against odd codes.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Work out the particle charge from the PDG code                     *
*                                                                    *
**********************************************************************

      DIMENSION IQUARK(6),ILEPT(27)
      SAVE IQUARK,ILEPT

      DATA IQUARK/-1,2,-1,2,-1,2/
      DATA ILEPT/-1,0,-1,0,-1,8*0,1,12*0,1/

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

* Zero will get this particle ignored
      FFCHG = 0

      IAPDG = IABS(IPDG)
      IF (IAPDG.LE.10) RETURN

      IF (IAPDG.LT.38) THEN
         FFCHG = ILEPT(IAPDG-10)
         IF (IPDG.LT.0) FFCHG = -FFCHG
         RETURN
      ENDIF

* Special codes
      IF (IAPDG.GT.490 .AND. IAPDG.LT.497) THEN
         IF (IAPDG.EQ.491 .OR. IAPDG.EQ.492) THEN
* Deuteron/triton
            FFCHG = 1
         ELSEIF (IAPDG.EQ.493) THEN
* Alpha
            FFCHG = 2
         ENDIF
* else geantino/showino
         IF (IPDG.LT.0) FFCHG = -FFCHG
         RETURN
      ENDIF

      IQ1 = IAPDG/10   - (IAPDG/100)*10
      IQ2 = IAPDG/100  - (IAPDG/1000)*10
      IQ3 = IAPDG/1000 - (IAPDG/10000)*10

      IF (IQ1.GT.6 .OR. IQ2.GT.6 .OR. IQ3.GT.6) RETURN

      IF (IQ3.GT.0) THEN
         FFCHG = (IQUARK(IQ1) + IQUARK(IQ2) + IQUARK(IQ3))/3
      ELSEIF (IQ2.EQ.(IQ2/2)*2) THEN
         FFCHG = (IQUARK(IQ2) - IQUARK(IQ1))/3
      ELSE
         FFCHG = (IQUARK(IQ1) - IQUARK(IQ2))/3
      ENDIF

      IF (IPDG.LT.0) FFCHG = -FFCHG

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  3.04/01 02/06/92  17.12.31  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Updates diagnostic arrays when a new hit has been found by FKHUNT
*
*HTMLI     : Describe the Input variables to the routine
*
* JPL   - z plane number (1 to 72)
* JTYPE - 1 for planar, 2 for radial
* JDIG  - hit index in FPLC/FRLC
*
* Information in various common blocks
*
* FRPX/FRRX banks (true hit information)
*
*HTMLO     : Describe the Output of the routine
*
* Sets LTRPL(JPL) (in /FKDBG/) to .TRUE. if the hit belongs to the track,
* and LTRPLD(JPL) to .TRUE. if it also has the correct drift sign.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFCHTR(JPL,JTYPE,JDIG)
*-----------------------------------------Updates 02/06/92-------
**: FVCHTR.......SB. Change loop indices to please farm.
*-----------------------------------------Updates 24/01/92-------
**: FFCHTR 30205.SB. Check to see if the drift sign is correct.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Update LTRPL for a new digi (found by FKHUNT)                      *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*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 (INDRSX(JTYPE).LE.0) THEN
         LTRPL(JPL)  = .TRUE.
         LTRPLD(JPL) = .TRUE.
         RETURN
      ENDIF

      LTRPL(JPL)  = .FALSE.
      LTRPLD(JPL) = .FALSE.

      ILOOP = IW(INDRSX(JTYPE)+2)
      DO 100 JHIT=1,ILOOP
         IFLAG = IBTAB(INDRSX(JTYPE),1,JHIT)
         JSTR  = IBTAB(INDRSX(JTYPE),2,JHIT)
         IDIG  = IBTAB(INDRSX(JTYPE),3,JHIT)
         IF (JSTR.EQ.JTRTR .AND. IFLAG.LT.512 .AND. IDIG.EQ.JDIG) THEN
            LTRPL(JPL) = .TRUE.
            ISGN = MOD(IBTAB(INDX(JTYPE),2,JDIG),2)
            IF (MOD(IFLAG,2).EQ.ISGN) LTRPLD(JPL) = .TRUE.
            RETURN
         ENDIF
 100  CONTINUE

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  7.01/00 01/06/95  15.23.52  by  Stephen Burke
*CMZU:  5.03/00 27/10/94  13.07.30  by  Stephen Burke
*CMZU:  3.09/01 03/05/93  15.18.59  by  Stephen Burke
*-- Author : S.Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Book diagnostic histograms (HBOOK)
*
*HTMLI     : Describe the Input variables to the routine
*
* Steering information from common blocks
*
*HTMLO     : Describe the Output of the routine
*
* Booked histograms in area //PAWC/FFDBG
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFHBK
*-----------------------------------------Updates 03/05/93-------
**: FFHBK.......SB.  Reinstate missing track histograms.
*-----------------------------------------Updates 29/10/92-------
**: FFHBK .......SB. Debug steering changed slightly.
*-----------------------------------------Updates 07/08/92-------
**: FFHBK .......SB. New histograms.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Book diagnostic histograms                                         *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEND.

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

      CALL HCDIR('//PAWC',' ')
      CALL HMDIR(CFDBG,'S')
      IPASS = 1

      IF (IHFF/1000.GT.0) THEN
         CALL HBOOK1(101,'TRACK ANGLE CORR (PLANAR)$',100,0.,0.025,0.)
         CALL HBOOK1(102,'TRACK ANGLE CORR (RADIAL)$',100,0.,0.025,0.)
         CALL HBOOK1(103,'TRACK ANGLE (PLANAR)$',100,0.,1.,0.)
         CALL HBOOK1(104,'TRACK ANGLE (RADIAL)$',100,0.,1.,0.)
         CALL HBOOK1(105,'EVT0 CORRECTION$',100,-0.025,0.025,0.)
         CALL HBOOK1(106,'TOF CORR (PLANAR)$',100,-0.025,0.025,0.)
         CALL HBOOK1(107,'TOF CORR (RADIAL)$',100,-0.025,0.025,0.)
         CALL HBOOK1(108,'PROP CORRECTION$',100,-0.025,0.025,0.)
         CALL HBOOK1(109,'B-FIELD CORR (PLANAR)$',100,-0.025,0.025,0.)
         CALL HBOOK1(110,'B-FIELD CORR (RADIAL)$',100,-0.025,0.025,0.)
         CALL HBOOK1(111,'DELTA(B) (PLANAR)$',100,-0.2,0.2,0.)
         CALL HBOOK1(112,'DELTA(B) (RADIAL)$',100,-0.2,0.2,0.)
         CALL HBOOK1(113,'TOTAL CORR (PLANAR)$',100,-0.025,0.025,0.)
         CALL HBOOK1(114,'TOTAL CORR (RADIAL)$',100,-0.025,0.025,0.)
      ENDIF

 100  CONTINUE

      IF (MOD(IHFF,10).GT.0) THEN
         CALL HBOOK1(300,'NUMBER OF TRACKS$',100,0.,100.,0.)
         IF (LTRUTH) CALL HBOOK1(301,'P(CHISQ)$',100,0.,1.,0.)
         CALL HBOOK1(311,'EFFICIENCY (PLANAR)$',100,0.,1.,0.)
         CALL HBOOK1(312,'EFFICIENCY (RADIAL)$',100,0.,1.,0.)
         CALL HBOOK1(313,'EFFICIENCY',100,0.,1.,0.)
         CALL HBOOK1(314,'ERROR RATE (PLANAR)$',100,0.,1.,0.)
         CALL HBOOK1(315,'ERROR RATE (RADIAL)$',100,0.,1.,0.)
         CALL HBOOK1(316,'ERROR RATE$',100,0.,1.,0.)
      ENDIF

      IF (MOD(IHFF/10,10).GT.0) THEN
         CALL HBOOK1(321,'NUMBER OF HITS (PLANAR)$',100,0.,100.,0.)
         CALL HBOOK1(322,'NUMBER OF HITS (RADIAL)$',100,0.,100.,0.)
         CALL HBOOK1(323,'HITS BY MODULE$',100,0.,100.,0.)
         CALL HBOOK1(331,'MISSING TRACKS$',100,0.,100.,0.)
         CALL HBOOK1(332,'HITS PER MISSING TRACK (PLANAR)$'
     &,              100,0.,100.,0.)
         CALL HBOOK1(333,'HITS PER MISSING TRACK (RADIAL)$'
     &,              100,0.,100.,0.)
         CALL HBOOK1(334,'MISSING TRACK MOMENTUM$'
     &,              100,0.,10.,0.)
         CALL HBOOK1(335,'HITS PER MISSING TRACK (PRIMARY)$'
     &,              100,0.,100.,0.)
         CALL HBOOK1(336,'MISSING TRACK MOMENTUM (PRIMARY)$'
     &,              100,0.,10.,0.)
      ENDIF

      CALL HBPRO(0,0.)
      CALL HMINIM(0,0.)
      CALL HIDOPT(0,'INTE')

      CALL HCDIR('//PAWC',' ')
      CALL HMDIR(CFKDBG,'S')

      IF (MOD(IHFF,1000).GT.100 .AND. IPASS.EQ.1) THEN
         IPASS = 2
         GOTO 100
      ENDIF

      CALL HCDIR('//PAWC',' ')

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  2.02/03 28/02/91  15.55.36  by  Stephen Burke
*-- Author : S.Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Determines the "true" track (STR) given a list of hits.
*
*HTMLI     : Describe the Input variables to the routine
*
* JDIGP - pointer to the first planar hit in FPUX
* JDIGR - pointer to the first radial hit in FRUX
*
* FPUX/FRUX banks (hit lists from pattern recognition)
* FRPX/FRRX banks (true hit information)
*
*HTMLO     : Describe the Output of the routine
*
* JMAX - STR index for the track which contributes most hits (returns
*        zero for failure)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFHUNT(JDIGP,JDIGR,JMAX)
**********************************************************************
*                                                                    *
* Hunt for the best candidate for the 'true' track, given a list     *
* of digis.                                                          *
*                                                                    *
* JDIGP and JDIGR are pointers to the first digis on the track.      *
* JMAX is returned as the STR index of the 'true' track.             *
*                                                                    *
* Note that the FRPX, FRRX, FPUX and FRUX banks are assumed to have  *
* been copied to work banks, with pointers in /FFWBI/.               *
*                                                                    *
**********************************************************************

      DIMENSION ITRUE(2,1000)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*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.

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

      JMAX = 0

* Allow for hit banks to be nonexistant
      IF (JDIGP.GT.0 .AND. INDRSX(1).LE.0) RETURN
      IF (JDIGR.GT.0 .AND. INDRSX(2).LE.0) RETURN

      CALL VZERO(ITRUE,2000)

      IF (JDIGP.GT.0) THEN
* Loop over planar digis looking for a corresponding hit ...
         NHIT = IW(INDRSX(1)+2)
         JDIG = JDIGP
 100     CONTINUE
            DO 200 JHIT=1,NHIT
               IDIG = IBTAB(INDRSX(1),3,JHIT)
               IF (IDIG.EQ.JDIG) CALL FFNUM(1,JHIT,ITRUE)
 200        CONTINUE
            JDIG = IBTAB(INDX(1),1,JDIG)
         IF (JDIG.NE.JDIGP) GOTO 100
      ENDIF

      IF (JDIGR.GT.0) THEN
* ... and the same for radials
         NHIT = IW(INDRSX(2)+2)
         JDIG = JDIGR
 300     CONTINUE
            DO 400 JHIT=1,NHIT
               IDIG = IBTAB(INDRSX(2),3,JHIT)
               IF (IDIG.EQ.JDIG) CALL FFNUM(2,JHIT,ITRUE)
 400        CONTINUE
            JDIG = IBTAB(INDX(2),1,JDIG)
         IF (JDIG.NE.JDIGR) GOTO 300
      ENDIF

      MAX  = 0
      JSTR = 0
 500  CONTINUE
         JSTR = JSTR + 1
* ITRUE now contains the number of hits for each track ...
         IF (ITRUE(2,JSTR).GT.MAX) THEN
            MAX  = ITRUE(2,JSTR)
            JMAX = ITRUE(1,JSTR)
         ENDIF
      IF (ITRUE(1,JSTR).GT.0 .AND. JSTR.LT.1000) GOTO 500

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  8.03/00 27/02/96  16.13.29  by  Katharina Mueller
*CMZU:  3.03/02 04/05/92  18.30.12  by  Stephen J. Maxfield
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill diagnostic HBOOK histograms from the output of the Kalman filter.
*
*HTMLI     : Describe the Input variables to the routine
*
* Steering parameters in various common blocks
*
* FTKR/FTPR/FTPX/FTRX banks (fitted tracks and hit pointers)
* FPLC/FRLC banks (unpacked hit information)
* FRPX/FRRX banks (true hit information)
*
*HTMLO     : Describe the Output of the routine
*
* Filled histograms
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFKLCH
*-----------------------------------------Updates 04/05/92-------              *
*-----------------------------------------Updates 13/02/92-------
**: FFKLCH 30205.SB. ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFKLCH 30205.SB. Remove unused FKCNTL sequence.
**: FFKLCH 30205.SB. Change to avoid UNDEF warning.
*-----------------------------------------Updates 24/01/92-------
**: FFKLCH 30205.SB. ERRLOG message format changed.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Fill histograms to test the Kalman filter output                   *
*                                                                    *
**********************************************************************

      CHARACTER*4 BANK

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*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.

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

* Look for the track banks - if there aren't any, give up!
      INDTKR = NLINK('FTKR',0)
      IF (INDTKR.LE.0) RETURN

* Unpacked digi banks
      INDLC(1) = NLINK('FPLC',0)
      IF (INDLC(1).LE.0) THEN
         CALL FPLOCO
         INDLC(1) = NLINK('FPLC',0)
      ENDIF
      INDLC(2) = NLINK('FRLC',0)
      IF (INDLC(2).LE.0) THEN
         CALL FRLOCO
         INDLC(2) = NLINK('FPLC',0)
      ENDIF
      IF (INDLC(1).LE.0 .OR. INDLC(2).LE.0) THEN
         CALL ERRLOG(401,'W:FFKLCH: Banks FPLC/FRLC not found')
         RETURN
      ENDIF

* Zero the work bank indices
      INDTPR = 0
      CALL VZERO(INDX,2)
      CALL VZERO(INDRSX,2)

* Get the pointering bank ...
      IND = NLINK('FTPR',0)
      IF (IND.LE.0) THEN
         CALL ERRLOG(402,'S:FFKLCH:  Bank FTPR not found')
         RETURN
      ENDIF
      BANK = 'FTPR'
      CALL BKTOW(IW,BANK,0,IW,INDTPR,*1000)

* Now get the link banks ...
      IF (NLINK('FTPX',0).LE.0 .OR. NLINK('FTRX',0).LE.0) THEN
         CALL ERRLOG(403,'S:FFKLCH:  Banks FTPX and FTRX not found')
         GOTO 9000
      ENDIF
      BANK = 'FTPX'
      CALL BKTOW(IW,BANK,0,IW,INDX(1),*1000)
      BANK = 'FTRX'
      CALL BKTOW(IW,BANK,0,IW,INDX(2),*1000)

      IF (NLINK('FRPX',0).GT.0) THEN
         BANK = 'FRPX'
         CALL BKTOW(IW,BANK,0,IW,INDRSX(1),*1000)
      ENDIF
      IF (NLINK('FRRX',0).GT.0) THEN
         BANK = 'FRRX'
         CALL BKTOW(IW,BANK,0,IW,INDRSX(2),*1000)
      ENDIF

      CALL HCDIR('//PAWC/'//CFKDBG,' ')

      NTR = IW(INDTKR+2)
      CALL HFILL(300,FLOAT(NTR/2),0.,1.)

      CALL VZERO(ITRTR,2*NTRACK)
      DO 100 JTR=1,NTR-1,2
         NDF    = IBTAB(INDTKR,17,JTR)
         CHISQ  = RBTAB(INDTKR,18,JTR)
         CHPROB = PROB(CHISQ,NDF)
         CALL HFILL(301,CHPROB,0.,1.)
         JDIGP = IBTAB(INDTPR,4,IBTAB(INDTKR,21,JTR))
         JDIGR = IBTAB(INDTPR,2,IBTAB(INDTKR,21,JTR))
         CALL FFHUNT(JDIGP,JDIGR,JMAX)
         IF (JMAX.GT.0) CALL FFCHEK(JDIGP,JDIGR,JMAX)
 100  CONTINUE
      CALL FFTRCH

      CALL HCDIR('//PAWC',' ')

 9000 CONTINUE

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

      CALL WDROP(IW,INDX(1))
      CALL WDROP(IW,INDX(2))
      CALL WDROP(IW,INDRSX(1))
      CALL WDROP(IW,INDRSX(2))
      CALL WDROP(IW,INDTPR)

      RETURN

 1000 CALL ERRLOG(404,'S:FFKLCH:  Bank '//BANK//' not found by BKTOW')
      GOTO 9000

      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZ :  2.00/00 12/12/90  17.35.56  by  Girish D. Patel
*-- Author : S.Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Counts the number of hits from each STR track (called from FFHUNT).
*
*HTMLI     : Describe the Input variables to the routine
*
* JTYPE - 1 for planars and 2 for radials
* JHIT  - hit index in the FRPX/FRRX bank
* ITRUE - a 2*1000 array with (STR number, number of hits) pairs (or zero)
*
* FRPX/FRRX banks (true hit information)
*
*HTMLO     : Describe the Output of the routine
*
* ITRUE - updated to reflect the new hit
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFNUM(JTYPE,JHIT,ITRUE)
**********************************************************************
*                                                                    *
* Count the number of hits for each track                            *
*                                                                    *
* JTYPE is 1 for planars and 2 for radials.                          *
* JHIT is the row number in the FRsX bank.                           *
* ITRUE is an array which counts the number of hits for each STR.    *
*                                                                    *
**********************************************************************

      DIMENSION ITRUE(2,1000)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*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.

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

* True hits only
      IFLAG = IBTAB(INDRSX(JTYPE),1,JHIT)
      IF (IFLAG.GE.512) RETURN

* See if this track has been seen before ...
      JSTR   = IBTAB(INDRSX(JTYPE),2,JHIT)
      IFOUND = 0
      INUM   = 0
 100  CONTINUE
         INUM = INUM + 1
         IF (INUM.GE.1000) RETURN
         IF (JSTR.EQ.ITRUE(1,INUM)) THEN
            IFOUND = INUM
         ELSEIF (ITRUE(1,INUM).GT.0) THEN
            GOTO 100
         ENDIF

* ... and increment the counter
      IF (IFOUND.EQ.0) THEN
         ITRUE(1,INUM) = JSTR
         ITRUE(2,INUM) = 1
      ELSE
         ITRUE(2,INUM) = ITRUE(2,INUM) + 1
      ENDIF

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  2.03/03 17/04/91  12.10.11  by  Stephen Burke
*-- Author : S.Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill an array with true track information. (Then calls FFXTRP to
* do it again if the fast tracking banks are available - not the
* most efficient way to do it!)
*
*HTMLI     : Describe the Input variables to the routine
*
* JTRUE - the true track (STR) number
*
* FS/STR/SVX banks (true track/vertex information)
*
* Geometry information in /FKCONS/
*
*HTMLO     : Describe the Output of the routine
*
* Fills the TRUE array (in /FKTRUE/) with the true track parameters
* at each plane
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFTRUE(JTRUE)
**********************************************************************
*                                                                    *
* Fill the TRUE array from the track JTRUE                           *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION Z,DZ,S(5),DTRAN(5,5)
      INTEGER FFCHG

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKTRUE.
*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.

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

      LTRUE = .FALSE.

* Find the starting track bank (if it exists)
      INDFS = NLINK('FS  ',0)
      IF (INDFS.GT.0) THEN
* Find the track with the right STR number
         JTRACK = 0
 100     CONTINUE
            JTRACK = JTRACK + 1
            IF (JTRACK.GT.IW(INDFS+2)) THEN
* This should be impossible, but ...
               INDFS = 0
               GOTO 150
            ENDIF
            JSTR = IBTAB(INDFS,10,JTRACK)
         IF (JSTR.NE.JTRUE) GOTO 100
         PX   = RBTAB(INDFS,1,JTRACK)
         PY   = RBTAB(INDFS,2,JTRACK)
         PZ   = RBTAB(INDFS,3,JTRACK)
         IPDG = IBTAB(INDFS,4,JTRACK)
         X    = RBTAB(INDFS,5,JTRACK)
         Y    = RBTAB(INDFS,6,JTRACK)
         Z    = RBTAB(INDFS,7,JTRACK)
      ENDIF

 150  CONTINUE
      IF (INDFS.LE.0) THEN
* Find the simulated track and vertex banks
         INDSTR = NLINK('STR ',0)
         INDSVX = NLINK('SVX ',0)
         IF (INDSTR.LE.0 .OR. INDSVX.LE.0) RETURN
         IF (JTRUE.LE.0 .OR. JTRUE.GT.IW(INDSTR+2)) RETURN
* Get the track parameters at the vertex
         PX   = RBTAB(INDSTR,1,JTRUE)
         PY   = RBTAB(INDSTR,2,JTRUE)
         PZ   = RBTAB(INDSTR,3,JTRUE)
         IPDG = IBTAB(INDSTR,5,JTRUE)
         JSVX = IBTAB(INDSTR,9,JTRUE)
         X    = RBTAB(INDSVX,1,JSVX)
         Y    = RBTAB(INDSVX,2,JSVX)
         Z    = RBTAB(INDSVX,3,JSVX)
      ENDIF

      ICHG = FFCHG(IPDG)
* Can be a gamma (if secondaries are stacked), which screws up FKTRAN
      IF (ICHG.EQ.0) RETURN

* Assemble a KF-type state vector
      P    = SQRT(PX*PX + PY*PY + PZ*PZ)
      PT   = SQRT(PX*PX + PY*PY)
      S(1) = X
      S(2) = Y
      S(3) = FLOAT(ICHG)/P
      S(4) = PT/PZ
      S(5) = ATAN2(PY,PX)
      CALL FKNORM(S,IFAIL)
      IF (IFAIL.GE.100) RETURN

* Translate to each plane in succession
      DO 200 JPL=1,JPLMAX
         DZ = ZPL(JPL) - Z
         CALL FKTRAN(DZ,Z,S,TRUE(1,JPL),DTRAN)
 200  CONTINUE

* Use FRPF/FRRF banks if available
      CALL FFXTRP(JTRUE,S)

      LTRUE = .TRUE.

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  3.04/01 02/06/92  17.12.31  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill an array with true track information.
*
*HTMLI     : Describe the Input variables to the routine
*
* JTRUE - the true track (STR) number
* S     - the initial track vector (REAL*8 5-vector)
*
* FRPF/FRRF banks (true track information)
*
* Geometry information in /FKCONS/
*
*HTMLO     : Describe the Output of the routine
*
* Fills the TRUE array (in /FKTRUE/) with the true track parameters
* at each plane
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFXTRP(JTRUE,S)
*-----------------------------------------Updates 02/06/92-------
**: FFXTRP.......SB. Change loop indices to please farm.
*-----------------------------------------Updates 07/02/92-------
**: FFXTRP 30205.SB. Initialise IPF and IRF to please UNDEF.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Fill the TRUE array from the track JTRUE using the FRPF/FRRF banks *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION Z,DZ,S(5),DTRAN(5,5),VX,VY
      DIMENSION IPF(9),IRF(3)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKTRUE.
*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*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.

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

      INDPF = NLINK('FRPF',0)
      INDRF = NLINK('FRRF',0)
      IF (INDPF.LT.0 .OR. INDRF.LT.0) RETURN

* This isn't actually necessary, but it stops UNDEF complaining
      CALL VZERO(IPF,9)
      CALL VZERO(IRF,3)

      NPMOD = 0
      ILOOP = IW(INDPF+2)
      DO 300 JPF=1,ILOOP
         IF (NPMOD.GE.9) GOTO 300
         JTR = IBTAB(INDPF,18,JPF)
         IF (JTR.EQ.JTRUE) THEN
            IMOD = 0
            DO 100 JMOD=1,NPMOD
               ZD = RBTAB(INDPF,3,JPF) - RBTAB(INDPF,3,IPF(JMOD))
               IF (ABS(ZD).LT.1.) THEN
                  IMOD = -1
               ELSEIF (ZD.LT.0.) THEN
                  IMOD = JMOD
               ENDIF
 100        CONTINUE
            IF (IMOD.GT.0) THEN
               DO 200 JMOD=NPMOD,IMOD,-1
                  IPF(JMOD+1) = IPF(JMOD)
 200           CONTINUE
               IPF(IMOD) = JPF
               NPMOD = NPMOD + 1
            ELSEIF (IMOD.EQ.0) THEN
               NPMOD = NPMOD + 1
               IPF(NPMOD) = JPF
            ENDIF
         ENDIF
 300  CONTINUE

      NRMOD = 0
      ILOOP = IW(INDRF+2)
      DO 600 JRF=1,ILOOP
         IF (NRMOD.GE.3) GOTO 600
         JTR = IBTAB(INDRF,17,JRF)
         IF (JTR.EQ.JTRUE) THEN
            IMOD = 0
            DO 400 JMOD=1,NRMOD
               ZD = RBTAB(INDRF,3,JRF) - RBTAB(INDRF,3,IRF(JMOD))
               IF (ABS(ZD).LT.1.) THEN
                  IMOD = -1
               ELSEIF (ZD.LT.0.) THEN
                  IMOD = JMOD
               ENDIF
 400        CONTINUE
            IF (IMOD.GT.0) THEN
               DO 500 JMOD=NRMOD,IMOD,-1
                  IRF(JMOD+1) = IRF(JMOD)
 500           CONTINUE
               IRF(IMOD) = JRF
               NRMOD = NRMOD + 1
            ELSEIF (IMOD.EQ.0) THEN
               NRMOD = NRMOD + 1
               IRF(NRMOD) = JRF
            ENDIF
         ENDIF
 600  CONTINUE

      JPF = 0
      JRF = 0
      DO 900 JPL=1,JPLMAX
         INDF = 0
         Z1   = ZPL(JPL)
         IF (IRP(JPL).EQ.1) THEN
            IF (JPF.LT.NPMOD) THEN
 700           CONTINUE
                  JPF = JPF + 1
                  Z2 = RBTAB(INDPF,3,IPF(JPF))
               IF (Z2.LE.Z1 .AND. JPF.LT.NPMOD) GOTO 700
               IF (Z2.GT.Z1) JPF = JPF - 1
            ENDIF
            IF (JPF.GT.0) THEN
               INDF = INDPF
               IF   = IPF(JPF)
            ENDIF
         ELSE
            IF (JRF.LT.NRMOD) THEN
 800           CONTINUE
                  JRF = JRF + 1
                  Z2 = RBTAB(INDRF,3,IRF(JRF))
               IF (Z2.LE.Z1 .AND. JRF.LT.NRMOD) GOTO 800
               IF (Z2.GT.Z1) JRF = JRF - 1
            ENDIF
            IF (JRF.GT.0) THEN
               INDF = INDRF
               IF   = IRF(JRF)
            ENDIF
         ENDIF
         IF (INDF.GT.0) THEN
            S(1) = RBTAB(INDF,1,IF)
            S(2) = RBTAB(INDF,2,IF)
            VX   = RBTAB(INDF,4,IF)
            VY   = RBTAB(INDF,5,IF)
            S(5) = ATAN2(VY,VX)
            IF (S(5).LT.0.0D0) S(5) = S(5) + TWOPI
            DZ = ZPL(JPL) - RBTAB(INDF,3,IF)
            CALL FKTRAN(DZ,Z,S,TRUE(1,JPL),DTRAN)
         ENDIF
 900  CONTINUE

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  3.06/06 14/10/92  19.40.06  by  Stephen Burke
*-- Author :    Stephen Burke   14/10/92
*
*HTMLP*    : Describe the Purpose of the routine
*
* Analyse true track information
*
*HTMLI     : Describe the Input variables to the routine
*
* ITRTR and ITRNF arrays in /FFDBG/
*
*HTMLO     : Describe the Output of the routine
*
* Counters of split and missing tracks in /FFSCAL/ are incremented
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFTRAN
*-----------------------------------------Updates 14/10/92-------
**: FFTRAN.......SB. New deck for diagnostics.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Analyse the true track information                                 *
*                                                                    *
**********************************************************************

*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEND.

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

*
* Count the number of split tracks
*

      JTR = 0
 100  CONTINUE
         JTR = JTR + 1
         IF (ITRTR(2,JTR).GT.1) NNSPLT = NNSPLT + 1
         IF (ITRTR(1,JTR).GT.0 .AND. JTR.LT.NTRACK) GOTO 100

*
* Count the number of missed tracks
*

      JTR = 0
 200  CONTINUE
         JTR = JTR + 1
         IF (ITRNF(2,JTR)+ITRNF(3,JTR).GT.8) NNMISS = NNMISS + 1
         IF (ITRNF(4,JTR).GT.8) NNMISP = NNMISP + 1
         IF (ITRNF(1,JTR).GT.0 .AND. JTR.LT.NTRACK) GOTO 200

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZU:  6.00/00 24/11/94  16.29.14  by  Stephen Burke
*CMZU:  5.03/00 24/10/94  16.04.41  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.04  by  Stephen Burke
*CMZU:  3.09/01 03/05/93  15.18.59  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Calculate and histogram the efficiency and error rate of the
* pattern recognition.
*
*HTMLI     : Describe the Input variables to the routine
*
* JDIGP - planar hit pointer in FPUX
* JDIGR - radial hit pointer in FRUX
* JMAX  - the true track (STR) number
*
* FPUX/FRUX banks (hit lists from pattern recognition)
* FRPX/FRRX banks (true hit information)
* FPLC/FRLC banks (unpacked hit information)
* FPG1/FRG1 banks (geometry/dead wires)
*
* Information from various common blocks
*
*HTMLO     : Describe the Output of the routine
*
* Filled histograms
*
* The array ITRTR in /FFDBG/ is updated
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFCHEK(JDIGP,JDIGR,JMAX)
*-----------------------------------------Updates 07/09/93-------
**: FFCHEK 40000 SB. New definition of dead wire flag.
*-----------------------------------------Updates 03/05/93-------
**: FFCHEK 40000 SB. Allow for hits with no digi.
**: FFCHEK 40000 SB. Fix bug in efficiency histograms
*-----------------------------------------Updates 28/01/92-------
**: FFCHEK 30205.SB. Fix bug in efficiency histograms
*-----------------------------------------Updates 24/01/92-------
**: FFCHEK 30205.SB. Check to see if the drift sign is correct.
**: FFCHEK 30205.SB. Add a check for dead wires
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Calculate and histogram the efficiency and inefficiency of the     *
* FT pattern recognition, for planars, radials and both together     *
*                                                                    *
* NB Histograms are booked in FFHBK                                  *
*                                                                    *
**********************************************************************

      LOGICAL IOK,IOKD
      DIMENSION MODHIT(12),MODST(12)
      SAVE MODST

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FKDBG.
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*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))
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

      DATA MODST/0,6,12,18,34,40,46,52,66,72,78,84/

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

* Put this track in the list of true tracks
      JTR = 0
 100  CONTINUE
         JTR = JTR + 1
         ITR = ITRTR(1,JTR)
      IF (ITR.NE.JMAX .AND. ITR.GT.0 .AND. JTR.LT.NTRACK) GOTO 100

      IF (ITR.EQ.0) THEN
         ITRTR(1,JTR) = JMAX
         ITRTR(2,JTR) = 1
      ELSEIF (ITR.EQ.JMAX) THEN
         ITRTR(2,JTR) = ITRTR(2,JTR) + 1
      ENDIF

* Current true track
      JTRTR = JMAX

      CALL VZERO(MODHIT,12)
      NPP    = 0
      NDIGP  = 0
      NGOODP = 0

      IF (JDIGP.GT.0) THEN
         NHIT = IW(INDRSX(1)+2)
         JDIG = JDIGP
 200     CONTINUE
            NDIGP = NDIGP + 1
            IOK   = .FALSE.
            IOKD  = .FALSE.
            DO 300 JHIT=1,NHIT
               IFLAG = IBTAB(INDRSX(1),1,JHIT)
               JSTR  = IBTAB(INDRSX(1),2,JHIT)
               IDIG  = IBTAB(INDRSX(1),3,JHIT)
               ICELL = IBTAB(INDLC(1),1,IDIG)
* Check for dead wire
               IF (IBTAB(INDG1(1),1,ICELL+1).EQ.1) GOTO 300
               IF (JSTR.EQ.JMAX .AND. IFLAG.LT.512 .AND.
     &             IDIG.GT.0) THEN
                  IF (IDIG.EQ.JDIG)  THEN
                     IOK = .TRUE.
                     ISGN = MOD(IBTAB(INDX(1),2,JDIG),2)
                     IF (MOD(IFLAG,2).EQ.ISGN) IOKD = .TRUE.
                  ENDIF
                  IF (JDIG.EQ.JDIGP) THEN
                     NPP   = NPP + 1
                     KMOD  = ICELL/384
                     KORI  = (ICELL - KMOD*384)/128
                     JMOD  = 4*KMOD + KORI + 1
                     MODHIT(JMOD) = MODHIT(JMOD) + 1
                  ENDIF
               ENDIF
 300        CONTINUE
            ICELL = IBTAB(INDLC(1),1,JDIG)
            JPL   = JFTPL(IPSBW(ICELL))
            IF (IOK .AND. IOKD) THEN
               NGOODP      = NGOODP + 1
               LTRPL(JPL)  = .TRUE.
               LTRPLD(JPL) = .TRUE.
            ELSEIF (IOK) THEN
C               NGOODP     = NGOODP + 1
               LTRPL(JPL)  = .TRUE.
               LTRPLD(JPL) = .FALSE.
            ELSE
               LTRPL(JPL)  = .FALSE.
               LTRPLD(JPL) = .FALSE.
            ENDIF
            JDIG = IBTAB(INDX(1),1,JDIG)
         IF (JDIG.NE.JDIGP) GOTO 200
      ENDIF

      NRP    = 0
      NDIGR  = 0
      NGOODR = 0

      IF (JDIGR.GT.0) THEN
         NHIT = IW(INDRSX(2)+2)
         JDIG = JDIGR
 400     CONTINUE
            NDIGR = NDIGR + 1
            IOK   = .FALSE.
            IOKD  = .FALSE.
            DO 500 JHIT=1,NHIT
               IFLAG = IBTAB(INDRSX(2),1,JHIT)
               JSTR  = IBTAB(INDRSX(2),2,JHIT)
               IDIG  = IBTAB(INDRSX(2),3,JHIT)
               IWEDG = JBIT(IFLAG,2)
               ICELL = IBTAB(INDLC(2),1,IDIG)
               IDEAD = IBTAB(INDG1(2),1,ICELL+1)
* Check for dead wire
               IF (IDEAD.EQ.1 .OR. IDEAD.EQ.IWEDG+2) GOTO 500
               IF (JSTR.EQ.JMAX .AND. IFLAG.LT.512 .AND.
     &             IDIG.GT.0) THEN
                  IF (IDIG.EQ.JDIG)  THEN
                     IOK = .TRUE.
                     ISGN = MOD(IBTAB(INDX(2),2,JDIG),2)
                     IF (MOD(IFLAG,2).EQ.ISGN) IOKD = .TRUE.
                  ENDIF
                  IF (JDIG.EQ.JDIGR) THEN
                     NRP   = NRP + 1
                     KMOD  = ICELL/288
                     JMOD  = 4*KMOD + 4
                     MODHIT(JMOD) = MODHIT(JMOD) + 1
                  ENDIF
               ENDIF
 500        CONTINUE
            ICELL = IBTAB(INDLC(2),1,JDIG)
            JPL   = JFTPL(IRSBW(ICELL))
            IF (IOK .AND. IOKD) THEN
               NGOODR      = NGOODR + 1
               LTRPL(JPL)  = .TRUE.
               LTRPLD(JPL) = .TRUE.
            ELSEIF (IOK) THEN
C               NGOODR     = NGOODR + 1
               LTRPL(JPL)  = .TRUE.
               LTRPLD(JPL) = .FALSE.
            ELSE
               LTRPL(JPL)  = .FALSE.
               LTRPLD(JPL) = .FALSE.
            ENDIF
            JDIG = IBTAB(INDX(2),1,JDIG)
         IF (JDIG.NE.JDIGR) GOTO 400
      ENDIF

      IF (NPP.GT.0) THEN
         EFF1P = ABS(FLOAT(NGOODP)/FLOAT(NPP) - 0.001)
         CALL HFILL(311,EFF1P,0.,1.)
      ELSEIF (NGOODP.EQ.0) THEN
         CALL HFILL(311,-1.,0.,1.)
      ENDIF
      IF (NDIGP.GT.0) THEN
         EFF2P = ABS(FLOAT(NDIGP - NGOODP)/FLOAT(NDIGP) - 0.001)
         CALL HFILL(314,EFF2P,0.,1.)
      ENDIF
      CALL HFILL(321,FLOAT(NDIGP),0.,1.)

      IF (NRP.GT.0) THEN
         EFF1R = ABS(FLOAT(NGOODR)/FLOAT(NRP) - 0.001)
         CALL HFILL(312,EFF1R,0.,1.)
      ELSEIF (NGOODR.EQ.0) THEN
         CALL HFILL(312,-1.,0.,1.)
      ENDIF
      IF (NDIGR.GT.0) THEN
         EFF2R = ABS(FLOAT(NDIGR - NGOODR)/FLOAT(NDIGR) - 0.001)
         CALL HFILL(315,EFF2R,0.,1.)
      ENDIF
      CALL HFILL(322,FLOAT(NDIGR),0.,1.)

      IF (NPP.GT.0 .OR. NRP.GT.0) THEN
         EFF1 = ABS(FLOAT(NGOODP+NGOODR)/FLOAT(NPP+NRP) - 0.001)
         CALL HFILL(313,EFF1,0.,1.)
      ELSEIF (NGOODP.EQ.0 .AND. NGOODR.EQ.0) THEN
         CALL HFILL(313,-1.,0.,1.)
      ENDIF
      IF (NDIGP.GT.0 .OR. NDIGR.GT.0) THEN
         EFF2 = ABS(FLOAT(NDIGP+NDIGR-NGOODP-NGOODR)/FLOAT(NDIGP+NDIGR)
     &        - 0.001)
         CALL HFILL(316,EFF2,0.,1.)
      ENDIF

      DO 600 JMOD = 1,12
         NUM = MODST(JMOD) + MODHIT(JMOD)
         CALL HFILL(323,FLOAT(NUM),0.,1.)
 600  CONTINUE

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.08  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.04  by  Stephen Burke
*CMZU:  3.09/01 03/05/93  15.18.59  by  Stephen Burke
*-- Author : S.Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill histograms for tracks not found by the pattern recognition
*
*HTMLI     : Describe the Input variables to the routine
*
* STR bank (true track information)
* FPUX/FRUX banks (hit lists from pattern recognition)
* FRPX/FRRX banks (true hit information)
* FPLC/FRLC banks (unpacked hit information)
* FPG1/FRG1 banks (geometry/dead wires)
*
*HTMLO     : Describe the Output of the routine
*
* Histograms are filled
*
* The ITRNF array in /FFDBG/ is filled
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFTRCH
*-----------------------------------------Updates 07/09/93-------
**: FFTRCH 40000 SB. New definition of dead wire flag.
*-----------------------------------------Updates 03/05/93-------
**: FFTRCH 40000 SB. Check for dead wires and hits with no digi.
**: FFTRCH 40000 SB. Reinstate missing track histograms.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Histogram the length of tracks which are not found by the patrec   *
*                                                                    *
* NB Histograms are booked in FFHBK                                  *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*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.

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

      CALL VZERO(ITRNF,5*NTRACK)

      INDSTR = NLINK('STR ',0)
      IF (INDSTR.LE.0) RETURN

      IF (INDRSX(1).GT.0) THEN
         NHITP = IW(INDRSX(1)+2)
      ELSE
         NHITP = 0
      ENDIF
      IF (INDRSX(2).GT.0) THEN
         NHITR = IW(INDRSX(2)+2)
      ELSE
         NHITR = 0
      ENDIF

      IF (NHITP.LE.0 .AND. NHITR.LE.0) RETURN

      NTR = 0

      DO 400 JHIT=1,NHITP
         IF (IBTAB(INDRSX(1),1,JHIT).GE.512) GOTO 400
         JSTR = IBTAB(INDRSX(1),2,JHIT)
         JTR  = 0
 100     CONTINUE
            JTR = JTR + 1
            ITR = ITRTR(1,JTR)
            IF (ITR.GT.0 .AND. ITR.NE.JSTR
     &                   .AND. JTR.LT.NTRACK) GOTO 100
         IF (ITR.EQ.JSTR) GOTO 400
         JDIG = IBTAB(INDRSX(1),3,JHIT)
         IF (JDIG.LE.0) GOTO 400
* Check for dead wire
         ICELL = IBTAB(INDLC(1),1,JDIG)
         IF (IBTAB(INDG1(1),1,ICELL+1).EQ.1) GOTO 400
         JPX = 0
 200     CONTINUE
            JPX = JPX + 1
            IDIG = IBTAB(INDX(1),1,JPX)
            IF (IDIG.NE.JDIG .AND. JPX.LT.IW(INDX(1)+2)) GOTO 200
         JTR = 0
 300     CONTINUE
            JTR = JTR + 1
            ITR = ITRNF(1,JTR)
            IF (ITR.GT.0 .AND. ITR.NE.JSTR
     &                   .AND. JTR.LT.NTRACK) GOTO 300
         IF (ITR.LE.0) THEN
            NTR = NTR + 1
            ITRNF(1,JTR) = JSTR
            ITRNF(2,JTR) = 1
            IF (IBTAB(INDSTR,7,JSTR).LE.0) ITRNF(4,JTR) = 1
            IF (IDIG.EQ.JDIG) ITRNF(5,JTR) = 1
         ELSEIF (ITR.EQ.JSTR) THEN
            ITRNF(2,JTR) = ITRNF(2,JTR) + 1
            IF (IBTAB(INDSTR,7,JSTR).LE.0)
     &         ITRNF(4,JTR) = ITRNF(4,JTR) + 1
            IF (IDIG.EQ.JDIG) ITRNF(5,JTR) = ITRNF(5,JTR) + 1
         ENDIF
 400  CONTINUE

      DO 800 JHIT=1,NHITR
         IFLAG = IBTAB(INDRSX(2),1,JHIT)
         IF (IFLAG.GE.512) GOTO 800
         JSTR = IBTAB(INDRSX(2),2,JHIT)
         JTR  = 0
 500     CONTINUE
            JTR = JTR + 1
            ITR = ITRTR(1,JTR)
            IF (ITR.GT.0 .AND. ITR.NE.JSTR
     &                   .AND. JTR.LT.NTRACK) GOTO 500
         IF (ITR.EQ.JSTR) GOTO 800
         JDIG = IBTAB(INDRSX(2),3,JHIT)
         IF (JDIG.LE.0) GOTO 800
* Check for dead wire
         ICELL = IBTAB(INDLC(2),1,JDIG)
         IDEAD = IBTAB(INDG1(2),1,ICELL+1)
         IWEDG = JBIT(IFLAG,2)
         IF (IDEAD.EQ.1 .OR. IDEAD.EQ.IWEDG) GOTO 800
         JRX = 0
 600     CONTINUE
            JRX = JRX + 1
            IDIG = IBTAB(INDX(2),1,JRX)
            IF (IDIG.NE.JDIG .AND. JRX.LT.IW(INDX(2)+2)) GOTO 600
         JTR = 0
 700     CONTINUE
            JTR = JTR + 1
            ITR = ITRNF(1,JTR)
            IF (ITR.GT.0 .AND. ITR.NE.JSTR
     &                   .AND. JTR.LT.NTRACK) GOTO 700
         IF (ITR.LE.0) THEN
            NTR = NTR + 1
            ITRNF(1,JTR) = JSTR
            ITRNF(3,JTR) = 1
            IF (IBTAB(INDSTR,7,JSTR).LE.0) ITRNF(4,JTR) = 1
            IF (IDIG.EQ.JDIG) ITRNF(5,JTR) = 1
         ELSEIF (ITR.EQ.JSTR) THEN
            ITRNF(3,JTR) = ITRNF(3,JTR) + 1
            IF (IBTAB(INDSTR,7,JSTR).LE.0)
     &         ITRNF(4,JTR) = ITRNF(4,JTR) + 1
            IF (IDIG.EQ.JDIG) ITRNF(5,JTR) = ITRNF(5,JTR) + 1
         ENDIF
 800  CONTINUE

      CALL HFILL(331,FLOAT(NTR),0.,1.)

      IF (NTR.LE.0) RETURN

      DO 900 JTR=1,NTR
         NHITP  = ITRNF(2,JTR)
         NHITR  = ITRNF(3,JTR)
         NHITPR = ITRNF(4,JTR)
         NFOUND = ITRNF(5,JTR)
         PTRK   = VMOD(IW(INDCR(INDSTR,1,ITRNF(1,JTR))),3)
         CALL HFILL(332,FLOAT(NHITP),0.,1.)
         CALL HFILL(333,FLOAT(NHITR),0.,1.)
         CALL HFILL(334,PTRK,0.,1.)
         IF (NHITPR.GT.0) THEN
            CALL HFILL(335,FLOAT(NHITPR),0.,1.)
            CALL HFILL(336,PTRK,0.,1.)
         ENDIF
C         IF (NHITPR.GT.36) CALL HFILL(347,PTRK,0.,1.)
C         CALL HFILL(348,FLOAT(NFOUND),0.,1.)
C         CALL HFILL(349,FLOAT(NFOUND)/FLOAT(NHITP+NHITR),0.,1.)
 900  CONTINUE

      RETURN
      END
*CMZ :  8.05/01 04/10/96  16.36.09  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.23  by  Stephen Burke
*CMZ :  7.00/00 10/04/95  11.07.25  by  G. Raedel
*-- Author :
*
*HTMLP*    : Describe the Purpose of the routine
*
* Histograms the frequency of error conditions per event (up to 200
* different errors at once).
*
*HTMLI     : Describe the Input variables to the routine
*
* IERR - the error number (as passed to ERRLOG)
*
*HTMLO     : Describe the Output of the routine
*
* Histograms are filled (and booked dynamically) in area //PAWC/FFDBG
*
*HTMLE     : Terminates the HTML documentation
*
*-- Author : S.Burke
      SUBROUTINE FERCHK(IERR)
**********************************************************************
*                                                                    *
* Histogram error frequencies                                        *
*                                                                    *
**********************************************************************

      PARAMETER (MAXERR=200)
      DIMENSION IERCNT(MAXERR,2)
      SAVE ILEVT,INUM,IERCNT

*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.

      DATA ILEVT/-1/,INUM/0/,IERCNT/MAXERR*0,MAXERR*0/

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

      CALL HCDIR('//PAWC/FFDBG',' ')

      IF (NEVENT.NE.ILEVT) THEN
         DO 100 II=1,INUM
            VAL = IERCNT(II,1)
            IF (VAL.GT.0.) CALL HFILL(10000+IERCNT(II,2),VAL,0.,1.)
 100     CONTINUE
         ILEVT = NEVENT
         CALL VZERO(IERCNT,MAXERR)
      ENDIF

      IMARK = 0
      DO 200 II=1,INUM
         IF (IERCNT(II,2).EQ.IERR) IMARK = II
 200  CONTINUE

      IF (IMARK.LE.0) THEN
         IF (INUM.EQ.MAXERR) RETURN
         INUM = INUM + 1
         CALL HBOOK1(10000+IERR,'Error count',100,0.,1000.,0.)
         IERCNT(INUM,1) = 1
         IERCNT(INUM,2) = IERR
      ELSE
         IERCNT(IMARK,1) = IERCNT(IMARK,1) + 1
      ENDIF

      CALL HCDIR('//PAWC',' ')

      RETURN
      END
*CMZ :  8.06/00 07/11/96  11.45.49  by  Stephen Burke
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.27  by  Stephen Burke
*CMZU:  7.03/03 29/11/95  19.43.46  by  Stephen Burke
*CMZU:  4.03/01 05/01/94  16.13.44  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.23  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  FTDSGI is the main routine for producing L4 monitoring during
*  L5 online reconstruction. It is called once per event.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTDSGI
**********************************************************************
*                                                                    *
* FTDSGI is to be called once per event on the SGI , to fill all FTD *
* monitoring histograms. It performs start-of-run initialisation in  *
* IF (BEGRUN) and fills statistics histogram at end of each event in *
* FTDSGE                                                             *
*                                                                    *
* GDP 22/10/93                                                       *
*                                                                    *
**********************************************************************

*KEEP,FMORUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FMORUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*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.

      IF(BEGRUN) THEN

* general initialisation ...
        CALL FTDINT

        NRUN0 = NCCRUN

* Histogram booking ...
        CALL FQBOOK

      ENDIF

* Event selection for real data only
      IF (MONTE) THEN
         IRET = 0
      ELSE
         CALL FMSLCT(EVT0,EVZV,IRET)
      ENDIF

      IF(REVENT .AND. IRET.EQ.0) THEN
* update statistics etc ...
         CALL FQMON

* locate FRPE bank and fill Planar monitoring hists ...
         IF( PLANAR ) CALL FQMONP

* locate FRRE bank and fill Radial monitoring hists ...
         IF( RADIAL ) CALL FQMONR

      ENDIF

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.27  by  Stephen Burke
*CMZ :  4.01/00 07/12/93  19.55.23  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Initialisation routine for <A HREF="FTDSGI.H.html">FTDSGI</A>
*  module called once per run.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTDINT
C
*KEEP,FMOLUN.
      COMMON/FMOLUN/ LUNH, LUNS, LMES
*KEEP,FMOERS.
      COMMON/FMOERS/ IERRH, IERRS, IERRP, IERRR
* IERRH < 0  free Lun for HBOOK output could not be found
* IERRS < 0  free Lun for Run Summary table not found
* IERRP < 0  free Lun for Planar Short Summary not found
* IERRR < 0  free Lun for Radial Short Summary not found
*KEEP,FMORUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FMORUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FMOSCA.
      COMMON /FMOSCA/ ISCA
*KEEP,FMOSUM.
      COMMON/FMOSUM/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FMOHIT.
      COMMON/FMOHIT/ LHITSP(0:8), LHITSR(0:8)
*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.


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


      NRUN0  = 0

* set up logical unit numbers for output files ...
* LMES for error messages etc.
      LMES   = 6  ! default Lun for error messages etc...also on farm?

* LUNH for HBOOK output ...

      PLANAR = .TRUE.
      RADIAL = .TRUE.

      ISCA = 50


      NTIME = 0
      IRTE0 = 1
      IRTP0 = 1
      IEVIN = 0
      NFPEVT= 0
      NHITSP= 0
      NFREVT= 0
      NHITSR= 0

* initialise hits per orientation count
      CALL VZERO( LHITSP(0),9 )
      CALL VZERO( LHITSR(0),9 )
      CALL VZERO( ISTATP(1),20 )
      CALL VZERO( ISTATR(1),20 )

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZU:  8.04/00 03/07/96  15.55.23  by  Girish D. Patel
*CMZU:  8.03/00 21/06/96  11.40.47  by  Girish D. Patel
*CMZU:  7.00/12 28/04/95  15.43.04  by  Girish D. Patel
*CMZ :  4.02/00 16/12/93  11.39.56  by  Gregorio Bernardi
*CMZ :  4.01/00 07/12/93  19.55.23  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Routine to book the LOOK histograms for the
*  <A HREF="FTDSGI.H.html">FTDSGI</A> module
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FQBOOK
************************************************************************
* HBOOKing of histograms for PLANAR and RADIAL monitoring              *
************************************************************************

*KEEP,FMOBIN.
      PARAMETER( NBINR=40 )
*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEEP,FMOTOT.
      PARAMETER(LENST=66)
      COMMON/FMOTOT/ ISTSUM(LENST)
*KEEP,FMORUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FMORUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FMOLUN.
      COMMON/FMOLUN/ LUNH, LUNS, LMES
*KEND.

*Set aside SGI area for forward tracker monotoring
         CALL SAREA('FTDSGI',0)
         IHX = 19500

* book some histograms
      IF(PLANAR) THEN


* book packed histograms for SGI

      IHS(1) = IHX + 1                                           !SGI
            CALL BHD(IHX + 1,0,32,-0.5,31.5,36,0.5,36.5)         !SGI
          CALL STEXT(IHX + 1 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 1 ,1,'Cell No vs Wire Plane')         !SGI


      IHS(2) = IHX + 2                                           !SGI
          CALL   BHS(IHX + 2,0,50,-0.5,49.5)                     !SGI
          CALL STEXT(IHX + 2 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 2 ,1,'Hit Multiplicity/Cell')         !SGI


      IHS(3) = IHX + 3                                           !SGI
          CALL   BHS(IHX + 3,0,100,0.,2000.)                     !SGI
          CALL STEXT(IHX + 3 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 3 ,1,'Raw D-Time ALL Hits')           !SGI

      IHS(4) = IHX + 4                                           !SGI
          CALL   BHD(IHX + 4,0,100,0.,1000.,4,0.,4.)             !SGI
          CALL STEXT(IHX + 4 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 4 ,1,'Inter-Hit Time, ALL + per SM')  !SGI

      IHS(5) = IHX + 5                                           !SGI
          CALL   BHD(IHX + 5,0,32,0.,1600.,30,4.,10.)            !SGI
          CALL STEXT(IHX + 5 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 5 ,1,'Ln(Q) vs T, ALL Hits')          !SGI

      IHS(6) = IHX + 6                                           !SGI
          CALL   BHD(IHX + 6,0,30,4.,10.  ,5,0.,5.)              !SGI
          CALL STEXT(IHX + 6 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 6 ,1,'Ln(Q) ALL Hits + per wire')     !SGI

      IHS(7) = IHX + 7                                           !SGI
          CALL   BHD(IHX + 7,0,30,4.,10.,4,0.,4.)                !SGI
          CALL STEXT(IHX + 7 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX +7,1,'Ln(Q) for Cluster hits + per SM') !SGI

      IHS(8) = IHX + 8                                           !SGI
          CALL   BHD(IHX + 8,0,34,-51.,51.,39,0.,39.)            !SGI
          CALL STEXT(IHX + 8 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 8 ,1,'+/-2S/V All+SM+Layer')          !SGI

      IHS(9) = IHX + 9                                           !SGI
          CALL  BHDW(IHX + 9,0,40,800.,1200.,13,0.,13.)          !SGI
          CALL STEXT(IHX + 9 ,4,'FT Planar')                     !SGI
          CALL STEXT(IHX + 9 ,1,'Raw D-Time DOS/Back')           !SGI

      IHS(10)= IHX + 10                                          !SGI
          CALL   BHDW(IHX + 10,0,40,80.,280.,13,0.,13.)          !SGI
          CALL STEXT(IHX + 10 ,4,'FT Planar')                    !SGI
          CALL STEXT(IHX + 10 ,1,'Raw D-Time DOS/Front')         !SGI

      IHS(27) = IHX + 27
          CALL BHS(IHX + 27,0,100,200.,1000.)
          CALL STEXT(IHX + 27 ,4,'FT Planar')
          CALL STEXT(IHX + 27 ,1,'Planar: Mean Drift/event')

      ENDIF



      IF(RADIAL) THEN


* book packed histograms for farm
      IHS(11)= IHX + 11                                          !SGI
          CALL    BHD(IHX + 11,0,48,-0.5,47.5,36,0.5,36.5)       !SGI
          CALL STEXT(IHX + 11 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 11 ,1,'Wedge Pair*2+- vs Wire Plane') !SGI


      IHS(12)= IHX + 12                                          !SGI
          CALL    BHS(IHX + 12,0,30,-0.5,29.5)                   !SGI
          CALL STEXT(IHX + 12 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 12 ,1,'Hit Multiplicity/Cell')        !SGI

      IHS(13)= IHX + 13                                          !SGI
          CALL   BHS(IHX + 13,0,100,0.,2000.)                    !SGI
          CALL STEXT(IHX + 13 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 13 ,1,'Raw D-Time ALL Hits')          !SGI

*      IHS(14)= IHX + 14                                          !SGI
*          CALL   BHS(IHX + 14,0,80, -80.,80.)                    !SGI
*          CALL STEXT(IHX + 14 ,4,'FT Radial')                    !SGI
*          CALL STEXT(IHX + 14 ,1,'Radius  ALL Hits')             !SGI

      IHS(15)= IHX + 15                                          !SGI
          CALL   BHS(IHX + 15,0,80,0.,80.)                       !SGI
          CALL STEXT(IHX + 15 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 15 ,1,'ABS(Radius)  ALL Hits')        !SGI

*      IHS(16)= IHX + 16                                          !SGI
*          CALL   BHD(IHX + 16,0,50,0.,2500.,40,0.,80.)           !SGI
*          CALL STEXT(IHX + 16 ,4,'FT Radial')                    !SGI
*          CALL STEXT(IHX + 16 ,1,'Drift T vs Radius, ALL Hits')  !SGI

*     IHS(17)= IHX + 17                                          !SGI
*         CALL   BHD(IHX + 17,0,60,0.,300.,40,0.,80.)            !SGI
*         CALL STEXT(IHX + 17 ,4,'FT Radial')                    !SGI
*         CALL STEXT(IHX + 17 ,1,'D-T vs R, Front edge+All Hits')!SGI
*          GMAX = FLOAT(NBINR)
*      IHS(17)= IHX + 17                                          !SGI
*          CALL  BHDW(IHX + 17,0,27,300.,1920.,NBINR,0.,GMAX)     !SGI
*          CALL STEXT(IHX + 17 ,4,'FT Radial')                    !SGI
*          CALL STEXT(IHX + 17 ,1,'RawD-Time DOS/Back +   ')      !SGI

*     IHS(18)= IHX + 18                                          !SGI
*         CALL   BHD(IHX + 18,0,40,300.,1900.,40,0.,80.)         !SGI
*         CALL STEXT(IHX + 18 ,4,'FT Radial')                    !SGI
*         CALL STEXT(IHX + 18 ,1,'D-T vs R, Back edge+All Hits') !SGI
*         GMAX = FLOAT(NBINR)
*     IHS(18)= IHX + 18                                          !SGI
*         CALL  BHDW(IHX + 18,0,27,300.,1920.,NBINR,0.,GMAX)     !SGI
*         CALL STEXT(IHX + 18 ,4,'FT Radial')                    !SGI
*         CALL STEXT(IHX + 18 ,1,'RawD-Time DOS/Back -   ')      !SGI

      IHS(19)= IHX + 19                                          !SGI
          CALL   BHD(IHX + 19,0,100,0.,1000.,4,0.,4.)            !SGI
          CALL STEXT(IHX + 19 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 19 ,1,'Inter-Hit Time all + SM')      !SGI

      IHS(20)= IHX + 20                                          !SGI
          CALL   BHD(IHX + 20,0,50,0.,2500.,30,4.,10.)           !SGI
          CALL STEXT(IHX + 20 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 20 ,1,'Ln(Q) vs T, ALL Hits')         !SGI

      IHS(21)= IHX + 21                                          !SGI
          CALL   BHD(IHX + 21,0,30,4.,10.  ,13,0.,13.)           !SGI
          CALL STEXT(IHX + 21 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 21 ,1,'Ln(Q) ALL Hits and per wire')  !SGI

      IHS(22)= IHX + 22                                          !SGI
          CALL   BHD(IHX + 22,0,50,0.,5000.,4,0.,4.)             !SGI
          CALL STEXT(IHX + 22 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 22 ,1,'Q for Cluster hits + SM')      !SGI

      IHS(23)= IHX + 23                                          !SGI
          CALL   BHD(IHX + 23,0,34,-51.,51.,39,0.,39.)           !SGI
          CALL STEXT(IHX + 23 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 23 ,1,'+/- 2S/V All + SM + Layer')    !SGI

      IHS(24)= IHX + 24                                          !SGI
          CALL  BHSW(IHX + 24,0,60,80.,380.)                     !SGI
          CALL STEXT(IHX + 24 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 24 ,1,'Raw D-Time DOS/Front R<80')    !SGI

          GMAX = FLOAT(NBINR)
      IHS(25)= IHX + 25                                          !SGI
          CALL  BHDW(IHX + 25,0,24,300.,1740.,NBINR,0.,GMAX)     !SGI
          CALL STEXT(IHX + 25 ,4,'FT Radial')                    !SGI
          CALL STEXT(IHX + 25 ,1,'RawD-Time DOS/Back Rbin')      !SGI

      IHS(28) = IHX + 28
          CALL BHS(IHX + 28,0,100,200.,1000.)
          CALL STEXT(IHX + 28 ,4,'FT Radial')
          CALL STEXT(IHX + 28 ,1,'Radial: Mean Drift/event')

      ENDIF

      GMIN = 0.5
      GMAX = FLOAT(LENST) + 0.5

      IHS(26)= IHX + 26                                          !SGI
          CALL  BHSW(IHX + 26,0,LENST,GMIN,GMAX)                 !SGI
          CALL STEXT(IHX + 26,4,'FTD Monitoring')                !SGI
          CALL STEXT(IHX + 26,1,'Run Statistics')                !SGI

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.27  by  Stephen Burke
*CMZU:  4.03/01 06/01/94  18.08.11  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.23  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Extracts basic run parameters for L4 monitoring plot 26
*  DATE/TIME/B_FIELD/PRESSURE/E_CURRENT/P_CURRENT
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FQMON

*KEEP,FMOTOT.
      PARAMETER(LENST=66)
      COMMON/FMOTOT/ ISTSUM(LENST)
*KEEP,FMOLUN.
      COMMON/FMOLUN/ LUNH, LUNS, LMES
*KEEP,FMORUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FMORUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FMOSUM.
      COMMON/FMOSUM/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEND.
      LOGICAL LDATE,LTIME,LFIELD,LPRESS,LECURR,LPCURR,LFIRST
      DATA    LDATE ,LTIME ,LFIELD,LPRESS,LECURR,LPCURR,LFIRST/
     &        .TRUE.,.TRUE., .TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE./

      DATA NRUNL/0/

      IEVIN = IEVIN + 1
      CALL SHSW(IHS(26),0,66.,1.)

      NRUN =  JRDATA('NRUN',IRTN)
      NEVENT = JRDATA('NEVENT',IRTE)
      IF( IRTN.EQ.0 ) THEN

         IF( LFIRST) THEN
            NRUN0 = NRUN
            NRUN1 = NRUN
            ISTSUM(1) = NRUN
            CALL SHSW(IHS(26),0,1.,FLOAT(ISTSUM(1)))
            LFIRST = .FALSE.
         ENDIF

         IF( LDATE )THEN ! try to get date
            NDATE = JRDATA('IDATE',IRTN)
         IF( IRTN.EQ.0 )THEN ! successful
            LDATE = .FALSE.
            NDATE0 = NDATE
            ISTSUM(2) = NDATE
            CALL SHSW(IHS(26),0,2.,FLOAT(ISTSUM(2)))
         ENDIF
         ENDIF

         IF( LTIME )THEN ! try to get time
            NTIME = JRDATA('ITIME',IRTN)
         IF( IRTN.EQ.0 )THEN ! successful
            LTIME = .FALSE.
            NTIME0 = NTIME
            ISTSUM(3) = NTIME
            CALL SHSW(IHS(26),0,3.,FLOAT(ISTSUM(3)))
         ENDIF
         ENDIF

         IF( LFIELD )THEN ! try to get H1 field
            NFIELD = JRDATA('BFIELD',IRTN)
         IF( IRTN.EQ.0 )THEN ! successful
            LFIELD = .FALSE.
            NFIEL0 = NFIELD
            ISTSUM(4) = NFIELD
            CALL SHSW(IHS(26),0,4.,FLOAT(ISTSUM(4)))
         ENDIF
         ENDIF

         IF( LPRESS )THEN ! try to get atmospheric pressure
            NPRESS = JRDATA('PRESSURE',IRTN)
         IF( IRTN.EQ.0 )THEN ! successful
            LPRESS = .FALSE.
            NPRES0 = NPRESS
            ISTSUM(5) = NPRESS
            CALL SHSW(IHS(26),0,5.,FLOAT(ISTSUM(5)))
         ENDIF
         ENDIF

         IF( LECURR )THEN ! try to get electron beam current
            NECURR = JRDATA('ECURRENT',IRTN)
         IF( IRTN.EQ.0 )THEN ! successful
            LECURR = .FALSE.
            NECUR0 = NECURR
            IRTE0  = 0
            ISTSUM(6) = NECURR
            CALL SHSW(IHS(26),0,6.,FLOAT(ISTSUM(6)))
         ENDIF
         ENDIF

         IF( LPCURR )THEN ! try to get proton beam current
            NPCURR = JRDATA('PCURRENT',IRTN)
         IF( IRTN.EQ.0 )THEN ! successful
            LPCURR = .FALSE.
            NPCUR0 = NPCURR
            IRTP0  = 0
            ISTSUM(7) = NPCURR
            CALL SHSW(IHS(26),0,7.,FLOAT(ISTSUM(7)))
         ENDIF
         ENDIF

      ENDIF   ! IRTN ok for NRUN

      IF (NRUN.NE.NRUNL) THEN
         NRUNL = NRUN
         NRUN1 = NRUN
      ENDIF

  100 RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZU:  8.04/00 03/07/96  15.57.06  by  Girish D. Patel
*CMZU:  8.03/00 20/06/96  16.11.28  by  Girish D. Patel
*CMZU:  7.00/12 28/04/95  16.04.48  by  Girish D. Patel
*CMZU:  4.03/01 05/01/94  17.19.40  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.23  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  This routine controls all L4 monitoring plots relating to
*  the planar chambers.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FQMONP

*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEEP,FMOLUN.
      COMMON/FMOLUN/ LUNH, LUNS, LMES
*KEEP,FMORUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FMORUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FMOSUM.
      COMMON/FMOSUM/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FMOSCA.
      COMMON /FMOSCA/ ISCA
*KEEP,FMOWRK.
      PARAMETER (MAXHIT=20)
      LOGICAL LNEWR
      LOGICAL LNEWP
      COMMON/H1WORK/
*     planar hit data...
     +         TT(0:287,4,MAXHIT), NHIT(0:287,4),
     +         QQ(0:287,4,MAXHIT), QQW(4) , LNEWP,
*     radial hit data...
     +         TTR(0:431,4,MAXHIT), NHITR(0:431,4),
     +         QQR(0:431,4,MAXHIT), QQWR(4) , LNEWR,
     +         RR(0:431,4,MAXHIT)
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEND.
*
      DIMENSION ZP(9)

* integer*2 bos array
      PARAMETER (NBOSW2=2*NBOSIW)
      INTEGER*2    IW2(NBOSW2)
      EQUIVALENCE (IW(1),IW2(1))
      LOGICAL FIRST

*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.
*     function for time of flight correction.
      TOF(J) = ( ZP(J/128+1) + MOD(J,4)*SEP - ZMID)/VC
*
      DATA ZP / 132.44,136.70,140.96,174.64,178.90,183.16,216.84,
     &          221.10,225.36/
      DATA SEP /0.60/
      DATA ZMID /175.0/
      DATA VC /29.9792/

      DATA FIRST/.TRUE./

      DATA NRUNL /-1/

      IF(FIRST) THEN
*       'event' banks...
        IQFRPE = NAMIND('FRPE')
        IQFRPD = NAMIND('FRPD')
        IQDER5 = NAMIND('DER5')
*       from database...
        IQF1PA = NAMIND('F1PA')
        FIRST = .FALSE.
      ENDIF

      IF(NRUN.NE.NRUNL) THEN
         NRUNL = NRUN
*
*       Hit database to update
*       wire-by-wire (F1PA) constants.
*
        CALL UGTBNK('F1PA',IND)
      ENDIF

*     Initialise for this event. Zero arrays
      LNEWP = .FALSE.
      NW2 = 1152
      NW3 = NW2*MAXHIT
      CALL VZERO( TT(0,1,1),NW3 )
      CALL VZERO( QQ(0,1,1),NW3 )
      CALL VZERO( NHIT(0,1),NW2 )
      FPT = 0.0

      IND  = IW(IQFRPE)
      IND2 = IW(IQFRPD)
      IND3 = IW(IQDER5)
      IF( IND3.GT.0 ) THEN
         ISTATP(13) = ISTATP(13)+1    ! timing problem?
         CALL SHSW(IHS(26),0,20.,1.)
      ENDIF
      IND1 = IND
      IF( IND .GT.0 )THEN
        IF( IW(IND).LE.1 ) IND1=0
      ENDIF

      IF( IND2.GT.0 )THEN
        IF( IW(IND2).LE.1 ) IND2=0
      ENDIF

* statistics for run summary ...
      IF( IND1.NE.0 ) THEN
         ISTATP(1)=ISTATP(1)+1
         CALL SHSW(IHS(26),0, 8.,1.)
      ENDIF
      IF( IND2.NE.0 ) THEN
         ISTATP(2)=ISTATP(2)+1
         CALL SHSW(IHS(26),0, 9.,1.)
      ENDIF
      IF( (IND1*IND2).NE.0 ) THEN
         ISTATP(3)=ISTATP(3)+1
         CALL SHSW(IHS(26),0,10.,1.)
      ENDIF
      IF( IND1.EQ.0 .AND. IND2.EQ.0 ) THEN
         ISTATP(4)=ISTATP(4)+1
         CALL SHSW(IHS(26),0,11.,1.)
      ENDIF

      IF (IND.NE.0) THEN
C                          FRPE BANK PRESENT - GO FOR IT !!!
C ATTEMPT TO READ WIRE NO., T AND Q FROM BANK
C
      NFPEVT = NFPEVT+1

      INDX = IND*2
      NW = IW(IND)
      NHW = NW*2
      NBANK = IW(IND-2)
      NROW  = IW2(INDX+2)


C               INDX IS THE ADDRESS OF THE END OF THE PREVIOUS RECORD
C               IN 2-BYTE WORDS
C                                CHECK CONTENTS ARE BELIEVABLE (?)
      IF (NW.NE.NROW*3+1) THEN
         WRITE(LMES,132) NROW,NFPEVT,NW,IND,NBANK
  132    FORMAT(' WARNING : NROW = ',I6,' IN EVENT ',I6,' BUT NW = ',
     *   I6,/,' FRPE POINTER = ',I6,' BANK NUMBER = ',I6)

         GOTO 100
      ENDIF
      NHITSP = NHITSP + NROW
      INDX = INDX+2
C               EVERYTHING SHOUD BE OK - READ OUT CONTENTS
      IF( NROW.GT.0 )THEN

      IND1PA = IW(IQF1PA)

      DO 137 I = 1,NROW
C                               LOOP OVER HITS IN QT OUTPUT BANK
         IWIRE = IW2(INDX+1)
         IDT   = IW2(INDX+2)     ! DRIFT TIME IN FADC BINS * ISCA
         IQ    = IW2(INDX+3)     ! INTEGRATED CHARGE FOR WHOLE PULSE

*        Extract wire dependent T0 for Channel IWIRE...
         T0    = RBTAB(IND1PA, 1,IWIRE+1)


*        Correct drift time for wire-by-wire T0
         TCOR  = FLOAT(IDT) - T0
         TOFCOR= TOF(IWIRE)
         FDT   = 9.6154*TCOR/FLOAT(ISCA) - TOFCOR
         FQ    = FLOAT(IQ)

         IF(FDT.LT.1600.0) FPT = FPT + FDT

         CALL FILLQP(IWIRE,FDT,FQ,0)  ! fill T and Q arrays


         INDX = INDX+6
  137 CONTINUE

      FPT = FPT/FLOAT(NROW)
      CALL  SHS (IHS(27),0,FPT)

      ENDIF
        CALL FCHKQP
      ENDIF

  100 RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.28  by  Stephen Burke
*CMZ :  7.01/04 04/08/95  13.26.25  by  Gaby Raedel
*CMZU:  7.00/12 28/04/95  16.14.07  by  Girish D. Patel
*CMZU:  4.03/01 05/01/94  17.25.37  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.23  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Stores planar hits (Q & T) sorted by cell/wire in cell for
*  later checksum analysis.
*
*HTMLI     : Describe the Input variables to the routine
*
*  IW = Planar Channel Number (0 TO 1151)
*  T  = Drift Time in nsec
*  Q  = Integrated Charge (FADC bins * FADC channel content)
*  M  = DOS multiplicity within hit (=1 for "clean" hit,0 if no info)
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments. The arrays TT and QQ in COMMON H1WORK
*  are filled
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FILLQP(IW,T,Q,M)
**********************************************************************
*                                                                    *
* Fill arrays with Ts and Qs for all cells, per event                *
* IW = Planar Channel Number (0 TO 1151)                             *
* T  = Drift Time in nsec                                            *
* Q  = Integrated Charge (FADC bins * FADC channel content)          *
* M  = DOS multiplicity within hit (=1 for "clean" hit,0 if no info) *
*                                                                    *
* JVM  9/6/92                                                        *
**********************************************************************

*KEEP,FMOSUM.
      COMMON/FMOSUM/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FMOWRK.
      PARAMETER (MAXHIT=20)
      LOGICAL LNEWR
      LOGICAL LNEWP
      COMMON/H1WORK/
*     planar hit data...
     +         TT(0:287,4,MAXHIT), NHIT(0:287,4),
     +         QQ(0:287,4,MAXHIT), QQW(4) , LNEWP,
*     radial hit data...
     +         TTR(0:431,4,MAXHIT), NHITR(0:431,4),
     +         QQR(0:431,4,MAXHIT), QQWR(4) , LNEWR,
     +         RR(0:431,4,MAXHIT)
*KEEP,FMOHIT.
      COMMON/FMOHIT/ LHITSP(0:8), LHITSR(0:8)
*KEND.

*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEEP,FMOLUN.
      COMMON/FMOLUN/ LUNH, LUNS, LMES
*KEND.

      ISTATP(11) = ISTATP(11) + 1
      CALL SHSW(IHS(26),0,18.,1.)
      IF( Q.LE.0. )THEN
        ISTATP(12) = ISTATP(12) + 1
      CALL SHSW(IHS(26),0,19.,1.)
        RETURN
      ENDIF
      QLOG = ALOG(Q)

      IF(IW.LT.0 .OR. IW.GT.1151)THEN
         WRITE(LMES,1000)IW,NEVENT
 1000    FORMAT(1X,'*** FILLQP; illegal wire number',I10,' Event',I10)
         RETURN
      ENDIF

      NC = IW/4
      NWC= MOD(IW,4)+1
      KRATE = IW/192
      ICKR  = MOD(IW,192)/4    ! cell number within crate
      NCO = MOD(NC,32)
      NPIOS = (IW/128)*4+NWC
         CALL SHD (IHS(1),0,FLOAT(NCO),FLOAT(NPIOS))             !SGI

* fill vector of hits per orientation
      LH = IW/128
      LM = IW/384
      LHITSP(LH) = LHITSP(LH) + 1
* Histograms for ALL available hits ...
      CALL SHSW(IHS(26),0,48.+FLOAT(LH),1.)
         CALL SHD (IHS( 5),0,T,QLOG)                             !SGI
         CALL SHD (IHS( 6),0,QLOG,0.)                            !SGI
         CALL SHD (IHS( 6),0,QLOG,FLOAT(NWC) )                   !SGI
         CALL SHS (IHS(3),0,T)                                   !SGI
         CALL SHDW (IHS(10),0,T-5.,0.5,+1.)                      !SGI
         CALL SHDW (IHS(10),0,T+5.,0.5,-1.)                      !SGI
         CALL SHDW (IHS(10),0,T-5.,FLOAT(LM)+1.5,+1.)            !SGI
         CALL SHDW (IHS(10),0,T+5.,FLOAT(LM)+1.5,-1.)            !SGI
         CALL SHDW (IHS(10),0,T-5.,FLOAT(LH)+4.5,+1.)            !SGI
         CALL SHDW (IHS(10),0,T+5.,FLOAT(LH)+4.5,-1.)            !SGI
         CALL SHDW (IHS( 9),0,T-5.,0.5,-1.)                      !SGI
         CALL SHDW (IHS( 9),0,T+5.,0.5,+1.)                      !SGI
         CALL SHDW (IHS( 9),0,T-5.,FLOAT(LM)+1.5,-1.)            !SGI
         CALL SHDW (IHS( 9),0,T+5.,FLOAT(LM)+1.5,+1.)            !SGI
         CALL SHDW (IHS( 9),0,T-5.,FLOAT(LH)+4.5,-1.)            !SGI
         CALL SHDW (IHS( 9),0,T+5.,FLOAT(LH)+4.5,+1.)            !SGI

         IF( NHIT(NC,NWC).EQ.MAXHIT ) GOTO 9000
         NHIT(NC,NWC) = NHIT(NC,NWC)+1
         TT(NC,NWC,NHIT(NC,NWC)) = T
         QQ(NC,NWC,NHIT(NC,NWC)) = Q
         LNEWP = .TRUE.
 9000 CONTINUE

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.28  by  Stephen Burke
*CMZU:  7.00/12 28/04/95  16.17.08  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.23  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Fill histograms from hits in COMMON/H1WORK/, entered by FILLQP
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FCHKQP
**********************************************************************
*                                                                    *
* Fill histograms from hits in COMMON/H1WORK/, entered by FILLQP     *
*                                                                    *
* JVM  22/7/92                                                       *
**********************************************************************

*KEEP,FMOWRK.
      PARAMETER (MAXHIT=20)
      LOGICAL LNEWR
      LOGICAL LNEWP
      COMMON/H1WORK/
*     planar hit data...
     +         TT(0:287,4,MAXHIT), NHIT(0:287,4),
     +         QQ(0:287,4,MAXHIT), QQW(4) , LNEWP,
*     radial hit data...
     +         TTR(0:431,4,MAXHIT), NHITR(0:431,4),
     +         QQR(0:431,4,MAXHIT), QQWR(4) , LNEWR,
     +         RR(0:431,4,MAXHIT)
*KEND.
      LOGICAL LFREE
      DIMENSION LFREE(4,MAXHIT)
      DIMENSION MWR(4)

*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEND.

* check that COMMON/NEWP/ has some data ..
      IF( LNEWP )THEN
        LNEWP = .FALSE.
      ELSE
        RETURN
      ENDIF


* cycle through the cells ...
      DO 9000 NC=0,287
      NSMOD = NC/96
      NSLAY = NC/32
        CHITS = FLOAT( NHIT(NC,1)+NHIT(NC,2)+NHIT(NC,3)+NHIT(NC,4) )
        CALL HF1(2,CHITS,1.)
             CALL SHS (IHS(2),0,CHITS)                           !SGI
*       analyse existing hits in cell NC, if there are any
        DO 100 J=1,4

        IF( NHIT(NC,J).GT.1 )THEN      ! look for periodic noise
          DO 111 JHT=2,NHIT(NC,J)
          TDIF = ABS( TT(NC,J,JHT)-TT(NC,J,JHT-1) )
             CALL SHD (IHS(4),0,TDIF,0.)                         !SGI
             CALL SHD (IHS(4),0,TDIF,FLOAT(NSMOD+1))             !SGI
  111     CONTINUE
        ENDIF

  100   CONTINUE
*
* complete set of hits available here
      MULTI = NHIT(NC,1)*NHIT(NC,2)*NHIT(NC,3)*NHIT(NC,4)
      MULT2 = NHIT(NC,1)*NHIT(NC,3)*NHIT(NC,4)
      MULT3 = NHIT(NC,1)*NHIT(NC,2)*NHIT(NC,4)

      IF( MULTI.EQ.1 )THEN      ! loop through combinations ?

*     set flag "LFREE" to flag Qs which have not yet been plotted in
*     hist ID=22 .....
      DO 2 JWR=1,4
      DO 2 JWH=1,MAXHIT
    2 LFREE(JWR,JWH) = .TRUE.

      DO 200 J1=1,NHIT(NC,1)
        MWR(1) = J1
      DO 200 J2=1,NHIT(NC,2)
        MWR(2) = J2
      DO 200 J3=1,NHIT(NC,3)
        MWR(3) = J3
      DO 200 J4=1,NHIT(NC,4)
        MWR(4) = J4

        CHK1 = (TT(NC,2,J2)-TT(NC,1,J1))-(TT(NC,4,J4)-TT(NC,3,J3))
        CHK2 = (TT(NC,2,J2)-TT(NC,1,J1))+(TT(NC,4,J4)-TT(NC,3,J3))
        X1 = 0.75*(TT(NC,2,J2)-TT(NC,3,J3))
     &     - 0.25*(TT(NC,1,J1)-TT(NC,4,J4))

        IF( MULTI.EQ.1 )THEN
          X2 = TT(NC,3,J3) - 0.33333*TT(NC,1,J1) - 0.66667*TT(NC,4,J4)
          X3 = TT(NC,2,J2) - 0.33333*TT(NC,4,J4) - 0.66667*TT(NC,1,J1)
          CALL SHD (IHS( 8),0,X2,13.5)                           !SGI
          CALL SHD (IHS( 8),0,X2,FLOAT(NSMOD+1)+13.5)            !SGI
          CALL SHD (IHS( 8),0,X2,FLOAT(NSLAY+4)+13.5)            !SGI
          CALL SHD (IHS( 8),0,X3,13.5)                           !SGI
          CALL SHD (IHS( 8),0,X3,FLOAT(NSMOD+1)+13.5)            !SGI
          CALL SHD (IHS( 8),0,X3,FLOAT(NSLAY+4)+13.5)            !SGI
        ENDIF


        IF( ABS(CHK1).LE.100.0 .AND. ABS(CHK2).GT.24.0 )THEN
             CALL SHD (IHS( 8),0,X1,0.5)                         !SGI
             CALL SHD (IHS( 8),0,X1,FLOAT(NSMOD+1)+0.5)          !SGI
             CALL SHD (IHS( 8),0,X1,FLOAT(NSLAY+4)+0.5)          !SGI

          QQW(1) = QQ(NC,1,J1)
          QQW(2) = QQ(NC,2,J2)
          QQW(3) = QQ(NC,3,J3)
          QQW(4) = QQ(NC,4,J4)

          DO 6666 J=1,4
          IF( LFREE(J,MWR(J)) )THEN
          LFREE(J,MWR(J)) = .FALSE.
             QLOG = ALOG(QQW(J))
             CALL SHD (IHS( 7),0,QLOG,0.)                        !SGI
             CALL SHD (IHS( 7),0,QLOG,FLOAT(NSMOD+1))            !SGI
          ENDIF
 6666     CONTINUE


        ENDIF
  200 CONTINUE
      ELSE IF(MULTI.EQ.0 .AND. MULT2.EQ.1 ) THEN
        X2 = TT(NC,3,1) - 0.33333*TT(NC,1,1) - 0.66667*TT(NC,4,1)
          CALL SHD (IHS( 8),0,X2,26.5)                           !SGI
          CALL SHD (IHS( 8),0,X2,FLOAT(NSMOD+1)+26.5)            !SGI
          CALL SHD (IHS( 8),0,X2,FLOAT(NSLAY+4)+26.5)            !SGI
      ELSE IF(MULTI.EQ.0 .AND. MULT3.EQ.1 ) THEN
        X3 = TT(NC,2,1) - 0.33333*TT(NC,4,1) - 0.66667*TT(NC,1,1)
          CALL SHD (IHS( 8),0,X3,26.5)                           !SGI
          CALL SHD (IHS( 8),0,X3,FLOAT(NSMOD+1)+26.5)            !SGI
          CALL SHD (IHS( 8),0,X3,FLOAT(NSLAY+4)+26.5)            !SGI
      ENDIF

  101   CONTINUE
 9000 CONTINUE                ! cycle on cells

*       zero arrays ready for next event
        NW2 = 1152
        NW3 = NW2*MAXHIT
        CALL VZERO( TT(0,1,1),NW3 )
        CALL VZERO( QQ(0,1,1),NW3 )
        CALL VZERO( NHIT(0,1),NW2 )

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.36  by  Stephen Burke
*CMZU:  8.04/00 03/07/96  15.57.59  by  Girish D. Patel
*CMZU:  8.03/00 20/06/96  16.11.55  by  Girish D. Patel
*CMZU:  7.00/12 28/04/95  16.24.16  by  Girish D. Patel
*CMZU:  4.03/01 05/01/94  17.32.58  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.24  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  This routine controls all L4 monitoring plots relating to
*  the radial chambers.
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*

      SUBROUTINE FQMONR
**: FQMONR.......SM. Modifications for farm.
**: FQMONR.......SM. Addition of alpha and T0 corrections.

*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEEP,FMOLUN.
      COMMON/FMOLUN/ LUNH, LUNS, LMES
*KEEP,FMORUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FMORUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FMOSUM.
      COMMON/FMOSUM/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FMOSCA.
      COMMON /FMOSCA/ ISCA
*KEEP,FMOWRK.
      PARAMETER (MAXHIT=20)
      LOGICAL LNEWR
      LOGICAL LNEWP
      COMMON/H1WORK/
*     planar hit data...
     +         TT(0:287,4,MAXHIT), NHIT(0:287,4),
     +         QQ(0:287,4,MAXHIT), QQW(4) , LNEWP,
*     radial hit data...
     +         TTR(0:431,4,MAXHIT), NHITR(0:431,4),
     +         QQR(0:431,4,MAXHIT), QQWR(4) , LNEWR,
     +         RR(0:431,4,MAXHIT)
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEND.

      DIMENSION ZP(3)

* integer*2 bos array
      PARAMETER (NBOSW2=2*NBOSIW)
      INTEGER*2    IW2(NBOSW2)
      EQUIVALENCE (IW(1),IW2(1))
      LOGICAL FIRST
*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.
*     function for time of flight correction.
      TOF(J) = ( ZP(J/288+1) + MOD(J,12)*SEP - ZMID)/VC

      DATA ZP / 159.20,201.40,243.60/
      DATA SEP /1.00/
      DATA ZMID /200.0/
      DATA VC /29.9792/

      DATA NRUNL /-1/
      DATA FIRST/.TRUE./

      IF(FIRST) THEN
*       'event' banks
        IQFRRE = NAMIND('FRRE')
        IQFRRD = NAMIND('FRRD')
        IQDER5 = NAMIND('DER5')
*       from database
        IQF0R8 = NAMIND('F0R8')
        IQF1RA = NAMIND('F1RA')
        IQF1RB = NAMIND('F1RB')
        FIRST = .FALSE.
      ENDIF

      IF(NRUN.NE.NRUNL) THEN
         NRUNL = NRUN
*
*       Hit database to update overall (F0R8) and
*       wire-by-wire (F1RA/B) constants.
*
        CALL UGTBNK('F0R8',IND)
        CALL UGTBNK('F1RA',IND)
        CALL UGTBNK('F1RB',IND)
        IND0R8 = IW(IQF0R8)
        XI     = RBTAB(IND0R8,12,1)
      ENDIF

*     Initialise for this event. Zero arrays.
      LNEWR = .FALSE.
      NW2 = 2128
      NW3 = NW2*MAXHIT
      NW4 = 1728*MAXHIT
      CALL VZERO( TTR(0,1,1),NW3 )
      CALL VZERO( QQR(0,1,1),NW3 )
      CALL VZERO( NHITR(0,1),NW2 )
      CALL VZERO( RR(0,1,1),NW4 )

      FRT = 0.0

      IND  = IW(IQFRRE)
      IND2 = IW(IQFRRD)
      IND3 = IW(IQDER5)
      IF( IND3.GT.0 ) THEN
         ISTATR(13) = ISTATR(13)+1    ! timing problem?
         CALL SHSW(IHS(26),0,40.,1.)
      ENDIF
      IND1 = IND
      IF( IND .GT.0 )THEN
        IF( IW(IND).LE.1 ) IND1=0
      ENDIF

      IF( IND2.GT.0 )THEN
        IF( IW(IND2).LE.1 ) IND2=0
      ENDIF

* statistics for run summary ...
      IF( IND1.NE.0 ) THEN
         ISTATR(1)=ISTATR(1)+1
         CALL SHSW(IHS(26),0,28.,1.)
      ENDIF
      IF( IND2.NE.0 ) THEN
         ISTATR(2)=ISTATR(2)+1
         CALL SHSW(IHS(26),0,29.,1.)
      ENDIF
      IF( (IND1*IND2).NE.0 ) THEN
         ISTATR(3)=ISTATR(3)+1
         CALL SHSW(IHS(26),0,30.,1.)
      ENDIF
      IF( IND1.EQ.0 .AND. IND2.EQ.0 ) THEN
         ISTATR(4)=ISTATR(4)+1
         CALL SHSW(IHS(26),0,31.,1.)
      ENDIF

      IF (IND.NE.0 ) THEN
C                          FRRE BANK PRESENT - GO FOR IT !!!
C ATTEMPT TO READ WIRE NO., T AND Q FROM BANK
C
      NFREVT = NFREVT+1

      INDX = IND*2
      NW = IW(IND)
      NHW = NW*2
      NBANK = IW(IND-2)
      NROW  = IW2(INDX+2)
C               INDX IS THE ADDRESS OF THE END OF THE PREVIOUS RECORD
C               IN 2-BYTE WORDS
C                                CHECK CONTENTS ARE BELIEVABLE (?)
      IF (NW.NE.NROW*3+1) THEN
         WRITE(LMES,132) NROW,NFREVT,NW,IND,NBANK
  132    FORMAT(' WARNING : NROW = ',I6,' IN EVENT ',I6,' BUT NW = ',
     *   I6,/,' FRRE POINTER = ',I6,' BANK NUMBER = ',I6)

         GOTO 100
      ENDIF
      NHITSR = NHITSR + NROW
      INDX = INDX+2
C               EVERYTHING SHOULD BE OK - READ OUT CONTENTS
      IF( NROW.GT.0 )THEN

      IND1RA = IW(IQF1RA)
      IND1RB = IW(IQF1RB)

      DO 137 I = 1,NROW
C                               LOOP OVER HITS IN QT OUTPUT BANK

         IWIRE = IW2(INDX+1)
         IDT   = IW2(INDX+2)     ! DRIFT TIME IN FADC BINS * ISCA
         IQP   = IW2(INDX+3)     ! INTEGRATED CHARGE FOR + END OF WIRE
         IQM   = IW2(INDX+4)     ! INTEGRATED CHARGE FOR - END OF WIRE
         IFLG2 = IW2(INDX+6)     ! IFLAG2 FADC pulse information

*        Extract wire dependent constants for Channel IWIRE...
         T0    = RBTAB(IND1RA, 1,IWIRE+1)
         DELD  = RBTAB(IND1RA, 2,IWIRE+1)
         DELT  = RBTAB(IND1RA, 3,IWIRE+1)
         RELG  = RBTAB(IND1RA, 4,IWIRE+1)
         ELEFOL= RBTAB(IND1RA, 6,IWIRE+1)

         RPLUS = RBTAB(IND1RB, 1,IWIRE+1)
         RMINUS= RBTAB(IND1RB, 2,IWIRE+1)
         RESPLU= RBTAB(IND1RB, 3,IWIRE+1)
         RESMIN= RBTAB(IND1RB, 4,IWIRE+1)
         RMINPL= RBTAB(IND1RB, 5,IWIRE+1)
         RMINMI= RBTAB(IND1RB, 6,IWIRE+1)


         IQ    = IQP + IQM      ! INTEGRATED CHARGE FOR TOTAL PULSE
         FQ    = FLOAT(IQ)
         QPLUS = FLOAT(IQP)
         QMINUS= FLOAT(IQM)

*        Determine alpha. Needed for correction to Drift time
*        as well as for radial coordinate.
         DENOM = QPLUS + RELG*QMINUS
         IF (DENOM .GT. 0.0) THEN
            ALP   =(QPLUS - RELG*QMINUS) / DENOM
            IBADQ = 0
         ELSE
            CALL ERRLOG(100, 'W:FQMONR: Zero charge digi found')
            ALP = 0.0
            IBADQ = 1
         ENDIF
*
*        Determine radial coordinate by charge divison
*
         SIGMA = (RPLUS + RMINUS)*ELEFOL
         DELTA =  RPLUS- RMINUS

         RPL     =  +  (SIGMA*ALP+DELTA)/(2.*RESPLU)
         RPM     =  -  (SIGMA*ALP+DELTA)/(2.*RESMIN)
*        Choose valid solution, add inner radius and apply
*        chg-div distortion correction (linear part only for now)
         IF(RPL .GE. 0.0) THEN
            RADIUS = RPL*(1.0 + XI) + RMINPL
            RAD = RPL + RMINPL
            ISGNW  = 1
         ELSE
            RADIUS = RPM*(1.0 + XI) + RMINMI
            RAD = RPM + RMINMI
            ISGNW  = -1
         ENDIF
**
*        Correct drift time for wire-by-wire T0 and radius
         TALP  = 0.5*ALP*(DELD - ALP*DELT)
         TCOR  = FLOAT(IDT) - (T0 + TALP)
         TOFCOR= TOF(IWIRE)
         FDT   = 9.6154*TCOR/FLOAT(ISCA) - TOFCOR

         IF(FDT.LT.1600.0) FRT = FRT + FDT

         CALL FILLQR(IWIRE,FDT,FQ,RADIUS,ISGNW,IFLG2)

         INDX = INDX+6
  137 CONTINUE

      FRT = FRT/FLOAT(NROW)
      CALL  SHS (IHS(28),0,FRT)

      ENDIF
        CALL FCHKQR
      ENDIF

*
*   END OF LOOP OVER EVENTS - COLLECT STATISTICS
*
  100 RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.37  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.28  by  Stephen Burke
*CMZU:  8.03/00 20/06/96  16.12.18  by  Girish D. Patel
*CMZU:  7.00/12 28/04/95  16.26.35  by  Girish D. Patel
*CMZU:  4.03/01 05/01/94  17.34.33  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.24  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Stores Radial hits (Q , T & radius ) sorted by cell/wire in
*  cell for later checksum analysis.
*
*HTMLI     : Describe the Input variables to the routine
*
*  IW    = Planar Channel Number (0 TO 1151)
*  T     = Drift Time in nsec
*  Q     = Integrated Charge (FADC bins * FADC channel content)
*  RAD   = Charge division radius of hit in cms
*  IS    = Wedge pair indicator 1 = + wedge , -1 = - wedge
*  IFLG2 = IFLAG2 FADC pulse information
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments. The arrays TTR, QQR and RR in COMMON H1WORK
*  are filled
*
*HTMLE     : Terminates the HTML documentation
*
*
      SUBROUTINE FILLQR(IW,T,Q,RAD,IS,IFLG2)
**********************************************************************
*                                                                    *
* Fill arrays with Ts and Qs for all cells, per event                *
* IW    = Planar Channel Number (0 TO 1151)                          *
* T     = Drift Time in nsec                                         *
* Q     = Integrated Charge (FADC bins * FADC channel content)       *
* RAD   = Charge division radius of hit in cms                       *
* IS    = Wedge pair indicator 1 = + wedge , -1 = - wedge            *
* IFLG2 = IFLAG2 FADC pulse information                              *
*                                                                    *
* JVM  9/6/92                                                        *
**********************************************************************
*KEEP,FMOBIN.
      PARAMETER( NBINR=40 )
*KEEP,FMOLUN.
      COMMON/FMOLUN/ LUNH, LUNS, LMES
*KEEP,FMOSUM.
      COMMON/FMOSUM/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FMOHIT.
      COMMON/FMOHIT/ LHITSP(0:8), LHITSR(0:8)
*KEEP,FMOWRK.
      PARAMETER (MAXHIT=20)
      LOGICAL LNEWR
      LOGICAL LNEWP
      COMMON/H1WORK/
*     planar hit data...
     +         TT(0:287,4,MAXHIT), NHIT(0:287,4),
     +         QQ(0:287,4,MAXHIT), QQW(4) , LNEWP,
*     radial hit data...
     +         TTR(0:431,4,MAXHIT), NHITR(0:431,4),
     +         QQR(0:431,4,MAXHIT), QQWR(4) , LNEWR,
     +         RR(0:431,4,MAXHIT)
*KEND.

*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEND.

      ISTATR(11) = ISTATR(11) + 1
      CALL SHSW(IHS(26),0,38.,1.)
      IF( Q.LE.0. )THEN
        ISTATR(12) = ISTATR(12) + 1
        CALL SHSW(IHS(26),0,39.,1.)
        RETURN
      ENDIF
      QLOG = ALOG(Q)

      IF(IW.LT.0 .OR. IW.GT.863)THEN
         WRITE(LMES,1000)IW,NEVENT
 1000    FORMAT(1X,'*** FILLQR; illegal wire number',I10,' Event',I10)
         RETURN
      ENDIF

      NWM = IW/288
      NWP = (IW-NWM*288)/12
      NWP2= (NWP/2)*4 + MOD(NWP,2)
      IF(IS.EQ.-1) NWP2 = MOD(NWP2+34,48)
      NWO = MOD(IW,12)/4
      NWW = MOD(IW,12)+1
      NC  = NWM*144 + NWP2 + NWO*48
      NWC= MOD(IW,4)+1
      KRATE = IW/192
      ICKR  = MOD(IW,192)/4    ! cell number within crate
      NWPPM = NWP*2+(IS+1)/2
         CALL  SHD (IHS(11),0,FLOAT(NWPPM),FLOAT(NWM*12+NWW))    !SGI

* fill vector of hits per orientation
      LH = NWM*3 + NWO
      LHITSR(LH) = LHITSR(LH) + 1
      CALL SHSW(IHS(26),0,57.+FLOAT(LH),1.)
* Histograms for ALL available hits ...
         CALL  SHS (IHS(13),0,T)                                 !SGI
*GDP     CALL  SHS (IHS(14),0,RAD*FLOAT(IS))                     !SGI
         CALL  SHS (IHS(15),0,RAD)                               !SGI
      IF(RAD.LT.80.0) THEN
         CALL  SHSW(IHS(24),0,T-5.,+1.)                          !SGI
         CALL  SHSW(IHS(24),0,T+5.,-1.)                          !SGI
        XRAD = RAD*FLOAT(NBINR)/80.0
        IRAD = XRAD
         CALL  SHDW(IHS(25),0,T-60.,XRAD,-1.)                    !SGI
         CALL  SHDW(IHS(25),0,T+60.,XRAD,+1.)                    !SGI
      ENDIF
*GDP     CALL  SHD (IHS(16),0,T,RAD)                             !SGI
         CALL  SHD (IHS(20),0,T,QLOG)                            !SGI
*GDP     CALL  SHD (IHS(17),0,T,RAD)       Histo  redefined      !SGI
*GDP     CALL  SHD (IHS(18),0,T,RAD)       Histo  redefined      !SGI
         CALL  SHD (IHS(21),0,QLOG,0.)                           !SGI
         CALL  SHD (IHS(21),0,QLOG,FLOAT(NWW))                   !SGI
         IF( NHITR(NC,NWC).EQ.MAXHIT ) GOTO 9000
         NHITR(NC,NWC) = NHITR(NC,NWC)+1
         TTR(NC,NWC,NHITR(NC,NWC)) = T
         QQR(NC,NWC,NHITR(NC,NWC)) = Q
         RR(NC,NWC,NHITR(NC,NWC)) = RAD
         LNEWR = .TRUE.
 9000 CONTINUE

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.37  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.28  by  Stephen Burke
*CMZU:  7.00/12 28/04/95  16.35.12  by  Girish D. Patel
*CMZ :  4.01/00 07/12/93  19.55.24  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/12/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Fill histograms from hits in COMMON/H1WORK/, entered by FILLQR
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*

      SUBROUTINE FCHKQR
**********************************************************************
*                                                                    *
* Fill histograms from hits in COMMON/H1WORK/, entered by FILLQR     *
*                                                                    *
* JVM  22/7/92                                                       *
**********************************************************************

*KEEP,FMOBIN.
      PARAMETER( NBINR=40 )
*KEEP,FMOWRK.
      PARAMETER (MAXHIT=20)
      LOGICAL LNEWR
      LOGICAL LNEWP
      COMMON/H1WORK/
*     planar hit data...
     +         TT(0:287,4,MAXHIT), NHIT(0:287,4),
     +         QQ(0:287,4,MAXHIT), QQW(4) , LNEWP,
*     radial hit data...
     +         TTR(0:431,4,MAXHIT), NHITR(0:431,4),
     +         QQR(0:431,4,MAXHIT), QQWR(4) , LNEWR,
     +         RR(0:431,4,MAXHIT)
*KEND.
      LOGICAL LFREE
      DIMENSION LFREE(4,MAXHIT)
      DIMENSION MWR(4),TTW(4),RRW(4)

*KEEP,FMOHIS.
      INTEGER IHS(28)
      COMMON/FMOHIS/ IHS
*KEND.

* check that COMMON/H1WORK/ has some data ..
      IF( LNEWR )THEN
        LNEWR = .FALSE.
      ELSE
        RETURN
      ENDIF


* cycle through the cells ...
      DO 9000 NC=0,431
      NSMOD = NC/144
      NLAY  = NC/48
        CHITS = FLOAT(NHITR(NC,1)+NHITR(NC,2)+NHITR(NC,3)+NHITR(NC,4))
             CALL  SHS (IHS(12),0,CHITS)                         !SGI
*       analyse existing hits in cell NC, if there are any
        DO 100 J=1,4

        IF( NHITR(NC,J).GT.1 )THEN      ! look for periodic noise
          DO 111 JHT=2,NHITR(NC,J)
          TDIF = ABS( TTR(NC,J,JHT)-TTR(NC,J,JHT-1) )
             CALL SHD (IHS(19),0,TDIF,0.)                        !SGI
             CALL SHD (IHS(19),0,TDIF,FLOAT(NSMOD+1))            !SGI
  111     CONTINUE
        ENDIF

  100   CONTINUE
*
* complete set of hits available here
      MULTI = NHITR(NC,1)*NHITR(NC,2)*NHITR(NC,3)*NHITR(NC,4)
      MULT2 = NHITR(NC,1)*NHITR(NC,3)*NHITR(NC,4)
      MULT3 = NHITR(NC,1)*NHITR(NC,2)*NHITR(NC,4)

      IF( MULTI.EQ.1 )THEN      ! loop through combinations ?

*     set flag "LFREE" to flag Qs which have not yet been plotted in
*     hist ID=68 ...
      DO 2 JWR=1,4
      DO 2 JWH=1,MAXHIT
    2 LFREE(JWR,JWH) = .TRUE.

      DO 200 J1=1,NHITR(NC,1)
        MWR(1) = J1
      DO 200 J2=1,NHITR(NC,2)
        MWR(2) = J2
      DO 200 J3=1,NHITR(NC,3)
        MWR(3) = J3
      DO 200 J4=1,NHITR(NC,4)
        MWR(4) = J4

        CHK1 = (TTR(NC,2,J2)-TTR(NC,1,J1))-(TTR(NC,4,J4)-TTR(NC,3,J3))
        CHK2 = (TTR(NC,2,J2)-TTR(NC,1,J1))+(TTR(NC,4,J4)-TTR(NC,3,J3))
        X1 = 0.75*(TTR(NC,2,J2)-TTR(NC,3,J3))
     &     - 0.25*(TTR(NC,1,J1)-TTR(NC,4,J4))

        IF( MULTI.EQ.1 )THEN
          X2 = TTR(NC,3,J3)-0.33333*TTR(NC,1,J1)-0.66667*TTR(NC,4,J4)
          X3 = TTR(NC,2,J2)-0.33333*TTR(NC,4,J4)-0.66667*TTR(NC,1,J1)
          CALL SHD (IHS(23),0,X2,13.5)                           !SGI
          CALL SHD (IHS(23),0,X2,FLOAT(NSMOD+1)+13.5)            !SGI
          CALL SHD (IHS(23),0,X2,FLOAT(NLAY+4)+13.5)             !SGI
          CALL SHD (IHS(23),0,X3,13.5)                           !SGI
          CALL SHD (IHS(23),0,X3,FLOAT(NSMOD+1)+13.5)            !SGI
          CALL SHD (IHS(23),0,X3,FLOAT(NLAY+4)+13.5)             !SGI
        ENDIF


        IF( ABS(CHK1).LE.100.0 .AND. ABS(CHK2).GT.24.0 )THEN
          CALL SHD (IHS(23),0,X1,0.5)                            !SGI
          CALL SHD (IHS(23),0,X1,FLOAT(NSMOD+1)+0.5)             !SGI
          CALL SHD (IHS(23),0,X1,FLOAT(NLAY+4)+0.5)              !SGI

*          RAD  = (RR(NC,2,J1)+RR(NC,1,J2)+RR(NC,4,J3)+RR(NC,3,J4))/4.0

          QQWR(1) = QQR(NC,1,J1)
          QQWR(2) = QQR(NC,2,J2)
          QQWR(3) = QQR(NC,3,J3)
          QQWR(4) = QQR(NC,4,J4)

*          TTW(1) = TTR(NC,1,J1)
*          TTW(2) = TTR(NC,2,J2)
*          TTW(3) = TTR(NC,3,J3)
*          TTW(4) = TTR(NC,4,J4)

*          RRW(1) = RR(NC,1,J1)
*          RRW(2) = RR(NC,2,J2)
*          RRW(3) = RR(NC,3,J3)
*          RRW(4) = RR(NC,4,J4)

*          SRZ  = -0.3*RRW(1) - 0.1*RRW(2) + 0.1*RRW(3) + 0.3*RRW(4)
*          CRZ  =      RRW(1) + 0.5*RRW(2)              - 0.5*RRW(4)

          DO 6666 J=1,4
          IF( LFREE(J,MWR(J)) )THEN
            LFREE(J,MWR(J)) = .FALSE.
             CALL SHD (IHS(22),0,QQWR(J),0.)                     !SGI
             CALL SHD (IHS(22),0,QQWR(J),FLOAT(NSMOD+1))         !SGI
          ENDIF
*          RPRED = SRZ*FLOAT(J) + CRZ
*          IF(RPRED.LT.80.0) THEN
*            YRPRED = RPRED*FLOAT(NBINR)/80.0
*            IRPRED = YRPRED
*            IF(X1.GT.0.0) THEN
*             CALL SHDW(IHS(17),0,TTW(J)-60.,YRPRED,-1.)          !SGI
*             CALL SHDW(IHS(17),0,TTW(J)+60.,YRPRED,+1.)          !SGI
*            ELSE
*             CALL SHDW(IHS(18),0,TTW(J)-60.,YRPRED,-1.)          !SGI
*             CALL SHDW(IHS(18),0,TTW(J)+60.,YRPRED,+1.)          !SGI
*            ENDIF
*          ENDIF
*          IF(RAD.LT.80.0.AND.ABS(X1).GT.8.0.AND.ABS(X1).LT.32.0) THEN
*          ENDIF
 6666     CONTINUE


        ENDIF
  200 CONTINUE
      ELSE IF(MULTI.EQ.0 .AND. MULT2.EQ.1 ) THEN
        X2 = TTR(NC,3,1) - 0.33333*TTR(NC,1,1) - 0.66667*TTR(NC,4,1)
          CALL SHD (IHS(23),0,X2,26.5)                           !SGI
          CALL SHD (IHS(23),0,X2,FLOAT(NSMOD+1)+26.5)            !SGI
          CALL SHD (IHS(23),0,X2,FLOAT(NLAY+4)+26.5)             !SGI
      ELSE IF(MULTI.EQ.0 .AND. MULT3.EQ.1 ) THEN
        X3 = TTR(NC,2,1) - 0.33333*TTR(NC,4,1) - 0.66667*TTR(NC,1,1)
          CALL SHD (IHS(23),0,X3,26.5)                           !SGI
          CALL SHD (IHS(23),0,X3,FLOAT(NSMOD+1)+26.5)            !SGI
          CALL SHD (IHS(23),0,X3,FLOAT(NLAY+4)+26.5)             !SGI
      ENDIF

  101   CONTINUE
 9000 CONTINUE                ! cycle on cells

*       zero arrays ready for next event
        NW2 = 2128
        NW3 = NW2*MAXHIT
        CALL VZERO( TTR(0,1,1),NW3 )
        CALL VZERO( QQR(0,1,1),NW3 )
        CALL VZERO( NHITR(0,1),NW2 )

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.37  by  Stephen Burke
*CMZ :  8.05/00 25/09/96  15.53.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.28  by  Stephen Burke
*CMZU:  7.03/03 30/11/95  15.51.41  by  Stephen Burke
*-- Author :    Stephen Burke   29/11/95
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  This is the top module routine to re-run FTD L4 monitoring at L5
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments.
*
*HTMLO     : Describe the Output of the routine
*
*  No output arguments.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FTMSGI
***************************************************************
*
*     Module to re-run FT L4 monitoring
*
***************************************************************

*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEND.

      PARAMETER (IDNSCL=10)

      CHARACTER*8 VERSQQ

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

*KEEP,VERSQQ.
      VERSQQ = ' 8.07/02'
      IVERSQ =  80702
*KEND.
*     module steering by MODULS
      CALL MODULS('FTDSGI',IVERSQ,'FRREFRPECJKV')

      IF (MOD(NEVENT,IDNSCL).EQ.0 .OR. BEGRUN) CALL FTDSGI

      IF (ENDJOB) THEN
         CALL PRNTF(0,0)
* Output LOOK Histograms...
      ENDIF

      CALL MODULF

      RETURN
      END
*CMZ :  8.05/03 09/10/96  18.10.37  by  Stephen Burke
*CMZ :  8.04/00 23/07/96  15.09.21  by  Stephen Burke
*CMZ :  7.09/03 23/02/96  16.16.06  by  Stephen Burke
*CMZU:  7.03/03 29/11/95  19.43.46  by  Stephen Burke
*-- Author :    Girish D. Patel
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP*    : Describe the Purpose of the routine
*
*  Routine for event rejection on the basis of T0/Zvtx from CJC
*
*HTMLI     : Describe the Input variables to the routine
*
*  No input arguments
*
*HTMLO     : Describe the Output of the routine
*
*  EVT0   CJC EVENT T0       ( = 1000.0 IF NOT FOUND)
*  EVZV   CJC EVENT Z-VERTEX ( = 1000.0 IF NOT FOUND)
*  IRET   RETURN FLAG: 0 - OK OR NO CJC INFO FOR REJECTION
*                                 1 - CJC REJECT ON T0
*                                 2 - CJC REJECT ON Z-VERTEX
*                                 3 - CJC REJECT ON T0 & Z-VERTEX
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FMSLCT(EVT0,EVZV,IRET)
*======================================================================
*     OUTPUT: EVT0   CJC EVENT T0       ( = 1000.0 IF NOT FOUND)
*             EVZV   CJC EVENT Z-VERTEX ( = 1000.0 IF NOT FOUND)
*             IRET   RETURN FLAG: 0 - OK OR NO CJC INFO FOR REJECTION
*                                 1 - CJC REJECT ON T0
*                                 2 - CJC REJECT ON Z-VERTEX
*                                 3 - CJC REJECT ON T0 & Z-VERTEX
*======================================================================
*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,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.
      LOGICAL FIRST
      DIMENSION INFO20(20)
*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.
      DATA FIRST/.TRUE./
*
      IF(FIRST) THEN
        FIRST = .FALSE.
        IQCJCC = NAMIND('CJCC')
        IQCJKV = NAMIND('CJKV')
      ENDIF
*
      INCJCC = IW(IQCJCC)
      INCJKV = IW(IQCJKV)
*
      EVT0 = 1000.0
      IF(INCJCC.NE.0) THEN
        IF(IW(INCJCC+2).NE.0) EVT0 = RBTAB(INCJCC,2,1)
      ENDIF
*
      EVZV = 1000.0
      IF(INCJKV.NE.0) THEN
        NVERT = IW(INCJKV+2)
        IF(NVERT.GT.0) THEN
          DO IV = 1 , NVERT
            IVTYP = IBTAB(INCJKV,9,IV)
            IF(IVTYP.EQ.1) THEN
              EVZV = RBTAB(INCJKV,3,IV)
            ENDIF
          ENDDO
        ENDIF
      ENDIF

      IRET = 0
      IERR = 0

      CALL H1MOR1('T_0 ','CJTREC',NCCRUN,CJCT0,VARI,INFO20,IERR)

      IF (EVT0.NE.1000.0 .AND. CJCT0.GT.0.) THEN
         DT0 = ABS(EVT0 - CJCT0)
         IF (DT0.GT.50.) IRET = IRET + 1
      ENDIF

      INBEAZ = IABS(MDB('BEAZ'))
      ZNOM = 0.
      IF (INBEAZ.GT.0) ZNOM = RW(INBEAZ +2 +2)

      IF(EVZV.LT.ZNOM-100.0) IRET = IRET + 2

      RETURN
      END
*CMZ :  8.06/00 11/11/96  19.07.16  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.20  by  Stephen Burke
*CMZU:  7.02/11 23/10/95  15.38.51  by  Stephen Burke
*CMZU:  7.02/00 11/08/95  10.51.59  by  Stephen Burke
*CMZU:  5.03/00 03/11/94  23.13.56  by  Stephen Burke
*CMZU:  5.01/08 18/02/94  14.51.40  by  Stephen Burke
*CMZU:  4.01/01 10/12/93  15.41.23  by  Stephen Burke
*CMZU:  4.00/08 22/11/93  20.18.16  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.36  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Book LOOK monitoring histograms
*
*HTMLI     : Describe the Input variables to the routine
*
* None
*
*HTMLO     : Describe the Output of the routine
*
* None
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFBKLK
*-----------------------------------------Updates 22/11/93-------
**: FFBKLK.......SB. Changes to monitoring histograms.
*-----------------------------------------Updates 27/07/93-------
**: FFBKLK 30907 SB. Changes to monitoring histograms.
**: FFBKLK 30907 RP. Farm changes.
*-----------------------------------------Updates 02/06/93-------
**: FFBKLK 30907 SB. Correct bad update.
*-----------------------------------------Updates 03/05/93-------
**: FFBKLK 30907 SB. Change range of MC histos.
*-----------------------------------------Updates 03/03/93-------
**: FFBKLK 30907 SB. New monitoring histograms.
*-----------------------------------------Updates 03/03/93-------
**: FFBKLK 30907 SB. New monitoring histograms.
*-----------------------------------------Updates 30/11/92-------
**: FFBKLK 30907 SB. New monitoring histograms.
*-----------------------------------------Updates 06/08/92-------
**: FFBKLK 30205.SB. Remove vertex histos, add xy, change scales.
*-----------------------------------------Updates 24/01/92-------
**: FFBKLK 30205.SB. Add some new histograms, with new numbering.
**: FFBKLK 30205.SB. Change range of histograms for data.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Book LOOK monitoring histograms for the Kalman filter              *
*                                                                    *
**********************************************************************

*KEEP,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*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,FTHIST.
* indices of filter farm histos
      COMMON/FTHIST/IHP(100)
*KEND.

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

*
* Histogram offset (for filter)
*

      IHX=0

*
* Residual histogram range for MC and data
*

      IF (IDATA.NE.0) THEN
C         RANGE = 0.06
         RANGE = 0.12
      ELSE
         RANGE = 0.12
      ENDIF

      CALL BHS(IHX+1,0,60,1.,61.)
      CALL STEXT(IHX+1,4,'Tracks/event')

      CALL BHS(IHX+2,0,37,0.,37.)
      CALL STEXT(IHX+2,4,'Planar hits/track')

      CALL BHS(IHX+3,0,37,0.,37.)
      CALL STEXT(IHX+3,4,'Radial hits/track')

      CALL BHS(IHX+4,0,60,-RANGE,RANGE)
      CALL STEXT(IHX+4,4,'Drift residuals (planars)')
      CALL STEXT(IHX+4,1,'cm')

      CALL BHS(IHX+5,0,60,-RANGE,RANGE)
      CALL STEXT(IHX+5,4,'Drift residuals (radials)')
      CALL STEXT(IHX+5,1,'cm')

      CALL BHS(IHX+6,0,60,-12.0,12.0)
      CALL STEXT(IHX+6,4,'Radius residuals (radials)')
      CALL STEXT(IHX+6,1,'cm')

      CALL BHS(IHX+7,0,64,-3.2,3.2)
      CALL STEXT(IHX+7,4,'Phi')

      CALL BHS(IHX+8,0,60,0.,0.6)
      CALL STEXT(IHX+8,4,'Theta')

      CALL BHS(IHX+9,0,60,-0.3,0.3)
      CALL STEXT(IHX+9,4,'Q/Momentum')
      CALL STEXT(IHX+9,1,'GeV**-1')

      CALL BHS(IHX+10,0,60,-1.0,2.0)
      CALL STEXT(IHX+10,4,'LOG(Momentum)')

      CALL BHS(IHX+11,0,60,15.,75.)
      CALL STEXT(IHX+11,4,'R start')
      CALL STEXT(IHX+11,1,'cm')

      CALL BHS(IHX+12,0,64,-3.2,3.2)
      CALL STEXT(IHX+12,4,'PHI start')

      CALL BHS(IHX+13,0,60,0.,2400.)
      CALL STEXT(IHX+13,4,'Number of planar hits')

      CALL BHS(IHX+14,0,60,0.,2400.)
      CALL STEXT(IHX+14,4,'Number of radial hits')

      CALL BHS(IHX+15,0,50,0.,1.)
      CALL STEXT(IHX+15,4,'Fraction of planar hits used')

      CALL BHS(IHX+16,0,50,0.,1.)
      CALL STEXT(IHX+16,4,'Fraction of radial hits used')

      CALL BHS(IHX+17,0,37,0.,37.)
      CALL STEXT(IHX+17,4,'Planar hits per segment')

      CALL BHS(IHX+18,0,37,0.,37.)
      CALL STEXT(IHX+18,4,'Radial hits per segment')

      CALL BHS(IHX+19,0,64,0.,64.)
      CALL STEXT(IHX+19,4,'Supermodule mask')

C      CALL BHS(IHX+20,0,60,0.,240.)
C      CALL STEXT(IHX+20,4,'Chi-squared between start/end parameters')

      CALL BHS(IHX+20,0,64,0.,64.)
      CALL STEXT(IHX+20,4,'Secondary/tertiary mask')

      CALL BHS(IHX+51,0,60,0.,12.)
      CALL STEXT(IHX+51,4,'Chi-squared/DOF')

      CALL BHS(IHX+52,0,50,0.,1.)
      CALL STEXT(IHX+52,4,'Chi-squared probability')

      CALL BHS(IHX+53,0,60,0.,0.6)
      CALL STEXT(IHX+53,4,'Fractional error on 1/r')

      CALL BHS(IHX+54,0,60,0.,0.012)
      CALL STEXT(IHX+54,4,'Error on theta')

      CALL BHS(IHX+55,0,60,0.,0.15)
      CALL STEXT(IHX+55,4,'Error on xy')
      CALL STEXT(IHX+55,1,'cm')

      CALL BHD(IHX+71,0,32,0.,32.,36,0.,36.)
      CALL STEXT(IHX+71,4,'Planar used hit map (.gt.1 planar segment)')

      CALL BHD(IHX+72,0,48,0.,48.,36,0.,36.)
      CALL STEXT(IHX+72,4,'Radial used hit map (.gt.1 planar segment)')

      CALL BHD(IHX+73,0,32,0.,32.,36,0.,36.)
      CALL STEXT(IHX+73,4,'Planar unused hit map')

      CALL BHD(IHX+74,0,48,0.,48.,36,0.,36.)
      CALL STEXT(IHX+74,4,'Radial unused hit map')

      CALL BHS(IHX+75,0,60,-RANGE,RANGE)
      CALL STEXT(IHX+75,4,'Drift residuals (planars) (>1 seg)')
      CALL STEXT(IHX+75,1,'cm')

      CALL BHS(IHX+76,0,60,-RANGE,RANGE)
      CALL STEXT(IHX+76,4,'Drift residuals (radials) (>1 seg)')
      CALL STEXT(IHX+76,1,'cm')

      CALL BHS(IHX+77,0,60,-3.0,3.0)
      CALL STEXT(IHX+77,4,'Planar drift distance')
      CALL STEXT(IHX+77,1,'cm')

      CALL BHS(IHX+78,0,60,-6.0,6.0)
      CALL STEXT(IHX+78,4,'Radial drift distance')
      CALL STEXT(IHX+78,1,'cm')

      CALL BHS(IHX+79,0,60,-0.15,0.15)
      CALL STEXT(IHX+79,4,'Planar C1 checksum')
      CALL STEXT(IHX+79,1,'cm')

      CALL BHS(IHX+80,0,60,-0.15,0.15)
      CALL STEXT(IHX+80,4,'Planar C2 checksum')
      CALL STEXT(IHX+80,1,'cm')

      CALL BHS(IHX+81,0,60,-0.15,0.15)
      CALL STEXT(IHX+81,4,'Radial C1 checksum')
      CALL STEXT(IHX+81,1,'cm')

      CALL BHS(IHX+82,0,60,-0.15,0.15)
      CALL STEXT(IHX+82,4,'Radial C2 checksum')
      CALL STEXT(IHX+82,1,'cm')

      CALL BHS(IHX+83,0,60,-RANGE,RANGE)
      CALL STEXT(IHX+83,4,'Drift residuals (planars) (<5 mm)')
      CALL STEXT(IHX+83,1,'cm')

      CALL BHS(IHX+84,0,60,-RANGE,RANGE)
      CALL STEXT(IHX+84,4,'Drift residuals (radials) (<5 mm)')
      CALL STEXT(IHX+84,1,'cm')

      CALL BHD(IHX+85,0,32,0.,32.,36,0.,36.)
      CALL STEXT(IHX+85,4,'Planar used hit map')

      CALL BHD(IHX+86,0,48,0.,48.,36,0.,36.)
      CALL STEXT(IHX+86,4,'Radial used hit map')

      CALL BHS(IHX+87,0,60,-0.15,0.15)
      CALL STEXT(IHX+87,4,'Planar C2 checksum (crossing wire plane)')
      CALL STEXT(IHX+87,1,'cm')

      CALL BHS(IHX+88,0,60,-0.15,0.15)
      CALL STEXT(IHX+88,4,'Radial C2 checksum (crossing wire plane)')
      CALL STEXT(IHX+88,1,'cm')

      CALL BHS(IHX+89,0,60,-0.15,0.15)
      CALL STEXT(IHX+89,4,'Planar C2 checksum (crossing cathode)')
      CALL STEXT(IHX+89,1,'cm')

      CALL BHS(IHX+90,0,60,-0.15,0.15)
      CALL STEXT(IHX+90,4,'Radial C2 checksum (crossing cathode)')
      CALL STEXT(IHX+90,1,'cm')

      CALL BHD(IHX+68,0,60,-RANGE,RANGE,50,0.,2500.)
      CALL STEXT(IHX+68,4,'Drift residuals (planars) vs Q')

      CALL BHD(IHX+69,0,60,-RANGE,RANGE,50,0.,2500.)
      CALL STEXT(IHX+69,4,'Drift residuals (radials) vs Q')

      CALL BHS(IHX+70,0,60,-12.0,12.0,50,0.,2500.)
      CALL STEXT(IHX+70,4,'Radius residuals (radials) vs Q')

      IF (IDB.LE.1) RETURN

*
* Next lot for debug only
*

      CALL BHS(IHX+56,0,65,0.,130.)
      CALL STEXT(IHX+56,4,'Track length in z')

      CALL BHS(IHX+57,0,60,0.,300.)
      CALL STEXT(IHX+57,4,'Number of planar segments')

      CALL BHS(IHX+58,0,60,0.,300.)
      CALL STEXT(IHX+58,4,'Number of radial segments')

      CALL BHD(IHX+59,0,40,-80.,80.,40,-80.,80.)
      CALL STEXT(IHX+59,4,'x-y position of starting point')

      CALL BHD(IHX+60,0,40,-80.,80.,40,-80.,80.)
      CALL STEXT(IHX+60,4,'x-y position of end point')

      CALL BHS(IHX+61,0,60,15.,75.)
      CALL STEXT(IHX+61,4,'R end')

      CALL BHS(IHX+62,0,64,-3.2,3.2)
      CALL STEXT(IHX+62,4,'phi end')

      CALL BHD(IHX+63,0,37,0.,37.,37,0.,37.)
      CALL STEXT(IHX+63,4,'Radial hits/track vs planar hits/track')

      CALL BHD(IHX+64,0,50,0.,1.0,73,0.,73.)
      CALL STEXT(IHX+64,4,'Hits/track vs theta')

      CALL BHD(IHX+65,0,60,-RANGE,RANGE,64,0.,64.)
      CALL STEXT(IHX+65,4,'Drift residuals (planars) vs IMAP')

      CALL BHD(IHX+66,0,60,-RANGE,RANGE,64,0.,64.)
      CALL STEXT(IHX+66,4,'Drift residuals (radials) vs IMAP')

      CALL BHS(IHX+67,0,60,-12.0,12.0,64,0.,64.)
      CALL STEXT(IHX+67,4,'Radius residuals (radials) vs IMAP')


      RETURN
      END
*CMZ :  8.07/00 20/11/96  17.33.50  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.20  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.01.42  by  Stephen Burke
*CMZU:  5.01/06 19/08/94  15.21.58  by  Stephen Burke
*CMZU:  5.00/07 25/05/94  10.17.16  by  Unknown
*CMZU:  4.00/08 22/11/93  20.18.16  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.36  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Picks up the output banks from the pattern recognition and passes each
* track in turn to FFKLMN to be fitted.
*
*HTMLI     : Describe the Input variables to the routine
*
* FTUR/FPUR/FPUX/FRUX banks (pattern-recognised tracks and hits)
* FPG1/FRG1 banks (geometry)
* FPLC/FRLC banks (unpacked hits)
*
* and for diagnostics:
*
* FPSG/FRSG banks (segment information)
* FRPX/FRRX banks (MC hit information)
*
*HTMLO     : Describe the Output of the routine
*
* None
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFFIT
*-----------------------------------------Updates 22/11/93-------
**: FFFIT.......SB.  New parameters in FFOUT call.
*-----------------------------------------Updates 27/07/93-------
**: FFFIT  30907 SB. Changes to monitoring histograms.
**: FFFIT  30907 RP. Farm changes.
*-----------------------------------------Updates 03/03/93-------
**: FFFIT  30907 SB. New monitoring histograms.
*-----------------------------------------Updates 06/08/92-------
**: FFFIT  30907 SB. Cosmetic changes.
*-----------------------------------------Updates 03/06/92-------
**: FFFIT  30907 SB. 1-column FTKR banks no longer made.
**: FFFIT  30907 SB. Creation of empty files moved to FFOUT.
**: FFFIT  30907 SB. Small fix to error counting.
*-----------------------------------------Updates 28/04/92-------
**: FFFIT  30907 SB. Make empty FTKX bank if necessary.
*-----------------------------------------Updates 13/02/92-------
**: FFFIT 30205.SB.  ERRLOG error numbers changed.
*-----------------------------------------Updates 24/01/92-------
**: FFFIT 30205.SB.  BKFMT calls moved to FFKAL.
**: FFFIT 30205.SB.  Count failures due to banks missing.
**: FFFIT 30205.SB.  ERRLOG message format changed.
**: FFFIT 30205.SB.  Add #tracks histogram call for empty events
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Find various banks, and Kalman filter the FPATREC tracks           *
*                                                                    *
**********************************************************************

      CHARACTER*4 BANK

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*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,H1EVDT.
      COMMON /H1EVDT/ KEVENT,IDATA,MONTE,LCONF
      INTEGER KEVENT,IDATA,LCONF
      LOGICAL MONTE
*
*  IDATA  type of information (HEAD bank word 6) :
*
*                       0 - real data H1
*                       1 - MC data H1SIM
*                       2 - real data CERN tests
*                       3 - MC data ARCET
*
*  MONTE = .TRUE.   if IDATA=1
*  KEVENT = event processed counter for H1REC
*
*KEEP,FTHIST.
* indices of filter farm histos
      COMMON/FTHIST/IHP(100)
*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.

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

* Look for the track bank
      INFTUR = NLINK('FTUR',0)
      IF (INFTUR.LE.0) THEN
        CALL ERRLOG(301,'S:FFFIT:  Bank FTUR not found; Kalman '
     +  //'filter aborted')
        RETURN
      ENDIF

      NTR = IW(INFTUR+2)
      IF (NTR.GT.500)  THEN
        CALL ERRLOG(302,'S:FFFIT:  Too many tracks; Kalman '
     +  //'filter aborted')
        RETURN
      ENDIF

* Unpacked geometry banks

      INDG1(1) = MLINK(LW,'FPG1',0)
      INDG1(2) = MLINK(LW,'FRG1',0)
      IF (INDG1(1).LE.0 .OR. INDG1(2).LE.0) THEN
        CALL FTCORG
        INDG1(1) = MLINK(LW,'FPG1',0)
        INDG1(2) = MLINK(LW,'FRG1',0)
        IF (INDG1(1).LE.0 .OR. INDG1(2).LE.0) THEN
          CALL ERRLOG(303,'S:FFFIT:  Banks FPG1/FRG1 not found;'//
     +    ' Kalman filter aborted')
          NBFAIL = NBFAIL + NTR
          RETURN
        ENDIF
      ENDIF

* Unpacked digi banks (MUST always exist)
      INDLC(1) = NLINK('FPLC',0)
      IF (INDLC(1).LE.0) THEN
        CALL FPLOCO
        INDLC(1) = NLINK('FPLC',0)
      ENDIF
      INDLC(2) = NLINK('FRLC',0)
      IF (INDLC(2).LE.0) THEN
        CALL FRLOCO
        INDLC(2) = NLINK('FRLC',0)
      ENDIF
      IF (INDLC(1).LE.0 .OR. INDLC(2).LE.0) THEN
        CALL ERRLOG(304,'S:FFFIT:  Banks FPLC/FRLC not found;'//
     +  ' Kalman filter aborted')
        NBFAIL = NBFAIL + NTR
        RETURN
      ENDIF

      INFPSG = NLINK('FPSG',0)
      INFRSG = NLINK('FRSG',0)
      CALL SHS(13,0,FLOAT(IW(INDLC(1)+2)))
      CALL SHS(14,0,FLOAT(IW(INDLC(2)+2)))
      IF (IDB.GT.1) THEN
         IF (INFPSG.GT.0) CALL SHS(57,0,FLOAT(IW(INFPSG+2)))
         IF (INFRSG.GT.0) CALL SHS(58,0,FLOAT(IW(INFRSG+2)))
      ENDIF

* Zero the work bank indices
      INDPUR = 0
      CALL VZERO(INDX,2)
      CALL VZERO(INDRSX,2)

* Get the pointering bank ...
      IF (NLINK('FPUR',0).LE.0) THEN
        CALL ERRLOG(305,'S:FFFIT:  Bank FPUR not found; Kalman '
     +  //'filter aborted')
        NBFAIL = NBFAIL + NTR
        GOTO 9000
      ENDIF
      BANK = 'FPUR'
      CALL BKTOW(IW,BANK,0,IW,INDPUR,*1000)
      IF (IW(INDPUR+2).NE.NTR) THEN
        CALL ERRLOG(306,'S:FFFIT:  Bank FPUR has wrong length; Kalman '
     +  //'filter aborted')
        NBFAIL = NBFAIL + NTR
        GOTO 9000
      ENDIF

* Now get the link banks ...
      IF (NLINK('FPUX',0).LE.0 .OR. NLINK('FRUX',0).LE.0) THEN
        CALL ERRLOG(307,'S:FFFIT:  Banks FPUX or FRUX not found;'//
     +  ' Kalman filter aborted')
        NBFAIL = NBFAIL + NTR
        GOTO 9000
      ENDIF
      BANK = 'FPUX'
      CALL BKTOW(IW,BANK,0,IW,INDX(1),*1000)
      BANK = 'FRUX'
      CALL BKTOW(IW,BANK,0,IW,INDX(2),*1000)

      IF (MONTE .AND. LTRUTH) THEN
* This is for MC data only - true track/digi link banks
        IF (NLINK('FRPX',0).GT.0) THEN
          BANK = 'FRPX'
          CALL BKTOW(IW,BANK,0,IW,INDRSX(1),*1000)
        ENDIF
        IF (NLINK('FRRX',0).GT.0) THEN
          BANK = 'FRRX'
          CALL BKTOW(IW,BANK,0,IW,INDRSX(2),*1000)
        ENDIF
      ENDIF

      CALL HCDIR('//PAWC/'//CFDBG,' ')
      IF (MOD(IHFF,1000).GT.0) CALL HFILL(300,FLOAT(NTR),0.,1.)

      CALL VZERO(ITRTR,2*NTRACK)

* Set the track number to (event no)*1000 + JTR
      ITR = MOD(NEVENT,1000000)*1000

* Fit each track in turn
      DO 100 JTR=1,NTR
* Quick track rejection
         NRHIT = IBTAB(INDPUR,1,JTR)
         NPHIT = IBTAB(INDPUR,3,JTR)
         IF (NRHIT.GE.9 .OR. NPHIT.GE.1) THEN
            CALL FFKLMN(INFTUR,JTR)
         ELSE
            NRFAIL = NRFAIL + 1
         ENDIF
  100 CONTINUE

* Close the output banks
      CALL FFOUT(0,NPS,NRS)

      IF (MOD(IHFF,1000).GT.0) CALL FFTRCH

      GOTO 9000

 1000 CALL ERRLOG(308,'S:FFFIT:  Bank '//BANK//' not found by BKTOW')
      NWFAIL = NWFAIL + NTR

 9000 CONTINUE

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

      CALL WDROP(IW,INDPUR)
      CALL WDROP(IW,INDX(1))
      CALL WDROP(IW,INDX(2))
      CALL WDROP(IW,INDRSX(1))
      CALL WDROP(IW,INDRSX(2))

      RETURN
      END
*CMZ :  8.07/00 26/11/96  16.22.37  by  Stephen Burke
*CMZ :  8.06/00 14/11/96  19.36.00  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.20  by  Stephen Burke
*CMZU:  7.01/00 22/06/95  15.48.12  by  Stephen Burke
*CMZU:  6.00/00 24/11/94  16.27.38  by  Stephen Burke
*CMZU:  5.03/00 25/08/94  19.42.26  by  Stephen Burke
*CMZU:  5.01/06 17/08/94  20.07.35  by  Stephen Burke
*CMZU:  5.00/07 25/05/94  10.17.16  by  Unknown
*CMZU:  4.00/08 22/11/93  20.18.16  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.36  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill the Kalman filter common blocks with information from one
* pattern-recognised track, including fine calibration corrections
* (FFEVT0 and FFCORR), call FKLFIT (or optionally FKLFTR) to fit
* it and FFOUT to write it into the output banks. Some bad-track
* rejection is done here (FFRJCT).
*
*HTMLI     : Describe the Input variables to the routine
*
* INFTUR - track bank (FTUR) index
* JTR    - track number
*
*HTMLO     : Describe the Output of the routine
*
* None
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFKLMN(INFTUR,JTR)
*-----------------------------------------Updates 30/09/94-------
**: FFKLMN.......SB. Corrections moved to FFCORR.
*-----------------------------------------Updates 17/05/94-------
**: FFKLMN 50106 SB. Bug fix for low momentum.
*-----------------------------------------Updates 22/11/93-------
**: FFKLMN.......SB. Farm changes.
**: FFKLMN.......SB. New params in FFOUT call.
**: FFKLMN.......SB. Debug histos only for .GE.2 planar segs.
*-----------------------------------------Updates 27/07/93-------
**: FFKLMN 30907 RP. Farm changes.
*-----------------------------------------Updates 03/05/93-------
**: FFKLMN 30907 SB. Radius ignored if there are planar hits.
*-----------------------------------------Updates 29/10/92-------
**: FFKLMN 30907 SB. Small change in debug steering.
*-----------------------------------------Updates 25/08/92-------
**: FFKLMN 30907 SB. Trap SGI overwrites.
*-----------------------------------------Updates 06/08/92-------
**: FFKLMN 30907 SB. Cosmetic changes; new histograms.
*-----------------------------------------Updates 04/05/92-------
**: FFKLMN 30907 SB. Severity added to ERRLOG messages.
**: FFKLMN 30205.SB. ERRLOG error numbers changed.
*-----------------------------------------Updates 28/01/92-------
**: FFKLMN 30205.SB. Make efficiency histograms conditional on PMCUT
*-----------------------------------------Updates 24/01/92-------
**: FFKLMN 30205.SB. BKFMT calls moved to FFKAL.
**: FFKLMN 30205.SB. Check the drift sign in debug mode.
**: FFKLMN 30205.SB. Count failed tracks.
**: FFKLMN 30205.SB. Starting errors must be .LE. errors in FTUR bank.
**: FFKLMN 30205.SB. ERRLOG message format changed.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Read the FPATREC output banks, pick up the digi list and fit       *
*                                                                    *
* INFTUR is the track bank index and JTR is the track number         *
*                                                                    *
**********************************************************************

      LOGICAL FFRJCT,LFAILP,LFAILR
      DOUBLE PRECISION SSTART(5),CSTART(5,5),ZSTART
      DOUBLE PRECISION DZ,ZTRAN,SS(5),STRAN(5),DTRAN(5,5),RES(2),CHISQ
      DIMENSION VXYZ(3)
      SAVE JMAX

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKPROJ.
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*KEEP,FKINT.
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FTANG.
*     Statement functions for track angle corrections...
*     (assumes COMMON FRLORA present)
      REAL DRIFT
      FTANGR(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGR, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*
      FTANGP(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGP, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

      DATA JMAX/0/

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

* Set up the Kalman filter arrays
      CALL FFFILL(JTR,LFAILP,LFAILR)

      IF (LFAILP) CALL ERRLOG(321,'S:FFKLMN: Bad planar digi pointers')
      IF (LFAILR) CALL ERRLOG(322,'S:FFKLMN: Bad radial digi pointers')
      IF (LFAILP .OR. LFAILR) THEN
         NBFAIL = NBFAIL + 1
         RETURN
      ENDIF

* Get the starting vector into the KF format
      CALL FKETOI(RW(INDCR(INFTUR,1,JTR)),SSTART,CSTART)
      ZSTART = RBTAB(INFTUR,6,JTR)
      CALL FKNORM(SSTART,IFAIL)
      IF (IFAIL.GE.100) THEN
         NTFAIL = NTFAIL + 1
         RETURN
      ENDIF

* Initial veto for bad tracks
      IF (FFRJCT(SSTART(3))) RETURN

* Find the true track
      JDIGP = IBTAB(INDPUR,4,JTR)
      JDIGR = IBTAB(INDPUR,2,JTR)
      IF (LTRUTH) CALL FFHUNT(JDIGP,JDIGR,JMAX)

* Histogram the patrec efficiencies
      IF ((PMCUT.LE.0. .OR. ABS(SSTART(3)).LE.1./PMCUT) .AND.
     &   MOD(IHFF,1000).GT.0 .AND. JMAX.GT.0)
     &      CALL FFCHEK(JDIGP,JDIGR,JMAX)

* Increment track number
      ITR = ITR + 1

* Corrections for real data only
      IDATA = JRDATA('RUNTYPE',STATUS)
      IF (IDATA.EQ.0) THEN
* Event T0
         CALL FFEVT0(DEVT0,ZNOM,VXYZ)
         ZTRAN = ZSTART
         CALL UCOPY(SSTART,SS,10)
         DO 100 JPL=1,JPLMAX
            IF (.NOT.LMES(JPL)) GOTO 100
            DZ = ZPL(JPL) - ZTRAN
            CALL FFTRF(DZ,ZTRAN,SS,STRAN,BZ)
* Track angle, time-of-flight, propagation time
            CALL FFCORR(JPL,STRAN,ZNOM,VXYZ,DEVT0,BZ,DCORR)
            IF (IDIGI(JPL).LT.0) DCORR = -DCORR
            WMES(1,JPL) = WMES(1,JPL) + DCORR
            ZTRAN = ZPL(JPL)
            CALL UCOPY(STRAN,SS,10)
 100     CONTINUE
      ENDIF

* Set up the starting vector
      CALL FFSTART(SSTART,CSTART,ZSTART)

* LFIRST and LTRUE can be in /H1WORK/, so must be set here
      LFIRST = .TRUE.
      LTRUE  = .FALSE.

* Fill the TRUE array if needed
      IF (JMAX.GT.0) CALL FFTRUE(JMAX)

* Kalman filter
      IF (LRISV) THEN
         CALL FKLFTR(IFAIL)
      ELSE
         CALL FKLFIT(IFAIL)
      ENDIF
      IF (IFAIL.GE.100) THEN
         CALL ERRLOG(324,'S:FFKLMN: Fatal error in track fit')
         NFFAIL = NFFAIL + 1
         RETURN
      ENDIF

* Add to the output banks
      CALL FFOUT(JTR,NPS,NRS)

      IF (PMCUT.LE.0. .OR. ABS(SSMT(3,JLAST)).LE.1./PMCUT) THEN
* Analyse the results
         IF (IHFK.GT.0 .AND. NPS.GT.1) CALL FKANAL(0,RES,CHISQ,NPS,NRS)
         CALL HCDIR('//PAWC/'//CFDBG,' ')
      ENDIF

      RETURN
      END
*CMZ :  8.07/00 20/11/96  21.24.05  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.38  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.20  by  Stephen Burke
*CMZU:  7.02/00 11/08/95  10.55.47  by  Stephen Burke
*CMZU:  7.01/00 19/06/95  12.44.38  by  Stephen Burke
*CMZU:  7.00/04 11/05/95  15.19.05  by  Stephen Burke
*CMZU:  6.00/00 29/11/94  21.01.38  by  Stephen Burke
*CMZU:  5.03/00 03/11/94  23.14.11  by  Stephen Burke
*CMZU:  5.01/08 18/02/94  15.06.36  by  Stephen Burke
*CMZU:  4.01/01 10/12/93  15.41.24  by  Stephen Burke
*CMZU:  4.00/08 22/11/93  20.41.13  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.36  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Add the information from a fitted track to the output banks (JTR
* non-zero) or finish the banks and tidy up (JTR zero). Some tracks
* are rejected here (chi-squared cut and FFKILL).
*
* Also fill most of the monitoring histograms in area FTREC 0.
*
*HTMLI     : Describe the Input variables to the routine
*
* JTR - track number in the FTUR (pattern-recognised track) bank
*
* Various Kalman filter common blocks with information on the fitted
* track (FKFLAG, FKCONS, FKMEAS, FKSMTH, FKRSID).
*
*HTMLO     : Describe the Output of the routine
*
* FTKR/FTPR/FTPX/FTRX banks (main FTREC output on E list)
*
* FTKX bank giving relations between FTKR and FTUR tracks (goes on R list)
*
* NPS, NRS - number of planar/radial segments (used for diagnostics)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFOUT(JTR,NPS,NRS)
*-----------------------------------------Updates 22/11/93-------
**: FFOUT.......SB.  New parameters in call.
**: FFOUT.......SB.  New monitoring histograms.
**: FFOUT.......SB.  Fix FTPR bug.
*-----------------------------------------Updates 27/07/93-------
**: FFOUT  30907 SB. Changes to monitoring histograms.
**: FFOUT  30907 RP. Farm changes.
*-----------------------------------------Updates 03/03/93-------
**: FFOUT  30907 SB. Module mask in LS 6 bits of word 20 of FTKR.
**: FFOUT  30907 SB. New monitoring histograms.
*-----------------------------------------Updates 30/11/92-------
**: FFOUT  30907 SB. Call new track rejection routine FFKILL.
**: FFOUT  30907 SB. New monitoring histograms.
*-----------------------------------------Updates 06/08/92-------
**: FFOUT  30907 SB. New monitoring histograms.
*-----------------------------------------Updates 03/06/92-------
**: FFOUT  30907 SB. Empty banks made here instead of in FFFIT.
**: FFOUT  30907 SB. Protect against large chi-squared.
**: FFOUT  30907 SB. Vertex fit stuff removed.
*-----------------------------------------Updates 02/06/92-------
**: FFOUT  30907 SB. Protect against divide by 0.
*-----------------------------------------Updates 28/04/92-------
**: FFOUT  30907 SB. FTKX now added to E-list in FTREC for debug.
*-----------------------------------------Updates 13/02/92-------
**: FFOUT 30205.SB.  Bug fix (NDF now correct if LRISV is .TRUE.)
**: FFOUT 30205.SB.  ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFOUT 30205.SB.  Remove unused FKMEAS sequence.
*-----------------------------------------Updates 24/01/92-------
**: FFOUT 30205.SB.  Count failures.
**: FFOUT 30205.SB.  Better handling of errors with missing banks.
**: FFOUT 30205.SB.  ERRLOG message format changed.
**: FFOUT 30205.SB.  Add some new histograms, with new numbering.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Create output banks for the Kalman filtered tracks                 *
*                                                                    *
**********************************************************************

      LOGICAL BKOPEN,BKERR,FFKILL,LGOOD
      SAVE BKOPEN,BKERR,JROW,NFRPE,NFRRE,NPHIT,NRHIT

      DIMENSION VEC(21),IVEC(21),IFP(2),NP(2),NHPS(3,2),NHPO(3,3)
      EQUIVALENCE (VEC,IVEC)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FTHIST.
* indices of filter farm histos
      COMMON/FTHIST/IHP(100)
*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*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/
*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,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*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.

      DATA BKOPEN/.TRUE./,BKERR/.FALSE./

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

      NPS = 0
      NRS = 0

* If work bank creation failed we junk all the tracks for this event
      IF (BKERR) THEN
         IF (JTR.LE.0) BKERR  = .FALSE.
         RETURN
      ENDIF

      IF (BKOPEN) THEN
         JROW     = 1
* Zero work bank indices
         INDTPR   = 0
         INDKTX   = 0
         INDKX(1) = 0
         INDKX(2) = 0
* Work banks for pointer lists ...
         NFRPE = IW(INDLC(1)+2)
         CALL WBANK(IW,INDKX(1),2*NFRPE+2,*2000)
         CALL VZERO(IW(INDKX(1)+1),2*NFRPE+2)
         IW(INDKX(1)+1) = 2
         IW(INDKX(1)+2) = NFRPE
         NFRRE = IW(INDLC(2)+2)
         CALL WBANK(IW,INDKX(2),2*NFRRE+2,*2000)
         CALL VZERO(IW(INDKX(2)+1),2*NFRRE+2)
         IW(INDKX(2)+1) = 2
         IW(INDKX(2)+2) = NFRRE
         BKOPEN = .FALSE.
         NTGOOD = 0
         NPHIT  = 0
         NRHIT  = 0
      ENDIF

      IF (JTR.LE.0) THEN
* Close banks ...
         BKOPEN = .TRUE.
         IF (JROW.GT.1) THEN
            INDKTR = IADFIN('FTKR',0)
            INFTKX = IADFIN('FTKX',0)
            INDTPR = IADFIN('FTPR',0)
            IF (INDKTR.LE.0 .OR. INFTKX.LE.0 .OR.
     &          INDTPR.LE.0) GOTO 2000
         ELSE
* Banks are made even if there are no tracks
            INDKTR = NBANK('FTKR',0,2)
            IF (INDKTR.LE.0) GOTO 2000
            IW(INDKTR+1) = 21
            IW(INDKTR+2) = 0
            CALL WBANK(IW,INDKTX,2,*2000)
            IW(INDKTX+1) = 1
            IW(INDKTX+2) = 0
            CALL BKFRW(IW,'FTKX',0,IW,INDKTX,*2000)
            CALL WBANK(IW,INDTPR,2,*2000)
            IW(INDTPR+1) = 4
            IW(INDTPR+2) = 0
            CALL BKFRW(IW,'FTPR',0,IW,INDTPR,*2000)
         ENDIF
* Pack work banks into named banks...
         CALL BKFRW(IW,'FTPX',0,IW,INDKX(1),*2000)
         CALL BKFRW(IW,'FTRX',0,IW,INDKX(2),*2000)
* Add banks to the E list ...
         CALL BLIST(IW,'E+','FTKR')
         CALL BLIST(IW,'E+','FTPR')
         CALL BLIST(IW,'E+','FTPX')
         CALL BLIST(IW,'E+','FTRX')
* Fill monitoring histograms
         CALL SHS(1,0,FLOAT(NTGOOD))
         IF (NTGOOD.GT.0) THEN
            IF (NFRPE.GT.0) CALL SHS(15,0,FLOAT(NPHIT)/FLOAT(NFRPE))
            IF (NFRRE.GT.0) CALL SHS(16,0,FLOAT(NRHIT)/FLOAT(NFRRE))
         ENDIF
         IF (MOD(NEVENT,10).NE.0) GOTO 9000
         DO 50 JDIG=1,IW(INDKX(1)+2)
            ICELL = IBTAB(INDLC(1),1,JDIG)
            IF (IBTAB(INDKX(1),1,JDIG).NE.0) GOTO 50
            CALL SHD(73,0,IPWCL(ICELL)+0.5,IPIOSW(ICELL)-0.5)
 50      CONTINUE
         DO 60 JDIG=1,IW(INDKX(2)+2)
            ICELL = IBTAB(INDLC(2),1,JDIG)
            IF (IBTAB(INDKX(2),1,JDIG).NE.0) GOTO 60
            IF (IAND(IBTAB(INDLC(2),6,JDIG),1).EQ.0) THEN
               CALL SHD(74,0,IRWPL(ICELL)+0.5,IRIOSW(ICELL)-0.5)
            ELSE
               CALL SHD(74,0,IRWMI(ICELL)+0.5,IRIOSW(ICELL)-0.5)
            ENDIF
 60      CONTINUE
         GOTO 9000
      ENDIF

*
* Loop over planes to find chisq and first digi
*

      CHISQ = 0.
      NDF   = 0
      J1    = 0
      IMAP  = 0
      CALL VZERO(IFP,2)
      CALL VZERO(NP,2)
      CALL VZERO(NHPS,6)
      CALL VZERO(NHPO,9)
      DO 100 JPL=1,JPLMAX
         IF (LMES(JPL)) THEN
            ISMOD = (JPLFT(JPL) + 23)/24
            IORI  = MOD((JPLFT(JPL)-1)/4,3) + 1
            CALL SBIT1(IMAP,ISMOD+3*(2-IRP(JPL)))
            NHPS(ISMOD,IRP(JPL)) = NHPS(ISMOD,IRP(JPL)) + 1
            IF (IRP(JPL).EQ.1)
     &         NHPO(IORI,ISMOD) = NHPO(IORI,ISMOD) + 1
            CHISQ = CHISQ + CHISMT(JPL)
            NDF   = NDF   + MES(JPL)
            NP(IRP(JPL)) = NP(IRP(JPL)) + 1
            IF (J1.EQ.0) J1 = JPL
            J2 = JPL
            IF (IFP(IRP(JPL)).EQ.0 .AND.
     &          IBTAB(INDKX(IRP(JPL)),1,ABS(IDIGI(JPL))).EQ.0)
     &             IFP(IRP(JPL)) = ABS(IDIGI(JPL))
         ENDIF
 100  CONTINUE

* Get secondary/tertiary segment flag from NHPO
      IMAPST = 0
      IMAPRR = 0
      DO 400 JSM=1,3
         IF (NHPS(JSM,1).GT.0) THEN
            DO 450 JORI=1,3
               IF (NHPO(JORI,JSM).EQ.0) THEN
                  CALL SBIT1(IMAPST,JSM+9)
               ELSEIF (NHPO(JORI,JSM).LT.3) THEN
                  CALL SBIT1(IMAPST,JSM+6)
               ENDIF
 450        CONTINUE
         ENDIF
         IQRR = (NHPS(JSM,2) - 4)/2
         IF (IQRR.LT.0) IQRR = 0
         IF (IQRR.GT.3) IQRR = 3
         IMAPRR = IMAPRR + IQRR*(4**(JSM+2))
 400  CONTINUE

      IF (LRISV) NDF = NDF - 5

      IF (NP(1)+NP(2).LE.0) THEN
         CALL ERRLOG(331,'W:FFOUT:  Track with no measurements')
         NFFAIL = NFFAIL + 1
         RETURN
      ENDIF

* PROB isn't very accurate for small probabilities
      IF (CHISQ/FLOAT(NDF).LT.20.) THEN
         CHP = PROB(CHISQ,NDF)
      ELSE
         CHP = 1.0E-10
      ENDIF
      IF (CHP.LT.CHPCUT .OR. CHISQ.GT.100.*FLOAT(NDF)) THEN
         NXFAIL = NXFAIL + 1
         RETURN
      ENDIF

* Kill off bad tracks
      IF (FFKILL(J1,J2)) RETURN

* Convert start vector to output format ...
      CALL FKITOE(ZPL(J1),SSMT(1,J1),CSMT(1,1,J1),VEC)

*
* Fill monitoring histograms
*

      JPS = IMAP/8
      JRS = IMAP - JPS*8
      NPRSEG(JPS,JRS) = NPRSEG(JPS,JRS) + 1
      JP3 = IMAPST/512
      JP2 = IMAPST/64 - JP3*8
      N23SEG(JP2,JP3) = N23SEG(JP2,JP3) + 1
      NPS   = JBIT(IMAP,4) + JBIT(IMAP,5) + JBIT(IMAP,6)
      NRS   = JBIT(IMAP,1) + JBIT(IMAP,2) + JBIT(IMAP,3)
      IF (NPS.GE.1 .OR. NRS.GE.2) THEN
         LGOOD = .TRUE.
         NTGOOD = NTGOOD + 1
      ELSE
         LGOOD = .FALSE.
         GOTO 1000
      ENDIF
      NPHIT = NPHIT + NP(1)
      NRHIT = NRHIT + NP(2)

      CALL SHS(2,0,FLOAT(NP(1)))
      CALL SHS(3,0,FLOAT(NP(2)))
      IF (IDB.GT.1) CALL SHD(64,0,VEC(3),FLOAT(NP(1)+NP(2)))
      CALL FFHTHS(J1,J2,NPS,IMAP)
      CALL SHS(7,0,VEC(2))
      CALL SHS(8,0,VEC(3))
      CALL SHS(9,0,SNGL(SSMT(3,J2)))
      IF (SSMT(3,J2).NE.0.0D0) THEN
         CALL SHS(10,0,-LOG10(ABS(SNGL(SSMT(3,J2)))))
      ELSE
         CALL SHS(10,0,3.)
      ENDIF
      CALL SHS(11,0,SQRT(VEC(4)**2+VEC(5)**2))
      CALL SHS(12,0,ATAN2(VEC(5),VEC(4)))
      IF (NHPS(1,1).GT.0) CALL SHS(17,0,FLOAT(NHPS(1,1)))
      IF (NHPS(2,1).GT.0) CALL SHS(17,0,FLOAT(NHPS(2,1))+12)
      IF (NHPS(3,1).GT.0) CALL SHS(17,0,FLOAT(NHPS(3,1))+24)
      IF (NHPS(1,2).GT.0) CALL SHS(18,0,FLOAT(NHPS(1,2)))
      IF (NHPS(2,2).GT.0) CALL SHS(18,0,FLOAT(NHPS(2,2))+12)
      IF (NHPS(3,2).GT.0) CALL SHS(18,0,FLOAT(NHPS(3,2))+24)
      CALL SHS(19,0,FLOAT(IMAP))
      CALL SHS(20,0,FLOAT(IMAPST/64))
      CALL SHS(51,0,CHISQ/FLOAT(NDF))
      CALL SHS(52,0,CHP)
      IF (VEC(1).NE.0.0) THEN
         CALL SHS(53,0,VEC(8)/ABS(VEC(1)))
      ELSE
         CALL SHS(53,0,0.)
      ENDIF
      CALL SHS(54,0,VEC(10))
      CALL SHS(55,0,SQRT(ABS(VEC(11)**2+VEC(12)**2)))
      IF (IDB.GT.1) THEN
         CALL SHS(56,0,SNGL(ZPL(J2))-VEC(6))
         CALL SHD(59,0,VEC(4),VEC(5))
         CALL SHD(63,0,FLOAT(NP(1)),FLOAT(NP(2)))
      ENDIF


 1000 CONTINUE

* ... fill in the other entries ...
      IVEC(17) = NDF
      VEC(18)  = CHISQ
      IVEC(19) = 2*JROW
      IVEC(20) = 65536*(NP(1) + 256*NP(2)) + IMAPST + IMAP
      IVEC(21) = JROW

* ... and fill another row in the banks
      INDKTR = IADROW('FTKR',0,21,VEC)
      INFTKX = IADROW('FTKX',0,1,JTR)

* Convert end vector to output format ...
      CALL FKITOE(ZPL(J2),SSMT(1,J2),CSMT(1,1,J2),VEC)

      IF (LGOOD) THEN
         IF (IDB.GT.1) THEN
            CALL SHD(60,0,VEC(4),VEC(5))
            CALL SHS(61,0,SQRT(VEC(4)**2+VEC(5)**2))
            CALL SHS(62,0,ATAN2(VEC(5),VEC(4)))
         ENDIF
      ENDIF

      IVEC(19) = -1
      IVEC(20) = 65536*(NP(1) + 256*NP(2)) + IMAPRR + IMAP
      INDKTR = IADROW('FTKR',0,21,VEC)

      JROW = JROW + 1

* Fill FTPR row
      IVEC(1) = NP(2)
      IVEC(2) = IFP(2)
      IVEC(3) = NP(1)
      IVEC(4) = IFP(1)

*  Now fill appropriate rows of FTRX and FTPX banks
      DO 200 JPL=JPLMAX,1,-1
         IF (LMES(JPL)) THEN
            JDIG = ABS(IDIGI(JPL))
            IF (IBTAB(INDKX(IRP(JPL)),1,JDIG).NE.0) THEN
               IVEC(5-2*IRP(JPL)) = IVEC(5-2*IRP(JPL)) - 1
               CALL ERRLOG(332,'W:FFOUT:  Digi used twice')
            ELSE
               IF (IDIGI(JPL).GE.0) THEN
                  IW(INDCR(INDKX(IRP(JPL)),2,JDIG)) = 0
               ELSE
                  IW(INDCR(INDKX(IRP(JPL)),2,JDIG)) = 1
               ENDIF
               IW(INDCR(INDKX(IRP(JPL)),1,JDIG)) = IFP(IRP(JPL))
               IFP(IRP(JPL)) = JDIG
               ICELL = IBTAB(INDLC(IRP(JPL)),1,JDIG)
               IF (LGOOD .AND. MOD(NEVENT,10).EQ.0) THEN
                  IF (NPS.GE.2) THEN
                    IF (IRP(JPL).EQ.1) THEN
                      CALL SHD(71,0,IPWCL(ICELL)+0.5,IPIOSW(ICELL)-0.5)
                    ELSEIF (IAND(IBTAB(INDLC(2),6,JDIG),1).EQ.0) THEN
                      CALL SHD(72,0,IRWPL(ICELL)+0.5,IRIOSW(ICELL)-0.5)
                    ELSE
                      CALL SHD(72,0,IRWMI(ICELL)+0.5,IRIOSW(ICELL)-0.5)
                    ENDIF
                  ENDIF
                  IF (IRP(JPL).EQ.1) THEN
                     CALL SHD(85,0,IPWCL(ICELL)+0.5,IPIOSW(ICELL)-0.5)
                  ELSEIF (IAND(IBTAB(INDLC(2),6,JDIG),1).EQ.0) THEN
                     CALL SHD(86,0,IRWPL(ICELL)+0.5,IRIOSW(ICELL)-0.5)
                  ELSE
                     CALL SHD(86,0,IRWMI(ICELL)+0.5,IRIOSW(ICELL)-0.5)
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
 200  CONTINUE

* Fill pointering bank
      INDTPR  = IADROW('FTPR',0,4,IVEC)

      RETURN

 2000 CONTINUE

      CALL ERRLOG(333,'S:FFOUT:  Error while using work bank')

      INFTUR = NLINK('FTUR',0)
      IF (INFTUR.GT.0) NWFAIL = NWFAIL + IW(INFTUR+2)

      IF (JTR.LE.0) THEN
* If we run out of space all banks are deleted
         IF (NLINK('FTKR',0).GT.0) CALL NDROP('FTKR',0)
         IF (NLINK('FTKX',0).GT.0) CALL NDROP('FTKX',0)
         IF (NLINK('FTPR',0).GT.0) CALL NDROP('FTPR',0)
         IF (NLINK('FTPX',0).GT.0) CALL NDROP('FTPX',0)
         IF (NLINK('FTRX',0).GT.0) CALL NDROP('FTRX',0)
      ELSE
* Set flag to ignore all tracks
         BKERR = .TRUE.
      ENDIF
 9000 CONTINUE
*
* Drop all work banks
*
      IF (JROW.LE.1) THEN
         CALL WDROP(IW,INDTPR)
         CALL WDROP(IW,INDKTX)
      ENDIF

      CALL WDROP(IW,INDKX(1))
      CALL WDROP(IW,INDKX(2))

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  3.04/04 06/08/92  15.47.27  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Calculate a planar cell number from an x/y position. Returns
* ICELL = -1 if JFT is invalid.
*
*HTMLI     : Describe the Input variables to the routine
*
* XY     - (x,y) coordinates (REAL*8)
* JFT    - z plane number (1 to 72)
*
* FGAP bank (planar geometry)
*
*HTMLO     : Describe the Output of the routine
*
* ICELL  - cell number
* DRIFT  - drift distance of point from wire (signed)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFPCEL(XY,JFT,ICELL,DRIFT)
*-----------------------------------------Updates 13/03/92-------
**: FFPCEL 30205.SB. Only call UGTBNK when run number changes
*-----------------------------------------Updates 13/02/92-------
**: FFPCEL 30205.SB. ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFPCEL 30205.SB. Remove unused FKMEAS sequence.
*-----------------------------------------Updates 24/01/92-------
**: FFPCEL 30205.SB. ERRLOG message format changed.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Calculate a planar cell number from a position                     *
*                                                                    *
* Returns ICELL = -1 if JFT is invalid                               *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION XY(2),PHI
      DIMENSION FGAP(75)
      SAVE FGAP,IRUN

*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,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

      DATA IRUN/-999999/

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

      ICELL = -1

      IF (IRUN.NE.NCCRUN) THEN
* Get geometry bank
         CALL UGTBNK('FGAP',INFGAP)
         IF (INFGAP.LE.0) THEN
            CALL ERRLOG(341,'S:FFPCEL: Bank FGAP not found')
            RETURN
         ENDIF
         IRUN = NCCRUN
         CALL UCOPY(RW(INFGAP+1),FGAP,75)
      ENDIF

      IF (JFT.GE.1 .AND. JFT.LE.12) THEN
         KMOD = 0
      ELSEIF (JFT.GE.25 .AND. JFT.LE.36) THEN
         KMOD = 1
      ELSEIF (JFT.GE.49 .AND. JFT.LE.60) THEN
         KMOD = 2
      ELSE
         RETURN
      ENDIF

* Orientation and wire number
      KORI  = MOD(JFT-1,12)/4
      KWIRE = MOD(JFT-1,4)

* NB The format of FGAP is hard-coded here
      W0     = FGAP(7)
      DW     = FGAP(8)
      INDMOD = 31 + 5*(3*KMOD + KORI)
      PHI    = FGAP(INDMOD+3) - PIBY2
      CPHI   = DCOS(PHI)
      SPHI   = DSIN(PHI)
      STAGG  = FGAP(INDMOD+4)

* Cell number and drift (NB check stagger!)
      W     = CPHI*XY(2) - SPHI*XY(1)
      WCELL = W - W0 + DW/2. - STAGG*(-1)**KWIRE
      KCELL = WCELL/DW
      IF (KCELL.LT.0 .OR. KCELL.GT.25) RETURN
      DRIFT = WCELL - KCELL*DW - DW/2.

* Adjust cell number for split cells
      IF (KCELL.GE.10 .AND. KCELL.LE.15) THEN
         R = CPHI*XY(1) + SPHI*XY(2)
         IF (R.LT.0.) KCELL = KCELL + 6
      ELSEIF (KCELL.GT.15) THEN
         KCELL = KCELL + 6
      ENDIF

* Cell number
      ICELL = 384*KMOD + 128*KORI + 4*KCELL + KWIRE

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.37  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill the Kalman filter arrays with information for one planar hit.
*
*HTMLI     : Describe the Input variables to the routine
*
* JDIG - hit number in FRPE/FPLC bank
*
* FPUX bank (hit information from pattern recognition)
* FPLC bank (unpacked planar hit information)
* FPG1 bank (planar geometry information)
*
*HTMLO     : Describe the Output of the routine
*
* Hit information in Kalman filter common blocks (FKFLAG, FKMEAS, FKCONS)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFPLAN(JDIG)
*-----------------------------------------Updates 27/07/93-------
**: FFPLAN 30907 RP. Farm changes.
*-----------------------------------------Updates 13/02/92-------
**: FFPLAN 30205.SB. ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFPLAN 30205.SB. Remove unused FKMEAS sequence.
*-----------------------------------------Updates 24/01/92-------
**: FFPLAN 30205.SB. ERRLOG message format changed.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Fill the Kalman filter arrays from the planar DIGI bank            *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION PHI

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

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

      ICELL = IBTAB(INDLC(1),1,JDIG)
      JPL   = JFTPL(IPSBW(ICELL))

      IF (JPL.LE.0) THEN
         CALL ERRLOG(351,'F:FFPLAN: Planar digi on mapped-out plane')
         RETURN
      ENDIF

* Remember the digi pointer and drift sign
      IDSIGN = JBIT(IBTAB(INDX(1),2,JDIG),1)
      IF (IDSIGN.EQ.0) THEN
         IDIGI(JPL) = JDIG
*         DD = RBTAB(INDLC(1),2,JDIG)
* Use assymetric drift
         DD = RBTAB(INDLC(1),6,JDIG)
      ELSE
         IDIGI(JPL) = -JDIG
*         DD = -RBTAB(INDLC(1),2,JDIG)
* Use assymetric drift
         DD = -RBTAB(INDLC(1),7,JDIG)
      ENDIF

* Measured position and error
*      WMES(1,JPL)   = DD + SBTAB(INDG1(1),3,ICELL+1)
* Use geometric stagger
      WMES(1,JPL)   = DD + SBTAB(INDG1(1),5,ICELL+1)
      CMES(1,1,JPL) = RBTAB(INDLC(1),3,JDIG)**2

      ZPL(JPL)      = SBTAB(INDG1(1),4,ICELL+1)
      MES(JPL)      = 1

      PHI           = SBTAB(INDG1(1),2,ICELL+1)
      HMES(1,1,JPL) = -DSIN(PHI)
      HMES(2,1,JPL) =  DCOS(PHI)
      HMES(1,2,JPL) =  HMES(2,1,JPL)
      HMES(2,2,JPL) = -HMES(1,1,JPL)

      LMES(JPL)     = .TRUE.

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.37  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill the Kalman filter arrays with information for one radial hit.
* Radius information is only used if NPLAN is zero.
*
*HTMLI     : Describe the Input variables to the routine
*
* JDIG  - hit number in FRRE/FRLC bank
* NPLAN - number of planar hits
*
* FRUX bank (hit information from pattern recognition)
* FRLC bank (unpacked planar hit information)
* FRG1 bank (planar geometry information)
*
*HTMLO     : Describe the Output of the routine
*
* Hit information in Kalman filter common blocks (FKFLAG, FKMEAS, FKCONS)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFRAD(JDIG,NPLAN)
*-----------------------------------------Updates 27/07/93-------
**: FFRAD  30907 RP. Farm changes.
*-----------------------------------------Updates 03/05/93-------
**: FFRAD 30907 SB.  Radius ignored if there are planar hits.
*-----------------------------------------Updates 06/08/92-------
**: FFRAD 30907 SB.  Fix bad radius bug.
*-----------------------------------------Updates 13/02/92-------
**: FFRAD 30205.SB.  ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFRAD 30205.SB.  Remove unused FKMEAS sequence.
*-----------------------------------------Updates 24/01/92-------
**: FFRAD 30205.SB.  ERRLOG message format changed.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Fill the Kalman filter arrays from the radial DIGI bank            *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION PHI

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

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

      ICELL = IBTAB(INDLC(2),1,JDIG)
      JPL   = JFTPL(IRSBW(ICELL))

      IF (JPL.LE.0) THEN
         CALL ERRLOG(361,'F:FFRAD:  Radial digi on mapped-out plane')
         RETURN
      ENDIF

* Remember the digi pointer and drift sign
      IDSIGN = JBIT(IBTAB(INDX(2),2,JDIG),1)
      IF (IDSIGN.EQ.0) THEN
         DSIGN = 1.
         IDIGI(JPL) = JDIG
*         DD = RBTAB(INDLC(2),2,JDIG)
* Use assymetric drift
         DD = RBTAB(INDLC(2),9,JDIG)
      ELSE
         DSIGN = -1.
         IDIGI(JPL) = -JDIG
*         DD = -RBTAB(INDLC(2),2,JDIG)
* Use assymetric drift
         DD = -RBTAB(INDLC(2),10,JDIG)
      ENDIF

      RR = RBTAB(INDLC(2),4,JDIG)

      KWED = JBIT(IBTAB(INDLC(2),6,JDIG),1)

* Measured position and error
*      WMES(1,JPL)   = DD + SBTAB(INDG1(2),3+3*KWED,ICELL+1)
* Use geometric stagger (3 & 6 -> 8 & 9)
      WMES(1,JPL)   = DD + SBTAB(INDG1(2),8+KWED,ICELL+1)
      WMES(2,JPL)   = RR + FLOREN(RR,ABS(DD),DSIGN)
      CMES(1,1,JPL) = RBTAB(INDLC(2),3,JDIG)**2
      CMES(2,2,JPL) = RBTAB(INDLC(2),5,JDIG)**2
      CMES(1,2,JPL) = 0.
      CMES(2,1,JPL) = 0.

      ZPL(JPL) = SBTAB(INDG1(2),4+3*KWED,ICELL+1)
      IF (NPLAN.LE.0) THEN
         MES(JPL) = 2 - JBIT(IBTAB(INDLC(2),6,JDIG),2)
      ELSE
         MES(JPL) = 1
      ENDIF

      PHI           =  SBTAB(INDG1(2),2+3*KWED,ICELL+1)
      HMES(1,1,JPL) = -DSIN(PHI)
      HMES(2,1,JPL) =  DCOS(PHI)
      HMES(1,2,JPL) =  HMES(2,1,JPL)
      HMES(2,2,JPL) = -HMES(1,1,JPL)

      LMES(JPL)     = .TRUE.

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  7.03/03 29/11/95  18.46.31  by  Stephen Burke
*CMZU:  3.04/04 06/08/92  15.47.27  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Calculate a radial cell number from an x/y position. Returns
* ICELL = -1 if JFT is invalid.
*
*HTMLI     : Describe the Input variables to the routine
*
* XY     - (x,y) coordinates (REAL*8)
* JFT    - z plane number (1 to 72)
*
* FGAR bank (radial geometry)
*
*HTMLO     : Describe the Output of the routine
*
* ICELL  - cell number
* IWEDGE - sign of wedge in wedge-pair
* DRIFT  - drift distance of point from wire (signed)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFRCEL(XY,JFT,ICELL,IWEDGE,DRIFT)
*-----------------------------------------Updates 13/03/92-------
**: FFRCEL 30205.SB. Only call UGTBNK when run number changes
*-----------------------------------------Updates 13/02/92-------
**: FFRCEL 30205.SB. ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFRCEL 30205.SB. Remove unused FKMEAS sequence.
*-----------------------------------------Updates 24/01/92-------
**: FFRCEL 30205.SB. ERRLOG message format changed.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Calculate a radial cell number from a position                     *
*                                                                    *
* Returns ICELL = -1 if JFT is invalid                               *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION XY(2)
      DOUBLE PRECISION PHI,DPHI,PHIOFF
      DIMENSION FGAR(21)
      DIMENSION KWDP(0:47)
      SAVE FGAR,IRUN,KWDP

*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,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

* Wedge spacing in phi - NB number of wedges is hard-wired
      PARAMETER (DPHI=TWOPI/48.0D0)

      DATA IRUN/-999999/

* This should end up being read from a bank?
      DATA KWDP/ 0, 1, 8, 9, 2, 3,10,11, 4, 5,12,13,
     &           6, 7,14,15, 8, 9,16,17,10,11,18,19,
     &          12,13,20,21,14,15,22,23,16,17, 0, 1,
     &          18,19, 2, 3,20,21, 4, 5,22,23, 6, 7/

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

      ICELL = -1

      IF (IRUN.NE.NCCRUN) THEN
* Get geometry bank
         CALL UGTBNK('FGAR',INFGAR)
         IF (INFGAR.LE.0) THEN
            CALL ERRLOG(371,'S:FFRCEL: Bank FGAR not found')
            RETURN
         ENDIF
         IRUN = NCCRUN
         CALL UCOPY(RW(INFGAR+1),FGAR,21)
      ENDIF

* Check the plane number. NB phi offset is hard-wired
      IF (JFT.GE.13 .AND. JFT.LE.24) THEN
         KMOD = 0
         PHIOFF = 0.D0
      ELSEIF (JFT.GE.37 .AND. JFT.LE.48) THEN
         KMOD = 1
         PHIOFF = DPHI/2.D0
      ELSEIF (JFT.GE.61 .AND. JFT.LE.72) THEN
         KMOD = 2
         PHIOFF = DPHI/3.D0
      ELSE
         RETURN
      ENDIF

* Wire number
      KWIRE = MOD(JFT-1,12)

* Wedge number from phi
      PHI = DATAN2(XY(2),XY(1)) - PHIOFF
      IF (PHI.LT.0.0D0) PHI = PHI + TWOPI
      KWEDGE = PHI/DPHI
* Allow for edge effects
      IF (KWEDGE.GT.47) KWEDGE = 0

* NB The format of FGAR is hard-coded here
      INDMOD = 10 + 4*KMOD
      PHI    = FGAR(INDMOD+3) - DPHI/2.0D0 + KWEDGE*DPHI
      CPHI   = DCOS(PHI)
      SPHI   = DSIN(PHI)
      STAGG  = FGAR(6)

* (x,y) -> drift (NB check stagger!)
      WWIRE  = STAGG*(-1)**KWIRE
      DRIFT  = CPHI*XY(2) - SPHI*XY(1) - WWIRE

* Wedge sign, and wedge -> wedge-pair
      IWEDGE = MOD(KWEDGE,4)/2
      KWEDGE = KWDP(KWEDGE)

* Cell number
      ICELL = 288*KMOD + 12*KWEDGE + KWIRE

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  4.00/01 21/09/93  16.21.34  by  Stephen Burke
*CMZU:  3.06/06 01/12/92  14.21.06  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Initialise the Kalman filter using data read in from steering banks.
*
*HTMLI     : Describe the Input variables to the routine
*
* FFTS bank - general steering flags
* FFTP bank - various parameters
* FFTM bank - `maps', i.e. parameters set for each wire plane
*
*HTMLO     : Describe the Output of the routine
*
* Steering parameters in various Kalman filter common blocks
* (FFSTEE,FKCNTL,FKFLAG,FKCONS,FKRJCT,FKLERR)
*
* A summary of the steering is printed to unit 6 unless printout
* is suppressed.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFTEXT
*-----------------------------------------Updates 21/09/93-------
**: FFTEXT.......SB. Turn off momentum cuts for zero field.
*-----------------------------------------Updates 30/11/92-------
**: FFTEXT.......SB. New steering cuts; FFRS bank format changed.
*-----------------------------------------Updates 13/03/92-------
**: FFTEXT 30205.SB. Suppress printout if IW(6).LE.0
*-----------------------------------------Updates 13/02/92-------
**: FFTEXT 30205.SB. Steering banks/parameters modified.
**: FFTEXT 30205.SB. Now protected against getting wrong version
**: FFTEXT 30205.SB. of steering banks.
**: FFTEXT 30205.SB. ERRLOG error numbers changed.
**: FFTEXT 30205.SB. Printout format improved.
*-----------------------------------------Updates 07/02/92-------
**: FFTEXT 30205.SB. Add printout of main steering parameters.
*-----------------------------------------Updates 24/01/92-------
**: FFTEXT 30205.SB. Small bug fix in debug steering.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Initialise the Kalman filter using data read in from steering      *
* banks:                                                             *
*                                                                    *
*  FFTS - general steering flags                                     *
*  FFTP - various parameters                                         *
*  FFTM - `maps', i.e. parameters set for each wire plane            *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKLERR.
      PARAMETER(NROUT=20,NCODE=50)
      COMMON /FKLERR/ NMERR(NCODE,NROUT),NUERR(NCODE,NROUT)
     &,               NFAT,NERR,NOFL,NUFL,IULAST,IRLAST,MAXERR
*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 NMES(NFT),R(3),B(3)
      DATA NMES/12*1,12*2,12*1,12*2,12*1,12*2/

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

      IF (NFT.GT.NPL) THEN
         WRITE(6,*)
         WRITE(6,*) '**FFTEXT**  NFT.GT.NPL; coding error'
         WRITE(6,*)
         CALL H1STOP
      ENDIF

* Get the steering bank
      CALL UGTBNK('FFTS',INDS)
      IF (INDS.GT.0) THEN
         IVERS = IW(INDS+1)
         IF (IVERS.NE.301192) THEN
            INDS = 0
            CALL ERRLOG(381,'F:FFTEXT: Wrong version of bank FFTS;'//
     &                      ' defaults used')
         ENDIF
      ELSE
         CALL ERRLOG(382,'W:FFTEXT: Bank FFTS not found;'//
     &                   ' defaults used')
      ENDIF
      IF (INDS.LE.0) THEN
         IDIAG  = 0
         PMCUT  = 0.
         LRISV  = .FALSE.
         JPLISV = 37
         ISRJCT = 0
         PCUT   = 0.1
         CHPCUT = 0.0001
         LUNHB  = 0
         LUNGKS = 20
         IWKGKS = 8601
         IDGKS  = 1
         LUNGKS = 21
         IWKGKS = 4
         IDGKS  = 2
         QOPMAX = 1000.0
         THEMAX = 1.0
         RFTMIN = 12.0
         RFTMAX = 80.0
         CEMAX  = 100.0
      ELSE
         LUN    = IW(INDS+2)
         IPR    = IW(INDS+3)
         MAXERR = IW(INDS+4)
         IDIAG  = IW(INDS+5)
         PMCUT  = RW(INDS+6)
         IF (IW(INDS+7).EQ.1) THEN
            LPOINT = .TRUE.
         ELSE
            LPOINT = .FALSE.
         ENDIF
         IF (IW(INDS+8).EQ.1) THEN
            LBLOCK = .TRUE.
         ELSE
            LBLOCK = .FALSE.
         ENDIF
         IF (IW(INDS+9).EQ.1) THEN
            LPRINI = .TRUE.
         ELSE
            LPRINI = .FALSE.
         ENDIF
         IF (IW(INDS+10).EQ.1) THEN
            LRISV = .TRUE.
         ELSE
            LRISV = .FALSE.
         ENDIF
         JPLRSV = IW(INDS+11)
         ISRJCT = IW(INDS+12)
         PCUT   = RW(INDS+13)
         CHPCUT = RW(INDS+14)
         LUNHB  = IW(INDS+15)
         LUNGKS = IW(INDS+16)
         IWKGKS = IW(INDS+17)
         IDGKS  = IW(INDS+18)
         LUNGKM = IW(INDS+19)
         IWKGKM = IW(INDS+20)
         IDGKM  = IW(INDS+21)
         QOPMAX = RW(INDS+22)
         THEMAX = RW(INDS+23)
         RFTMIN = RW(INDS+24)
         RFTMAX = RW(INDS+25)
         CEMAX  = RW(INDS+26)
      ENDIF

* Don't cut on momentum if field is too small
      CALL VZERO(R,3)
      CALL GUFLD(R,B)
      IF (ABS(B(3)).LT.1.0) THEN
         PCUT   = -1.0
         QOPMAX = -1.0
      ENDIF

* Decode diagnostic steering
      IF (MOD(IDIAG,10).GT.0) THEN
         LGRAPH = .TRUE.
      ELSE
         LGRAPH = .FALSE.
      ENDIF
      IF (MOD(IDIAG/10,10).GT.0) THEN
         LTRUTH = .TRUE.
      ELSE
         LTRUTH = .FALSE.
      ENDIF
      IHFK = MOD(IDIAG/100,1000)
      IHFF = IDIAG/100000

* Get the parameter bank
      CALL UGTBNK('FFTP',INDP)
      IF (INDP.GT.0) THEN
         IVERS = IW(INDP+1)
         IF (IVERS.NE.13292) THEN
            INDP = 0
            CALL ERRLOG(383,'F:FFTEXT: Wrong version of bank FFTP;'//
     &                      ' defaults used')
         ENDIF
      ELSE
         CALL ERRLOG(384,'W:FFTEXT: Bank FFTP not found;'//
     &                   ' defaults used')
      ENDIF
      IF (INDP.LE.0) THEN
         DSX    = 1.0
         DSY    = 1.0
         DSQOP  = 1.0
         DSTTH  = 0.1
         DSPHI  = 0.1
      ELSE
         X2PCUT = RW(INDP+2)
         X2CUTB = RW(INDP+3)
         X2CUTA = RW(INDP+4)
         X2CUTN = RW(INDP+5)
         X2PCTI = RW(INDP+6)
         X2CTBI = RW(INDP+7)
         X2CTAI = RW(INDP+8)
         X2CTNI = RW(INDP+9)
         DSX    = RW(INDP+10)
         DSY    = RW(INDP+11)
         DSQOP  = RW(INDP+12)
         DSTTH  = RW(INDP+13)
         DSPHI  = RW(INDP+14)
      ENDIF

* Get the map bank
      CALL UGTBNK('FFTM',INDM)
      IF (INDM.GT.0) THEN
         IVERS = IW(INDM+1)
         IF (IVERS.NE.13292) THEN
            INDM = 0
            CALL ERRLOG(385,'F:FFTEXT: Wrong version of bank FFTM;'//
     &                      ' defaults used')
         ENDIF
      ELSE
         CALL ERRLOG(386,'W:FFTEXT: Bank FFTM not found;'//
     &                   ' defaults used')
      ENDIF
      IF (INDM.LE.0) THEN
         DO 100 JFT=1,NFT
            LWMAP(JFT) = .TRUE.
            IRP(JFT)   = NMES(JFT)
            JPLFT(JFT) = JFT
            JFTPL(JFT) = JFT
 100     CONTINUE
         JPLMAX = NFT
      ELSE
         DO 200 JPL=1,NPL
            NBLOCK(JPL) = IW(INDM+JPL+1)
            IF (IW(INDM+NPL+JPL+1).EQ.1) THEN
               LWIRE(JPL) = .TRUE.
            ELSE
               LWIRE(JPL) = .FALSE.
            ENDIF
            RAD = RW(INDM+2*NPL+JPL+1)
            IF (RAD.GT.0.) THEN
               RADL(JPL) = RAD
               LRAD(JPL) = .TRUE.
            ELSE
               RADL(JPL) = -RAD
               LRAD(JPL) = .FALSE.
            ENDIF
 200     CONTINUE
         JPLMAX = 0
         DO 300 JFT=1,NFT
            IF (IW(INDM+3*NPL+JFT+1).EQ.1) THEN
               JPLMAX        = JPLMAX + 1
               LWMAP(JFT)    = .TRUE.
               JFTPL(JFT)    = JPLMAX
               IRP(JPLMAX)   = NMES(JFT)
               JPLFT(JPLMAX) = JFT
            ELSE
               LWMAP(JFT)    = .FALSE.
               JFTPL(JFT)    = 0
            ENDIF
 300     CONTINUE
      ENDIF

*Check print flag
      IF (IW(6).LE.0) RETURN

      WRITE(LUN,*)
      WRITE(LUN,*)
      WRITE(LUN,*) '        *** Kalman Filter steering parameters ***'
      WRITE(LUN,*)
      WRITE(LUN,*)
      IF (LPOINT) THEN
         WRITE(LUN,*) 'Point rejection enabled'
         WRITE(LUN,1000) X2PCUT
      ELSE
         WRITE(LUN,*) 'Point rejection disabled'
      ENDIF
      IF (LBLOCK) THEN
         WRITE(LUN,*) 'Block point rejection enabled'
         WRITE(LUN,1000) X2CUTB
      ELSE
         WRITE(LUN,*) 'Block point rejection disabled'
      ENDIF
      IF (LPOINT .OR. LBLOCK) THEN
         WRITE(LUN,*) 'Point reacquisition enabled'
         WRITE(LUN,1000) X2CUTA
         WRITE(LUN,*) 'New point finding enabled'
         WRITE(LUN,1000) X2CUTN
      ELSE
         WRITE(LUN,*) 'New point finding disabled'
      ENDIF
      WRITE(LUN,*)
      IF (LRISV) THEN
         WRITE(LUN,*) 'Initial state vector removed'
         WRITE(LUN,1001) JPLRSV
         IF (LPRINI) THEN
            IF (LPOINT) THEN
               WRITE(LUN,*) 'Point rejection performed on first pass'
               WRITE(LUN,1000) X2PCTI
            ENDIF
            IF (LBLOCK) THEN
               WRITE(LUN,*)
     &            'Block point rejection performed on first pass'
               WRITE(LUN,1000) X2CTBI
            ENDIF
            IF (LPOINT .OR. LBLOCK) THEN
               WRITE(LUN,*)
     &            'Point reacquisition performed on first pass'
               WRITE(LUN,1000) X2CTAI
               WRITE(LUN,*) 'New point finding performed on first pass'
               WRITE(LUN,1000) X2CTNI
            ENDIF
         ELSEIF (LPOINT .OR. LBLOCK) THEN
            WRITE(LUN,*) 'Point rejection not performed on first pass'
            WRITE(LUN,*) 'New point finding not performed on first pass'
         ENDIF
      ELSE
         WRITE(LUN,*) 'Initial state vector not removed'
      ENDIF

      WRITE(LUN,*)
      WRITE(LUN,1002) ISRJCT
      WRITE(LUN,1003) PCUT
      WRITE(LUN,1004) CHPCUT
      WRITE(LUN,1005) QOPMAX
      WRITE(LUN,1006) THEMAX
      WRITE(LUN,1007) RFTMIN
      WRITE(LUN,1008) RFTMAX
      WRITE(LUN,1009) CEMAX

 1000 FORMAT(' Chi-squared probability cut:            ',F7.4)
 1001 FORMAT(' Starting plane:                         ',I2)
 1002 FORMAT(' Track rejection flag:              ',I7/)
 1003 FORMAT(' Initial momentum cut:                   ',F5.2)
 1004 FORMAT(' Final chi-squared probability cut:      ',F7.4)
 1005 FORMAT(' Final 1/momentum cut:                 ',F7.2)
 1006 FORMAT(' Final theta cut:                        ',F7.4)
 1007 FORMAT(' Minimum radius allowed:               ',F7.2)
 1008 FORMAT(' Maximum radius allowed:               ',F7.2)
 1009 FORMAT(' Maximum chi-squared between start/end:',F7.2/)

      WRITE(LUN,1010) DSX
      WRITE(LUN,1011) DSY
      WRITE(LUN,1012) DSQOP
      WRITE(LUN,1013) DSTTH
      WRITE(LUN,1014) DSPHI

 1010 FORMAT(' Initial error on x:                     ',F5.2)
 1011 FORMAT(' Initial error on y:                     ',F5.2)
 1012 FORMAT(' Initial error on q/p:                   ',F5.2)
 1013 FORMAT(' Initial error on tan(theta):            ',F6.3)
 1014 FORMAT(' Initial error on phi:                   ',F6.3//)

      RETURN
      END
*CMZ :  8.07/00 26/11/96  16.22.38  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  7.01/00 22/06/95  15.48.13  by  Stephen Burke
*CMZU:  5.03/00 26/10/94  21.11.07  by  Stephen Burke
*CMZU:  5.01/08 07/06/94  19.42.27  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.37  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Look for a new digitisation near a track. This is called by the
* Kalman filter code if point acquisition is enabled and no hit is
* already attached to the track at a given z plane.
*
*HTMLI     : Describe the Input variables to the routine
*
* JPL - the z plane (1 to 72)
* S   - track parameters (REAL*8 5-vector)
* C   - covariance matrix (REAL*8 5*5 matrix)
*
*HTMLO     : Describe the Output of the routine
*
* LMES(JPL) (in /FKFLAG/) is set .TRUE. if a measurement is found
* in the correct cell, within a cut X2CUTN (in /FKRJCT/) of S, and
* .TRUE. is returned as the function value. The measurement arrays
* (WMES, CMES and HMES in /FKMEAS/) are filled appropriately. IRJCT(JPL)
* (in /FKRJCT/) is set to zero. IDIGI(JPL) (in /FFGEO/) is set to the
* digi pointer, signed according to the drift sign.
*
* IERR - error flag:
*
*       IERR =   0 ; normal termination
*   ->  IERR = 101 ; invalid probability cut
*   ->  IERR = 103 ; invalid value in MES array
*   ->  IERR = 104 ; invalid value in MES array, or internal error
*       IERR =  12 ; covariance of residuals not positive definite
*
*   ->  Fatal errors
*
* Fatal errors all give a return value of .FALSE., and no changes
* are made; they are consequently recoverable.
*
*HTMLE     : Terminates the HTML documentation
*
      LOGICAL FUNCTION FKHUNT(JPL,S,C,IERR)
*-----------------------------------------Updates 27/07/93-------
**: FFHUNT 30907 RP. Farm changes.
*-----------------------------------------Updates 03/05/93-------
**: FKHUNT 30907 SB. Extra argument to FFRAD.
*-----------------------------------------Updates 07/02/92-------
**: FKHUNT 30205.SB. Remove unused HCHI variable.
**: FKHUNT 30205.SB. Initialise IFAIL1 to please UNDEF.
*-----------------------------------------Updates 24/01/92-------
**: FKHUNT 30205.SB. Check for wrong drift sign in debug mode.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Look for a new digitisation                                        *
*                                                                    *
* ERROR CONDITIONS;                                                  *
*                                                                    *
*       IERR =   0 ; normal termination                              *
*   ->  IERR = 101 ; invalid probability cut                         *
*   ->  IERR = 103 ; invalid value in MES array                      *
*   ->  IERR = 104 ; invalid value in MES array, or internal error   *
*       IERR =  12 ; covariance of residuals not positive definite   *
*                                                                    *
*   ->  Fatal errors                                                 *
*                                                                    *
* Fatal errors all give a return value of .FALSE., and no changes    *
* are made; they are consequently recoverable.                       *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER (IUTIL=1,IROUT=8)
*KEEP,FKECODE.
      PARAMETER (IWARN=0,IFATAL=1,IFPRO=2,IFFLT=3,IFSMO=4,IFPRS=5,
     &           IFPAS=6,IFPAF=7)
      PARAMETER (IINF1=1,IINF2=2,IINF3=3,IINV=4,IDONE=5)
      PARAMETER (IICV=6,IMCV=7,IOCV=11,IRCV=12,IOVCV=13,
     &           ITHGP2=16,ITHG1=17)
      PARAMETER (IFREE=20,IFREE1=30,IFREE2=40,IFREE3=50)
*KEND.

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKSMTH.
*KEEP,FKRJCT.
      DOUBLE PRECISION CHITOT,X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,                       X2PCTI,X2CTBI,X2CTAI,X2CTNI
      LOGICAL LWIRE,LPRINI
      COMMON /FKRJCT/ X2PCUT,X2CUTB,X2CUTA,X2CUTN
     &,               X2PCTI,X2CTBI,X2CTAI,X2CTNI
     &,               CHITOT(NPL),NDF(NPL)
     &,               NBLOCK(NPL),NBADP(NPL),NBADB(NPL)
     &,               NFAILP(NPL),NFAILB(NPL),NNEWP(NPL)
     &,               NUNRJP(NPL),NUNRJB(NPL),NRERJP(NPL)
     &,               NCPRS,NBPRS,NCPAS,NPASS,IRJCT(NPL)
     &,               LWIRE(NPL),LPRINI
*KEEP,FKDBG.
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*KEND.

      DIMENSION S(5),C(5,5),VXYZ(3)
      DIMENSION WTEMP(2),CTEMP(2,2),HTEMP(2,2),RES(2),CRES(2,2)
      REAL R(3),B(3)
      LOGICAL LSAVED,LTRSAV,LTRDSV

*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,FTANG.
*     Statement functions for track angle corrections...
*     (assumes COMMON FRLORA present)
      REAL DRIFT
      FTANGR(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGR, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*
      FTANGP(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGP, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*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.

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

      IERR   = 0
      FKHUNT = .FALSE.

* Don't try to replace existing points
      IF (LMES(JPL)) RETURN

* Don't look outside the tracker!
      RAD = SQRT(S(1)**2 + S(2)**2)
      IF (RAD.LT.RFTMIN .OR. RAD.GT.RFTMAX) RETURN

*
* Work out the cell number and drift for the supplied state
* vector, and then search for a match in the digi bank
*

      IF (IRP(JPL).EQ.1) THEN
         CALL FFPCEL(S,JPLFT(JPL),ICELL,DRIFT)
         IF (ICELL.LT.0) THEN
            CALL FKERR(IUTIL,IROUT,IFATAL,IINF3,IERR)
            RETURN
         ENDIF
         CALL FFPHNT(ICELL,DRIFT,JDIG)
      ELSE
         CALL FFRCEL(S,JPLFT(JPL),ICELL,IWEDGE,DRIFT)
         IF (ICELL.LT.0) THEN
            CALL FKERR(IUTIL,IROUT,IFATAL,IINF3,IERR)
            RETURN
         ENDIF
         CALL FFRHNT(ICELL,DRIFT,IWEDGE,JDIG)
      ENDIF

* Give up if nothing was found, or if we just found the same point
      IF (JDIG.EQ.0 .OR. (IRJCT(JPL).GT.0 .AND.
     &                    ABS(IDIGI(JPL)).EQ.JDIG)) RETURN

* Disallow point sharing
      IF (INDKX(IRP(JPL)).GT.0 .AND.
     &    IBTAB(INDKX(IRP(JPL)),1,JDIG).NE.0) RETURN
      IF (IBTAB(INDX(IRP(JPL)),1,JDIG).NE.0) RETURN

* If there's something here, save it in case we change our mind
      IF (IRJCT(JPL).GT.1) THEN
         CALL UCOPY(WMES(1,JPL),WTEMP,4)
         CALL UCOPY(CMES(1,1,JPL),CTEMP,8)
         CALL UCOPY(HMES(1,1,JPL),HTEMP,8)
         ZTEMP  = ZPL(JPL)
         MTEMP  = MES(JPL)
         ITEMP  = IDIGI(JPL)
         LTRSAV = LTRPL(JPL)
         LTRDSV = LTRPLD(JPL)
         LSAVED = .TRUE.
      ELSE
         LSAVED = .FALSE.
      ENDIF

*
* Fill the measurement arrays
*

      IF (IRP(JPL).EQ.1) THEN
         CALL FFPLAN(JDIG)
      ELSE
* Always include radius
         CALL FFRAD(JDIG,0)
      ENDIF

* Event T0 correction
      CALL FFEVT0(DEVT0,ZNOM,VXYZ)
      R(1) = S(1)
      R(2) = S(2)
      R(3) = ZPL(JPL)
      CALL GUFLD(R,B)
* Track angle, time-of-flight and propagation time
      CALL FFCORR(JPL,S,ZNOM,VXYZ,DEVT0,B(3),DCORR)
      WMES(1,JPL) = WMES(1,JPL) + SIGN(1,IDIGI(JPL))*DCORR

*
* See if the chi**2 is acceptable
*

      LMES(JPL) = .TRUE.
      CALL FKLRSD(JPL,S,C,3,RES,CRES,CHISQ,IFAIL)

* Update the LTRPL array
      IF (LTRUTH) CALL FFCHTR(JPL,MES(JPL),JDIG)
* Histogram residuals
      IF (MOD(IHFK/10,10).GT.0) CALL FKANAL(JPL,RES,CHISQ,0,0)

      IFAIL1 = 0
      IF (IFAIL.EQ.0 .AND. CHISQ.LT.FKCHPR(4,MES(JPL),IFAIL1)) THEN
         IF (IFAIL1.EQ.0) THEN
* New point, starting from scratch
            IRJCT(JPL) = 0
            FKHUNT = .TRUE.
            RETURN
         ENDIF
      ENDIF

*
* The new point failed the chi**2 cut, so tidy up
*

      IF (IFAIL.NE.0) CALL FKERR(IUTIL,IROUT,IWARN,IFAIL,IERR)
      IF (IFAIL1.NE.0) CALL FKERR(IUTIL,IROUT,IFAIL1/100,IFAIL1,IERR)

      LMES(JPL) = .FALSE.

      IF (LSAVED) THEN
         CALL UCOPY(WTEMP,WMES(1,JPL),4)
         CALL UCOPY(CTEMP,CMES(1,1,JPL),8)
         CALL UCOPY(HTEMP,HMES(1,1,JPL),8)
         ZPL(JPL)    = ZTEMP
         MES(JPL)    = MTEMP
         IDIGI(JPL)  = ITEMP
         LTRPL(JPL)  = LTRSAV
         LTRPLD(JPL) = LTRDSV
      ENDIF

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  5.03/00 03/11/94  23.14.24  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.37  by  Stephen Burke
*-- Author : Stephen Burke  30/11/92
*
*HTMLP*    : Describe the Purpose of the routine
*
* Decide whether to reject a track (after fitting).
*
*HTMLI     : Describe the Input variables to the routine
*
* J1 - z plane number (1 to 72) of the start of the track
* J2 - z plane number (1 to 72) of the end of the track
*
* Track parameters and cut values in various common blocks
* (FFSTEE,FKCONS,FKSMTH)
*
*HTMLO     : Describe the Output of the routine
*
* The return value is .TRUE. if the track should be rejected
*
*HTMLE     : Terminates the HTML documentation
*
      LOGICAL FUNCTION FFKILL(J1,J2)
*-----------------------------------------Updates 27/07/93-------
**: FFKILL 30907 SB. Changes to monitoring histograms.
**: FFKILL 30907 RP. Farm changes.
*-----------------------------------------Updates 03/03/93-------
**: FFKILL 30907 SB. Cuts can be turned off with negative values.
*-----------------------------------------Updates 30/11/92-------
**: FFKILL 30907 SB. New deck to remove bad tracks.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Decide whether to reject a track                                   *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION S1(5),C1(5,5),S2(5),C2(5,5),DTRAN(5,5),QMS(5,5)
     &,                DZ,RADLEN,CHI12,TEMP

*KEEP,FTHIST.
* indices of filter farm histos
      COMMON/FTHIST/IHP(100)
*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKSMTH.
*KEND.

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

      FFKILL = .TRUE.

* Momentum too small?
      IF (QOPMAX.GE.0. .AND. ABS(SSMT(3,J1)).GT.QOPMAX) THEN
         NQFAIL = NQFAIL + 1
         RETURN
      ENDIF

* Theta too big?
      IF (THEMAX.GE.0.) THEN
         TTMX = TAN(THEMAX)
      ELSE
         TTMX = 1.0E35
      ENDIF
      IF (SSMT(4,J1).GT.TTMX .OR. SSMT(4,J2).GT.TTMX) THEN
         NAFAIL = NAFAIL + 1
         RETURN
      ENDIF

* Start/end outside tracker?
      R1   = SQRT(SSMT(1,J1)**2 + SSMT(2,J1)**2)
      R2   = SQRT(SSMT(1,J2)**2 + SSMT(2,J2)**2)
      RMIN = MIN(R1,R2)
      RMAX = MAX(R1,R2)
      IF (RMIN.LT.RFTMIN .OR. RMAX.GT.RFTMAX) THEN
         NOFAIL = NOFAIL + 1
         RETURN
      ENDIF

      FFKILL = .FALSE.
      IF (CEMAX.LT.0.) RETURN

* Swim from start to end ...
      DZ = ZPL(J2) - ZPL(J1)
      CALL FKTRAN(DZ,ZPL(J1),SSMT(1,J1),S1,DTRAN)
      CALL FKMUL(CSMT(1,1,J1),DTRAN,C1)

* ... allow for multiple scattering - assume av. rad. length is 10 cm (!) ...
      RADLEN = 10.0D0
      CALL FKSCAT(DZ,SSMT(1,J1),RADLEN,DTRAN,QMS)
      CALL FKQADD(C1,QMS)

* ... find difference between end parameters and extrapolation ...
      CALL FKDIFF(SSMT(1,J2),S1,S2)
      CALL FKADD(CSMT(1,1,J2),C1,C2)
      CALL DSINV(5,C2,5,IFAIL)

* ... and calculate chi-squared
      IF (IFAIL.NE.0) RETURN

      CHI12 = 0.0D0
      DO 200 I1=1,5
         TEMP = 0.0D0
         DO 100 I2=1,5
            TEMP = TEMP + C2(I1,I2)*S2(I2)
 100     CONTINUE
         CHI12 = CHI12 + S2(I1)*TEMP
 200  CONTINUE

C      CALL SHS(20,0,SNGL(CHI12))
      IF (CHI12.LE.CEMAX) RETURN

      NIFAIL = NIFAIL + 1
      FFKILL = .TRUE.

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  5.01/08 16/02/94  14.47.39  by  Stephen Burke
*CMZ :  4.00/00 09/09/93  19.04.16  by  Gregorio Bernardi
*CMZU:  3.09/07 26/07/93  10.00.36  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Top level routine (pseudo-module) to fit pattern-recognised tracks.
* Does some initialisation on the first event, calls FFFIT to perform
* the fit and calls FFEND at the end of a run to print some statistics.
*
*HTMLI     : Describe the Input variables to the routine
*
* None
*
*HTMLO     : Describe the Output of the routine
*
* None
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFKAL
*-----------------------------------------Updates 07/09/93-------
**: FFKAL 40000 SB.  No more garbage collection.
*-----------------------------------------Updates 27/07/93-------
**: FFKAL  30907 RP. Farm changes.
*-----------------------------------------Updates 03/05/93-------
**: FFKAL 30907 SB.  Print summary on ENDJOB.
**: FFKAL 30907 SB.  Output LOOK histograms.
*-----------------------------------------Updates 30/11/92-------
**: FFKAL 30907 SB.  Print new counters.
**: FFKAL 30907 SB.  Call new diagnostic routine FFTRAN.
*-----------------------------------------Updates 06/08/92-------
**: FFKAL 30907 SB.  Cosmetic changes.
*-----------------------------------------Updates 13/03/92-------
**: FFKAL 30205.SB.  Put REVENT code after ENDRUN code
**: FFKAL 30205.SB.  Suppress printout if IW(6).LE.0
*-----------------------------------------Updates 13/02/92-------
**: FFKAL 30205.SB.  Small cosmetic change (IFIRST -> LINIT).
**: FFKAL 30205.SB.  ERRLOG error numbers changed.
*-----------------------------------------Updates 07/02/92-------
**: FFKAL 30205.SB.  Change printout format slightly.
*-----------------------------------------Updates 24/01/92-------
**: FFKAL 30205.SB.  BKFMT calls moved here.
**: FFKAL 30205.SB.  New counters added.
**: FFKAL 30205.SB.  Call H1STOP if initialisation fails.
**: FFKAL 30205.SB.  ERRLOG message format changed.
**: FFKAL 30205.SB.  Make sure PAW directory is reset.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Steer Kalman filter track fit on results of FTREC                  *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*KEND.

      LOGICAL LINIT
      SAVE LINIT

*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.

      DATA LINIT/.TRUE./

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

* Initialise Kalman filter, and set parameter defaults
      IF (BEGJOB) CALL FKINIT

      IF (BEGRUN .AND. LINIT) THEN
* Zero work bank indices (just in case ...)
         CALL VZERO(INDRSX,NWBI)
* Zero counters
         CALL VZERO(NPFAIL,NSCAL)
* Override defaults with parameters read from text banks
         CALL FFTEXT
* Format output banks
         CALL BKFMT('FTKR','2I,(6F,I,9F,I,F,3I)')
         CALL BKFMT('FTKX','B16')
         CALL BKFMT('FTPR','B16')
         CALL BKFMT('FTPX','B16')
         CALL BKFMT('FTRX','B16')
* Book monitoring histograms
         CALL FFBKLK
* Book some debug histograms
         CALL FKHBK
         CALL FFHBK
* Initialise GKS
         LINIT = .FALSE.
      ENDIF

      IF (REVENT .AND. LINIT) THEN
* This shouldn't happen!
         WRITE(6,*)
         WRITE(6,*) '**FFKAL**  Not initialised - code error'
         WRITE(6,*)
         CALL H1STOP
      ENDIF

      IF (ENDRUN.OR.ENDJOB) CALL FFEND

      IF (.NOT.REVENT) RETURN

      CALL FFFIT

* Count tracks
      INFTUR = NLINK('FTUR',0)
      IF (INFTUR.GT.0) NTRIN = NTRIN + IW(INFTUR+2)
      INFTKR = NLINK('FTKR',0)
      IF (INFTKR.GT.0) NTROUT = NTROUT + IW(INFTKR+2)/2

* Check output
      IF (MOD(IHFF,1000).GT.100) CALL FFKLCH
      IF (LTRUTH) CALL FFTRAN

* Make sure PAW directory is reset
      CALL HCDIR('//PAWC',' ')

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.21  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.08.51  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.03  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.37  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Look for a planar hit in a specified cell, closest to a given drift.
*
*HTMLI     : Describe the Input variables to the routine
*
* ICELL - cell number
* DRIFT - drift distance of point from wire (signed)
*
* FPLC/FPHC banks (unpacked planar hits)
* FPG1 bank (planar geometry)
*
*HTMLO     : Describe the Output of the routine
*
* JMIN - hit number (in FPLC/FRPE) of closest hit, or zero
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFPHNT(ICELL,DRIFT,JMIN)
*-----------------------------------------Updates 07/09/93-------
**: FFPHNT 40000 SB. New definition of dead wire flag.
*-----------------------------------------Updates 27/07/93-------
**: FFPHNT 30907 RP. Farm changes.
*-----------------------------------------Updates 06/08/92-------
**: FFPHNT 30907 SB. Add check on bad hit flag.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Look for a planar digi near a specified point                      *
*                                                                    *
* NB The FRPE bank must have been unpacked into FPLC and FPHC, with  *
* a pointer to FPLC in INDLC(1) in /FFGEO/                           *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEND.

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

      JMIN = 0

      INDHC = NLINK('FPHC',0)
      IF (INDHC.LE.0 .OR. INDG1(1).LE.0 .OR. INDLC(1).LE.0) RETURN

* Check for dead wire
      IF (LBTAB(INDG1(1),1,ICELL+1).EQ.1) RETURN

      NHIT = IBTAB(INDHC,1,ICELL+1)
      J1   = IBTAB(INDHC,2,ICELL+1)

*
* Find the hit with the minimum difference between its drift and
* the target drift. Since the resolution is 150 um and the two-track
* resolution is 2 mm there is never any ambiguity.
*

      DDMIN = 1.E10
      DO 100 JDIG=J1,J1+NHIT-1
         DD  = RBTAB(INDLC(1),2,JDIG)
         DDD = ABS(ABS(DD) - ABS(DRIFT))
         IF (DDD.LT.DDMIN) THEN
            DDMIN = DDD
            JMIN  = JDIG
         ENDIF
 100  CONTINUE

* Check the bad hit flag (if it exists)
      IF (IW(INDLC(1)+1).LT.4) RETURN
      IBAD = IBTAB(INDLC(1),4,JMIN)
      IF (JBIT(IBAD,8).EQ.1) JMIN = 0

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.08.51  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.03  by  Stephen Burke
*CMZU:  3.09/07 26/07/93  10.00.37  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Look for a radial hit in a specified cell, closest to a given drift.
*
*HTMLI     : Describe the Input variables to the routine
*
* ICELL  - cell number
* DRIFT  - drift distance of point from wire (signed)
* IWEDGE - sign of wedge-pair
*
* FRLC/FRHC banks (unpacked radial hits)
* FRG1 bank (radial geometry)
*
*HTMLO     : Describe the Output of the routine
*
* JMIN - hit number (in FRLC/FRRE) of closest hit, or zero
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFRHNT(ICELL,DRIFT,IWEDGE,JMIN)
*-----------------------------------------Updates 07/09/93-------
**: FFRHNT 40000 SB. New definition of dead wire flag.
*-----------------------------------------Updates 27/07/93-------
**: FFRHNT 30907 RP. Farm changes.
**----------------------------------------------------------------------
**: FFRHNT 30907 SB. Check for bad hits (again).
**----------------------------------------------------------------------
**: FFRHNT 30104 SM. Check for bad hits.
**----------------------------------------------------------------------
**********************************************************************
*                                                                    *
* Look for a radial digi near a specified point                      *
*                                                                    *
* NB The FRRE bank must have been unpacked into FRLC and FRHC, with  *
* a pointer to FRLC in INDLC(2) in /FFGEO/                           *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEND.

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

      JMIN = 0

      INDHC = NLINK('FRHC',0)
      IF (INDHC.LE.0 .OR. INDG1(2).LE.0 .OR. INDLC(2).LE.0) RETURN

* Check for dead wires
      IDEAD = LBTAB(INDG1(2),1,ICELL+1)
      IF (IDEAD.EQ.1 .OR. IDEAD.EQ.IWEDGE+2) RETURN

      NHIT = IBTAB(INDHC,1,ICELL+1)
      J1   = IBTAB(INDHC,2,ICELL+1)

*
* Find the hit with the minimum difference between its drift and
* the target drift. Since the resolution is 150 um and the two-track
* resolution is 2 mm there is never any ambiguity; also no need to
* look at the radius.
*

      DDMIN = 1.E10
      DO 100 JDIG=J1,J1+NHIT-1
         DD  = RBTAB(INDLC(2),2,JDIG)
         DDD = ABS(ABS(DD) - ABS(DRIFT))
         IF (DDD.LT.DDMIN) THEN
            DDMIN = DDD
            JMIN  = JDIG
         ENDIF
 100  CONTINUE

* Check that it's the right wedge, and the hit is OK
      ISGNW = IBTAB(INDLC(2),6,JMIN)
      IF (JBIT(ISGNW,1).NE.IWEDGE) JMIN = 0
      IF (JBIT(ISGNW,8).EQ.1) JMIN = 0

      RETURN
      END
*CMZ :  8.07/00 20/11/96  17.23.05  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.39  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.08.51  by  Stephen Burke
*CMZ :  4.00/00 07/09/93  17.58.03  by  Stephen Burke
*CMZU:  2.07/01 05/09/91  14.42.18  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Reject tracks on the basis of the pattern recognition output
* (momentum and number of hits/modules).
*
*HTMLI     : Describe the Input variables to the routine
*
* QBYP - q/p from the patrec fit (REAL*8)
*
* Track information and cut values in various common blocks (FFSTEE,FKFLAG)
*
*HTMLO     : Describe the Output of the routine
*
* The return value is .TRUE. if the track should be rejected
*
*HTMLE     : Terminates the HTML documentation
*
      LOGICAL FUNCTION FFRJCT(QBYP)
*-----------------------------------------Updates 07/09/93-------
**: FFRJCT 40000 SB. Min. no. of hits for radial-only tracks.
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Makes an initial decision on whether to reject the track, or       *
* points on it                                                       *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION QBYP
      DIMENSION MODP(9),MODR(3)
      SAVE MODP,MODR

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEND.

      DATA MODP/1,5,9,25,29,33,49,53,57/
      DATA MODR/13,37,61/

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

      FFRJCT = .TRUE.

      IF (PCUT.GT.0 .AND. ABS(SNGL(QBYP)).GT.1./PCUT) THEN
         NMFAIL = NMFAIL + 1
         RETURN
      ENDIF

      NRHIT  = MOD(ISRJCT/10,100)
      NRMOD  = MOD(ISRJCT,10)

* Must have more than NRMOD modules with NRHIT hits each
      NMODR = 0
      NTOTR = 0
      DO 200 JMOD=1,3
         NHIT = 0
         MFT = MODR(JMOD)
         DO 100 JFT=MFT,MFT+11
            JPL = JFTPL(JFT)
            IF (JPL.GT.0 .AND. LMES(JPL)) NHIT = NHIT + 1
 100     CONTINUE
         NTOTR = NTOTR + NHIT
         IF (NHIT.GE.NRHIT) NMODR = NMODR + 1
 200  CONTINUE

* Kill radials if less than 9 hits total (reduces space in FTKR/DTNV)
      IF (NTOTR.LT.9) NMODR = 0

      IF (NMODR.LT.NRMOD) THEN
         NRFAIL = NRFAIL + 1
         RETURN
      ENDIF

      NPKILL = MOD(ISRJCT/1000000,10)
      NPHIT  = MOD(ISRJCT/100000,10)
      NPMOD  = MOD(ISRJCT/10000,10)
      NPSMOD = MOD(ISRJCT/1000,10)

* Must have NPHIT hits in NPMOD modules in NPSMOD supermodules
      NSMOD = 0
      DO 700 JSMOD=0,2
         NMODP = 0
         DO 500 JMOD=1,3
            MFT = MODP(3*JSMOD+JMOD)
            NHIT = 0
            DO 300 JFT=MFT,MFT+3
               JPL = JFTPL(JFT)
               IF (JPL.GT.0 .AND. LMES(JPL)) NHIT = NHIT + 1
 300        CONTINUE
            IF (NHIT.GE.NPHIT) THEN
               NMODP = NMODP + 1
            ELSEIF (NPKILL.GT.0) THEN
               DO 400 JFT=MFT,MFT+3
                  JPL = JFTPL(JFT)
                  IF (JPL.GT.0) LMES(JPL) = .FALSE.
 400           CONTINUE
            ENDIF
 500     CONTINUE
         IF (NMODP.GE.NPMOD) THEN
            NSMOD = NSMOD + 1
         ELSEIF (NPKILL.GT.0) THEN
            MFT = MODP(3*JSMOD+1)
            DO 600 JFT=MFT,MFT+11
               JPL = JFTPL(JFT)
               IF (JPL.GT.0) LMES(JPL) = .FALSE.
 600        CONTINUE
         ENDIF
 700  CONTINUE

      IF (NSMOD.GE.NPSMOD) THEN
         FFRJCT = .FALSE.
      ELSE
         NPFAIL = NPFAIL + 1
      ENDIF

* Must have at least one module above the threshold number of hits
      IF (NMODR+NSMOD.LT.1) THEN
         FFRJCT = .TRUE.
         NRFAIL = NRFAIL + 1
         RETURN
      ENDIF

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.40  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  7.01/00 11/07/95  20.20.14  by  Stephen Burke
*CMZU:  5.01/08 30/06/94  13.29.36  by  Stephen Burke
*-- Author : Stephen Burke  15/02/94
*
*HTMLP*    : Describe the Purpose of the routine
*
* Print statistics at end of a run/job
*
*HTMLI     : Describe the Input variables to the routine
*
* Information in the FFSCAL common block
*
*HTMLO     : Describe the Output of the routine
*
* Summary printout (controlled by various steering flags)
*
* Area 0 LOOK histograms to FFLOOKOUTPUT if requested
* HBOOK histograms to a file if requested
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFEND
*-----------------------------------------Updates 15/02/94-------
**: FFEND.......SB.  New routine for end-of-run printout
*-----------------------------------------Updates----------------
**********************************************************************
*                                                                    *
* Print statistics at end of run                                     *
*                                                                    *
**********************************************************************

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFSCAL.
* Counters
      PARAMETER (NSCAL=145)
      COMMON /FFSCAL/ NPFAIL,NRFAIL,NXFAIL,NFFAIL,NMFAIL,NBFAIL,NTFAIL
     &,               NWFAIL,NNSPLT,NNMISS,NNMISP
     &,               NQFAIL,NAFAIL,NOFAIL,NIFAIL
     &,               NTRIN,NTROUT,NPRSEG(0:7,0:7),N23SEG(0:7,0:7)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*KEND.
      COMMON /SUMARY/ LSUMA

      DIMENSION SEGFR(0:3,0:3),SEGFRP(0:3),SEGFRR(0:3)
      DIMENSION S23FR(0:3,0:3),S23FRP(0:3),S23FRR(0:3)

*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.

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

      IF (IW(6).LE.0) RETURN
      IF (.NOT.ENDJOB .AND. LSUMA.NE.1) RETURN

      IF (LUN.LE.0) LUN = 6

      WRITE(LUN,*)
      WRITE(LUN,*)
      WRITE(LUN,*) '             *** Kalman Filter track summary ***'
      WRITE(LUN,*)
      WRITE(LUN,*) 'Tracks found:               ',NTRIN
      WRITE(LUN,*)
      WRITE(LUN,*) 'BOS array full:             ',NWFAIL
      WRITE(LUN,*) 'Bank structure corrupt:     ',NBFAIL
      WRITE(LUN,*) 'Bad track parameters:       ',NTFAIL
      WRITE(LUN,*) 'Too few planar points:      ',NPFAIL
      WRITE(LUN,*) 'Too few radial points:      ',NRFAIL
      WRITE(LUN,*) 'Momentum below cut:         ',NMFAIL
      WRITE(LUN,*) 'Fatal error in fit:         ',NFFAIL
      WRITE(LUN,*) 'Bad chi-squared prob:       ',NXFAIL
      WRITE(LUN,*) 'Momentum too small:         ',NQFAIL
      WRITE(LUN,*) 'Theta too large:            ',NAFAIL
      WRITE(LUN,*) 'Track outside tracker:      ',NOFAIL
      WRITE(LUN,*) 'Start and end inconsistent: ',NIFAIL
      WRITE(LUN,*)
      WRITE(LUN,*) 'Tracks fitted:              ',NTROUT
      WRITE(LUN,*)
      WRITE(LUN,*)

      IF (LTRUTH) THEN
         WRITE(LUN,*) 'Tracks split:               ',NNSPLT
         WRITE(LUN,*) 'Tracks missed:              ',NNMISS
         WRITE(LUN,*) 'Tracks missed (primary):    ',NNMISP
         WRITE(LUN,*)
         WRITE(LUN,*)
      ENDIF

      IF (NTROUT.LE.0 .OR. .NOT.ENDJOB) RETURN

      CALL VZERO(SEGFR,16)
      CALL VZERO(SEGFRP,4)
      CALL VZERO(SEGFRR,4)
      SEGSUM = 0.
      CALL VZERO(S23FR,16)
      CALL VZERO(S23FRP,4)
      CALL VZERO(S23FRR,4)
      S23SUM = 0.
      DO 200 JPS=0,7
         NPS = JBIT(JPS,3) + JBIT(JPS,2) + JBIT(JPS,1)
         DO 100 JRS=0,7
            NRS  = JBIT(JRS,3) + JBIT(JRS,2) + JBIT(JRS,1)
            SEGF = 100.*FLOAT(NPRSEG(JPS,JRS))/FLOAT(NTROUT)
            SEGFR(NPS,NRS) = SEGFR(NPS,NRS) + SEGF
            SEGFRP(NPS)    = SEGFRP(NPS)    + SEGF
            SEGFRR(NRS)    = SEGFRR(NRS)    + SEGF
            SEGSUM         = SEGSUM         + SEGF
            S23F = 100.*FLOAT(N23SEG(JPS,JRS))/FLOAT(NTROUT)
            S23FR(NPS,NRS) = S23FR(NPS,NRS) + S23F
            S23FRP(NPS)    = S23FRP(NPS)    + S23F
            S23FRR(NRS)    = S23FRR(NRS)    + S23F
            S23SUM         = S23SUM         + S23F
 100     CONTINUE
 200  CONTINUE

      WRITE(LUN,1000)
      WRITE(LUN,*)
      WRITE(LUN,1001) (SEGFR(0,JRS),JRS=0,3),SEGFRP(0)
      WRITE(LUN,1002) (SEGFR(1,JRS),JRS=0,3),SEGFRP(1)
      WRITE(LUN,1003) (SEGFR(2,JRS),JRS=0,3),SEGFRP(2)
      WRITE(LUN,1004) (SEGFR(3,JRS),JRS=0,3),SEGFRP(3)
      WRITE(LUN,*)
      WRITE(LUN,1005) (SEGFRR(JPS),JPS=0,3),SEGSUM
      WRITE(LUN,*)
      WRITE(LUN,*)

 1000 FORMAT(14X,'0R',8X,'1R',8X,'2R',8X,'3R',12X,'XR')
 1001 FORMAT('     0P:   ',4(F6.2,4X),4X,F6.2)
 1002 FORMAT('     1P:   ',4(F6.2,4X),4X,F6.2)
 1003 FORMAT('     2P:   ',4(F6.2,4X),4X,F6.2)
 1004 FORMAT('     3P:   ',4(F6.2,4X),4X,F6.2)
 1005 FORMAT('     XP:   ',4(F6.2,4X),4X,F6.2)

      WRITE(LUN,1010)
      WRITE(LUN,*)
      WRITE(LUN,1011) (S23FR(0,JRS),JRS=0,3),S23FRP(0)
      WRITE(LUN,1012) (S23FR(1,JRS),JRS=0,3),S23FRP(1)
      WRITE(LUN,1013) (S23FR(2,JRS),JRS=0,3),S23FRP(2)
      WRITE(LUN,1014) (S23FR(3,JRS),JRS=0,3),S23FRP(3)
      WRITE(LUN,*)
      WRITE(LUN,1015) (S23FRR(JPS),JPS=0,3),S23SUM
      WRITE(LUN,*)
      WRITE(LUN,*)

 1010 FORMAT(13X,'0P3',7X,'1P3',7X,'2P3',7X,'3P3',11X,'XP3')
 1011 FORMAT('     0P2:  ',4(F6.2,4X),4X,F6.2)
 1012 FORMAT('     1P2:  ',4(F6.2,4X),4X,F6.2)
 1013 FORMAT('     2P2:  ',4(F6.2,4X),4X,F6.2)
 1014 FORMAT('     3P2:  ',4(F6.2,4X),4X,F6.2)
 1015 FORMAT('     XP2:  ',4(F6.2,4X),4X,F6.2)

      P1P2   = 0.
      P0P1P2 = 0.
      R0R1   = 0.
      P0R0R1 = 0.
      R0P1   = 0.
      P0R0P1 = 0.
      P0P2   = 0.
      R0P1R1 = 0.
      R1R2   = 0.
      P0P1   = 0.
      P1R1P2 = 0.
      R0R2   = 0.
      R0R1R2 = 0.
      P1P2R2 = 0.
      R1P2   = 0.
      R1P2R2 = 0.

* Order is planar, radial, mixed, P?, R?
      DO 400 JPS=0,7
         DO 300 JRS=0,7
            MASK = JPS*8 + JRS
            NSEG = NPRSEG(JPS,JRS)
* P0: planar, radial, mixed
            IF (IAND(MASK,32+16).EQ.48)   P1P2   = P1P2   + NSEG
            IF (IAND(MASK,32+16+8).EQ.56) P0P1P2 = P0P1P2 + NSEG
            IF (IAND(MASK,2+1).EQ.3)      R0R1   = R0R1   + NSEG
            IF (IAND(MASK,8+2+1).EQ.11)   P0R0R1 = P0R0R1 + NSEG
            IF (IAND(MASK,16+1).EQ.17)    R0P1   = R0P1   + NSEG
            IF (IAND(MASK,16+8+1).EQ.25)  P0R0P1 = P0R0P1 + NSEG
* P1: planar, radial
            IF (IAND(MASK,32+8).EQ.40)    P0P2   = P0P2   + NSEG
            IF (IAND(MASK,16+2+1).EQ.19)  R0P1R1 = R0P1R1 + NSEG
* P2: planar, radial
            IF (IAND(MASK,4+2).EQ.6)      R1R2   = R1R2   + NSEG
* R0: planar
            IF (IAND(MASK,16+8).EQ.24)    P0P1   = P0P1   + NSEG
* R1: planar, radial
            IF (IAND(MASK,32+16+2).EQ.50) P1R1P2 = P1R1P2 + NSEG
            IF (IAND(MASK,4+1).EQ.5)      R0R2   = R0R2   + NSEG
            IF (IAND(MASK,4+2+1).EQ.7)    R0R1R2 = R0R1R2 + NSEG
* R2: planar, mixed
            IF (IAND(MASK,32+16+4).EQ.52) P1P2R2 = P1P2R2 + NSEG
            IF (IAND(MASK,32+2).EQ.34)    R1P2   = R1P2   + NSEG
            IF (IAND(MASK,32+4+2).EQ.38)  R1P2R2 = R1P2R2 + NSEG
 300     CONTINUE
 400  CONTINUE

      EFFP0P = -1.
      EFFP0R = -1.
      EFFP0M = -1.
      EFFP1P = -1.
      EFFP1R = -1.
      EFFP2P = -1.
      EFFP2R = -1.
      EFFR0P = -1.
      EFFR1P = -1.
      EFFR1R = -1.
      EFFR2P = -1.
      EFFR2M = -1.

      IF (P1P2.GT.0.) EFFP0P = P0P1P2/P1P2
      IF (R0R1.GT.0.) EFFP0R = P0R0R1/R0R1
      IF (R0P1.GT.0.) EFFP0M = P0R0P1/R0P1
      IF (P0P2.GT.0.) EFFP1P = P0P1P2/P0P2
      IF (R0R1.GT.0.) EFFP1R = R0P1R1/R0R1
      IF (P0P1.GT.0.) EFFP2P = P0P1P2/P0P1
      IF (R1R2.GT.0.) EFFP2R = R1P2R2/R1R2
      IF (P0P1.GT.0.) EFFR0P = P0R0P1/P0P1
      IF (P1P2.GT.0.) EFFR1P = P1R1P2/P1P2
      IF (R0R2.GT.0.) EFFR1R = R0R1R2/R0R2
      IF (P1P2.GT.0.) EFFR2P = P1P2R2/P1P2
      IF (R1P2.GT.0.) EFFR2M = R1P2R2/R1P2

      WRITE(LUN,*) 'Efficiency for planar 0 from planars = ',EFFP0P
     &,            '   (',INT(P1P2),')'
      WRITE(LUN,*) 'Efficiency for planar 0 from radials = ',EFFP0R
     &,            '   (',INT(R0R1),')'
      WRITE(LUN,*) 'Efficiency for planar 0 from both    = ',EFFP0M
     &,            '   (',INT(R0P1),')'
      WRITE(LUN,*)
      WRITE(LUN,*) 'Efficiency for planar 1 from planars = ',EFFP1P
     &,            '   (',INT(P0P2),')'
      WRITE(LUN,*) 'Efficiency for planar 1 from radials = ',EFFP1R
     &,            '   (',INT(R0R1),')'
      WRITE(LUN,*)
      WRITE(LUN,*) 'Efficiency for planar 2 from planars = ',EFFP2P
     &,            '   (',INT(P0P1),')'
      WRITE(LUN,*) 'Efficiency for planar 2 from radials = ',EFFP2R
     &,            '   (',INT(R1R2),')'
      WRITE(LUN,*)
      WRITE(LUN,*) 'Efficiency for radial 0 from planars = ',EFFR0P
     &,            '   (',INT(P0P1),')'
      WRITE(LUN,*)
      WRITE(LUN,*) 'Efficiency for radial 1 from planars = ',EFFR1P
     &,            '   (',INT(P1P2),')'
      WRITE(LUN,*) 'Efficiency for radial 1 from radials = ',EFFR1R
     &,            '   (',INT(R0R2),')'
      WRITE(LUN,*)
      WRITE(LUN,*) 'Efficiency for radial 2 from planars = ',EFFR2P
     &,            '   (',INT(P1P2),')'
      WRITE(LUN,*) 'Efficiency for radial 2 from both    = ',EFFR2M
     &,            '   (',INT(R1P2),')'
      WRITE(LUN,*)
      WRITE(LUN,*)

      IF (IDIAG.GT.0) THEN
* Output LOOK histograms
         CALL SAREA('FTREC',0)
         CALL FWLOOK('FFLOOKOUTPUT',IERR)
         IF (IERR.NE.0) THEN
            WRITE(6,'('' FWLOOK Error'',I10)') IERR
         ELSE
            WRITE(6,'('' FFKAL Look output to file FFLOOKOUTPUT'')')
         ENDIF
      ENDIF

*Check print flag
      IF (IW(6).GT.0) THEN
         CALL FKEND
         CALL HPDIR('//PAWC/'//CFDBG,' ')
         CALL HPDIR('//PAWC/'//CFKDBG,' ')
         IF (IHFK.GT.0) CALL FKHPR
      ENDIF


      IF (IDIAG.LT.100 .OR. LUNHB.LE.0) RETURN

      OPEN(UNIT=LUNHB,ACCESS='DIRECT',FORM='UNFORMATTED',
     &     RECL=1024,STATUS='NEW',IOSTAT=IOS)
      IF (IOS.NE.0) THEN
         CALL ERRLOG(311,'W:FFKAL:  HBOOK file open failed')
         RETURN
      ENDIF

      CALL HRFILE(LUNHB,'FFKAL','N')
      CALL HCDIR('//PAWC/'//CFDBG,' ')
      CALL HCDIR('//FFKAL',' ')
      CALL HROUT(0,ICYC,' ')
      CALL HCDIR('//PAWC/'//CFKDBG,' ')
      CALL HCDIR('//FFKAL',' ')
      CALL HROUT(0,ICYC,' ')
      CALL HCDIR('//PAWC/'//CKDBG,' ')
      CALL HCDIR('//FFKAL',' ')
      CALL HROUT(0,ICYC,' ')
      CALL HCDIR('//PAWC/FPT0',' ')
      CALL HCDIR('//FFKAL',' ')
      CALL HROUT(0,ICYC,' ')
      CALL HCDIR('//PAWC',' ')
      CALL HREND('FFKAL')

      CLOSE(LUNHB)

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.40  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.08.52  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill the Kalman filter common blocks with hit information for a
* pattern-recognised track. Also check the hit lists for consistency.
*
*HTMLI     : Describe the Input variables to the routine
*
* JTR - the FTUR track number
*
* FPUR bank (pattern recognition output)
* FPG1/FRG1 banks (geometry)
*
*HTMLO     : Describe the Output of the routine
*
* Hit information in various Kalman filter common blocks
*
* LFAILP - .TRUE. if the planar digi pointers are corrupt
* LFAILR - .TRUE. if the radial digi pointers are corrupt
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFFILL(JTR,LFAILP,LFAILR)
**********************************************************************
*                                                                    *
* Fill the Kalman filter common blocks with the hit information      *
*                                                                    *
* INPUT:                                                             *
*   JTR is the FTUR track number                                     *
*                                                                    *
* OUTPUT:                                                            *
*   LFAILP is .TRUE. if the planar digi pointers are corrupt         *
*   LFAILR is .TRUE. if the radial digi pointers are corrupt         *
*                                                                    *
**********************************************************************

      LOGICAL LFAILP,LFAILR

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKPROJ.
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FFWBI.
* Work bank indices (note that INDKTR is *NOT* a work bank index!)
      PARAMETER (NWBI=10)
      COMMON /FFWBI/ INDRSX(2),INDX(2),INDKX(2),INDPUR
     &,              INDKTR,INDKTX,INDTPR
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*KEEP,FKINT.
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FTANG.
*     Statement functions for track angle corrections...
*     (assumes COMMON FRLORA present)
      REAL DRIFT
      FTANGR(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGR, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*
      FTANGP(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGP, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

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

      DO 100 JPL=1,JPLMAX
* No measurements yet
         LMES(JPL)   = .FALSE.
         ZPL(JPL)    = SBTAB(INDG1(IRP(JPL)),4,ICELSB(JPLFT(JPL))+1)
         LTRPL(JPL)  = .TRUE.
         LTRPLD(JPL) = .TRUE.
 100  CONTINUE

*
* Loop over hits, filling the common blocks
*

      LFAILP = .TRUE.
      LFAILR = .FALSE.

      NRAD  = IBTAB(INDPUR,1,JTR)
      JDIGR = IBTAB(INDPUR,2,JTR)
      NPLAN = IBTAB(INDPUR,3,JTR)
      JDIGP = IBTAB(INDPUR,4,JTR)

      IF (NPLAN.GT.36) RETURN

      DO 200 IDIG=1,NPLAN
         IF (JDIGP.LE.0 .OR. JDIGP.GT.IW(INDX(1)+2)) RETURN
         CALL FFPLAN(JDIGP)
         JDIGP = IBTAB(INDX(1),1,JDIGP)
 200  CONTINUE

      IF (JDIGP.NE.IBTAB(INDPUR,4,JTR)) RETURN

      LFAILP = .FALSE.
      LFAILR = .TRUE.

      IF (NRAD.GT.36) RETURN

      DO 300 IDIG=1,NRAD
         IF (JDIGR.LE.0 .OR. JDIGR.GT.IW(INDX(2)+2)) RETURN
         CALL FFRAD(JDIGR,NPLAN)
         JDIGR = IBTAB(INDX(2),1,JDIGR)
 300  CONTINUE

      IF (JDIGR.EQ.IBTAB(INDPUR,2,JTR)) LFAILR = .FALSE.

      RETURN
      END
*CMZ :  8.06/00 14/11/96  22.45.22  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.40  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  7.01/00 22/06/95  15.52.15  by  Stephen Burke
*CMZU:  6.00/14 07/03/95  17.28.40  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.08.52  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Calculate the event T0 correction.
*
*HTMLI     : Describe the Input variables to the routine
*
* BEAZ bank (nominal z-vertex)
* CJKV bank (CJC z-vertex)
*
*HTMLO     : Describe the Output of the routine
*
* DEVT0 - event T0 correction (in nsec)
* ZNOM  - nominal z vertex
* VXYZ  - event vertex position (3-vector)
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFEVT0(DEVT0,ZNOM,VXYZ)
**********************************************************************
*                                                                    *
* Calculate the event T0 correction (no e-bunch timing correction    *
* at the moment)                                                     *
*                                                                    *
* OUTPUT:                                                            *
*   DEVT0 is the event T0 correction                                 *
*   ZNOM is the nominal z vertex                                     *
*   VXYZ is the event vertex position                                *
*                                                                    *
**********************************************************************

      DIMENSION VXYZ(3)

* c = 30 cm/nsec
      PARAMETER (VTOF=30.0)

      SAVE IRUN,ZNOMS

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKPROJ.
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*KEEP,FKINT.
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FTANG.
*     Statement functions for track angle corrections...
*     (assumes COMMON FRLORA present)
      REAL DRIFT
      FTANGR(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGR, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*
      FTANGP(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGP, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

      DATA IRUN/-999999/,ZNOMS/0./

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

      IF (IRUN.NE.NCCRUN) THEN
         IRUN = NCCRUN
* Get the nominal z-vertex if available
         INBEAZ = IABS(MDB('BEAZ'))
         IF (INBEAZ.GT.0) ZNOMS = RBTAB(INBEAZ,2,1)
      ENDIF
      ZNOM = ZNOMS

* The nominal interaction point is deemed to be at x=y=0
      CALL VZERO(VXYZ,2)
      VXYZ(3) = ZNOM

* If the CJC has found a vertex, use it
C      INVERT = NLINK('CTKV',0)
* Lose dependence on CTREC to aid reprocessing
      INVERT = 0
      IF (INVERT.LE.0) INVERT = NLINK('CJKV',0)
      IF (INVERT.GT.0) THEN
         JPRIM = 0
         NVERT = IW(INVERT+2)
         DO 100 JVERT=1,NVERT
            JTYPE = IBTAB(INVERT,9,JVERT)
            IF (JTYPE.EQ.1 .AND. JPRIM.LE.0) JPRIM  = JVERT
 100     CONTINUE
* If the error is bigger than 50 cm its not worth doing
         IF (JPRIM.GT.0 .AND. RBTAB(INVERT,6,JPRIM).LT.50.)
     &      CALL UCOPY(IW(INDCR(INVERT,1,JPRIM)),VXYZ,3)
      ENDIF

* Event T0 correction
      DEVT0 = (VXYZ(3) - ZNOM)/VTOF

      RETURN
      END
*CMZ :  8.07/00 26/11/96  16.22.38  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.40  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  7.03/06 04/12/95  16.19.37  by  Stephen Burke
*CMZU:  7.01/00 22/06/95  15.52.15  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.08.52  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Calculate the drift corrections for track angle, time-of-flight,
* signal propagation time and magnetic field variation.
*
*HTMLI     : Describe the Input variables to the routine
*
* JPL   - z plane number (1 to 72)
* SVEC  - state vector at plane JPL (REAL*8)
* ZNOM  - nominal z vertex
* VXYZ  - event vertex position (3-vector)
* DEVT0 - event T0 correction
* BZ    - the z component of the field
*
* FPLC/FRLC banks (unpacked hits)
*
* Information in various Kalman filter common blocks
*
* Various parameters are hardwired
*
*HTMLO     : Describe the Output of the routine
*
* DCORR - total correction to the drift distance
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFCORR(JPL,SVEC,ZNOM,VXYZ,DEVT0,BZ,DCORR)
**********************************************************************
*                                                                    *
* Calculate the corrections for track angle, time-of-flight,         *
* signal propagation time and magnetic field variation.              *
*                                                                    *
* INPUT:                                                             *
*   JPL is the plane number                                          *
*   SVEC is the state vector at plane JPL                            *
*   ZNOM is the nominal z vertex                                     *
*   VXYZ is the event vertex position                                *
*   DEVT0 is the event T0 correction                                 *
*   BZ is the z component of the field
*                                                                    *
* OUTPUT:                                                            *
*   DCORR is the correction to the drift distance                    *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION SVEC(5)
      DIMENSION VXYZ(3),R(3)

* Estimates for Vdrift from SJM for '94 running; variation is less than 1%
      PARAMETER (VDRFTP=0.003234,VDRFTR=0.003749)
* Nominal drift velocity = 35 km/sec; c = 30 cm/nsec
      PARAMETER (VDRIFT=0.0035,VTOF=30.0,VPROP=30.0)
* Some nominal geometry
      PARAMETER (ZPNOM=175.0,ZRNOM=200.0,RPLAN=80.0,RPMID=60.0)
* Nominal magnetic field
      PARAMETER (BPNOM=11.5634,BRNOM=11.5875)
* Estimates for radial Lorenz angle from SJM for '94 running; error is 10%
      PARAMETER (S2LORP=0.4132,S2LORR=0.3663)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKPROJ.
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*KEEP,FKINT.
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FTANG.
*     Statement functions for track angle corrections...
*     (assumes COMMON FRLORA present)
      REAL DRIFT
      FTANGR(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGR, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*
      FTANGP(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGP, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

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

*
* Time-of-flight correction
*

      R(1) = SVEC(1)
      R(2) = SVEC(2)
      R(3) = ZPL(JPL)
* This is rather arbitrary ...
      IF (IRP(JPL).EQ.1) THEN
         ZMID  = ZPNOM - ZNOM
         DTOF  = VDRFTP*(ZMID - VDIST(R,VXYZ,3))/VTOF
         DDEVT = VDRFTP*DEVT0
      ELSE
         ZMID  = ZRNOM - ZNOM
         DTOF  = VDRFTR*(ZMID - VDIST(R,VXYZ,3))/VTOF
         DDEVT = VDRFTR*DEVT0
      ENDIF

*
* Track-angle correction
*

      SINWP = HMES(2,2,JPL)
      COSWP = HMES(2,1,JPL)
      TANTH = SVEC(4)
      PHI   = SVEC(5)
      JDIG  = ABS(IDIGI(JPL))
      DRIFT = RBTAB(INDLC(IRP(JPL)),2,JDIG)
      IF (IRP(JPL).EQ.1) THEN
         DTRANG = FTANGP(DRIFT,TANTH,PHI,SINWP,COSWP)
      ELSE
         DTRANG = FTANGR(DRIFT,TANTH,PHI,SINWP,COSWP)
      ENDIF
* Allow for negative drifts!
      IF (DTRANG.LT.0.) DTRANG = 0.

*
* Propagation time correction (planars only)
*

      IF (IRP(JPL).EQ.1) THEN
* Predicted (absolute) drift and radius
         W  = ABS(SINWP*R(1) - COSWP*R(2))
         RR = COSWP*R(1)+ SINWP*R(2)
         IF (W.LT.RPLAN) THEN
            CORD = SQRT(RPLAN**2 - W**2)
         ELSE
            CORD = 0.0
         ENDIF
         IWCELL = IPWCL(IBTAB(INDLC(1),1,JDIG))
         IF (IWCELL.GT.15) THEN
            SIGN = -1.0
         ELSE
            SIGN = 1.0
         ENDIF
         DPROP = VDRFTP*(RPMID - CORD - SIGN*RR)/VPROP
      ELSE
         DPROP = 0.
      ENDIF

*
* Magnetic field correction
*
      IF (IRP(JPL).EQ.1) THEN
         BMID = BPNOM - BZ
         BRAT = BMID*S2LORP/BPNOM
      ELSE
         BMID = BRNOM - BZ
         BRAT = BMID*S2LORR/BRNOM
      ENDIF
      DDBF = DRIFT*BRAT

      DCORR = DDEVT + DTOF + DTRANG + DPROP + DDBF

      IF (IHFF/1000.LE.0) RETURN

      CALL HFILL(100+IRP(JPL),DTRANG,0.,1.)
      TRANG = 1. + TANTH**2*(SIN(PHI)*COSWP - COS(PHI)*SINWP)**2
      IF (TRANG.GE.1.) THEN
         TRANG = ACOS(1./SQRT(TRANG))
      ELSE
         TRANG = -1.
      ENDIF
      CALL HFILL(102+IRP(JPL),TRANG,0.,1.)
      CALL HFILL(105,DDEVT,0.,1.)
      CALL HFILL(105+IRP(JPL),DTOF,0.,1.)
      IF (IRP(JPL).EQ.1) CALL HFILL(108,DPROP,0.,1.)
      CALL HFILL(108+IRP(JPL),DDBF,0.,1.)
      CALL HFILL(110+IRP(JPL),BMID,0.,1.)
      CALL HFILL(112+IRP(JPL),DCORR,0.,1.)

      RETURN
      END
*CMZ :  8.05/01 02/10/96  21.17.40  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZU:  5.03/00 28/10/94  12.08.52  by  Stephen Burke
*-- Author : Stephen Burke
*
*HTMLP*    : Describe the Purpose of the routine
*
* Set up the "starting vector" for the Kalman filter from the pattern
* recognition output.
*
*HTMLI     : Describe the Input variables to the routine
*
* SSTART - the initial state vector (REAL*8 5-vector)
* CSTART - the covariance matrix (REAL*8 5*5 matrix)
* ZSTART - the z coordinate of the starting vector (REAL*8)
*
* Information in various Kalman filter common blocks
*
*HTMLO     : Describe the Output of the routine
*
* Various common blocks are filled with the position of the start and
* end points and the starting vector.
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFSTART(SSTART,CSTART,ZSTART)
**********************************************************************
*                                                                    *
* Set up the starting vector for the Kalman filter                   *
*                                                                    *
* SSTART and CSTART give the initial state vector, and its           *
* covariance, at z = ZSTART.                                         *
*                                                                    *
**********************************************************************

      DOUBLE PRECISION SSTART(5),CSTART(5,5),ZSTART
      DOUBLE PRECISION DZ,DTRAN(5,5),CTEMP(5,5)

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKCNTL.
      COMMON /FKCNTL/ LUN,IPR,ITR,IPL,JSTART,JSTOP,JLAST,JSTEP
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FKCONS.
      DOUBLE PRECISION ZPL,DZPL,RADL
      COMMON /FKCONS/ ZPL(NPL),DZPL(NPL),RADL(NPL)
*KEEP,FKPROJ.
*KEEP,FKSMTH.
*KEEP,FKRSID.
*KEEP,FKTRUE.
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FFDBG.
      CHARACTER*5 CFDBG
      CHARACTER*6 CFKDBG
      PARAMETER (CFDBG='FFDBG',CFKDBG='FFKDBG')
      PARAMETER (NTRACK=1000)
      COMMON /FFDBG/ ITRTR(2,NTRACK),ITRNF(5,NTRACK),JTRTR
*KEEP,FKDBG.
*KEEP,FKINT.
*KEEP,FRLORA.
      REAL            ATLORR, ATLORP, DTANGR, DTANGP
      COMMON /FRLORA/ ATLORR, ATLORP, DTANGR, DTANGP
*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,CNSTBF.
      INTEGER   LW(NBOSIW)
      REAL      SW(NBOSIW)
      EQUIVALENCE (RW(1),IW(1),LW(1),SW(1))
*KEEP,FTANG.
*     Statement functions for track angle corrections...
*     (assumes COMMON FRLORA present)
      REAL DRIFT
      FTANGR(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGR, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*
      FTANGP(DRIFT, TANT, PHI, SINWP, COSWP)  =
     +        MIN(DTANGP, DRIFT) * ( SQRT( 1.0 +
     +        ((SIN(PHI) * COSWP - COS(PHI) * SINWP)**2) *
     +        (TANT**2)) - 1.0)
*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,STFCLW.
* statement functions acting on the BOS COMMON LW
*     index of element before row number LWROW
      LNDR(LND,LWROW) = LND + 2 + LW(LND+1)*(LWROW-1)
*     index of L-th element of row number LWROW
      LNDCR(LND,L,LWROW)=LNDR(LND,LWROW)+L
*     L-th integer element of the LWROW'th row in bank with index LND
      LBTAB(LND,L,LWROW)=LW(LNDCR(LND,L,LWROW))
*     L-th real element of the LWROW'th row in bank with index LND
      SBTAB(LND,L,LWROW)=SW(LNDCR(LND,L,LWROW))
*
*KEEP,FTFUNCT.
*     Statement functions for RADIAL Chamber data access.
*     Using Channel Number J

*     Module, Wedge-pair and Z-plane numbers...
      IRMOD(J) = J/288
      IRWDP(J) = (J-IRMOD(J)*288)/12
      IRZPL(J) =  J-IRMOD(J)*288-IRWDP(J)*12
*     Statement function for obtaining WEDGE numbers(0-47) of
*     wires at plus and minus ends of Cell numbers
      IRWPL(J) = (IRWDP(J)/2)*4 + (MOD(IRWDP(J),2))
      IRWMI(J) = MOD(IRWPL(J) + 34,48)
*     Statement function for obtaining IOS wire number (1-36)
      IRIOSW(J) = IRMOD(J)*12 + IRZPL(J) + 1

*     Statement functions for PLANAR Chamber data access.
*     Using Channel Number J

*     Module, orientation, W-cell and Z-plane numbers...
      IPMOD(J)  = J/384
      IPORI(J)  = (J-IPMOD(J)*384)/128
      IPWCL(J)  = (J-IPMOD(J)*384-IPORI(J)*128)/4
      IPZPL(J)  = (J-IPMOD(J)*384-IPORI(J)*128-IPWCL(J)*4)

*     IPSMD in range 0:8 Planar module number.
      IPSMD(J)  = IPMOD(J)*3 + IPORI(J)
*
*     IOS wire number (runs from 0 to 36)
      IPIOSW(J) = IPSMD(J)*4 + IPZPL(J) + 1

* SB plane numbers (1-72) from cell number
      IPSBW(J) = 24*IPMOD(J) + 4*IPORI(J) + IPZPL(J) + 1
      IRSBW(J) = 24*IRMOD(J)              + IRZPL(J) + 13

* Module, orientation, wire and (typical) cell number from plane
* number in the range 1-72 (planars, radials and combined)
      IPMSB(J)  = (J - 1)/24
      IPOSB(J)  = (J - 24*IPMSB(J) - 1)/4
      IPZSB(J)  = J - 24*IPMSB(J) - 4*IPOSB(J) - 1
      IPCLSB(J) = 384*IPMSB(J) + 128*IPOSB(J) + IPZSB(J)

      IRMSB(J)  = (J - 1)/24
      IRZSB(J)  = J - 24*IRMSB(J) - 13
      IRCLSB(J) = 288*IRMSB(J) + IRZSB(J)

      IRADSB(J) = (J - 24*((J-1)/24) - 1)/12
      ICELSB(J) = IRADSB(J)*IRCLSB(J) + (1 - IRADSB(J))*IPCLSB(J)
*KEND.

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

* Set up the start and end points
      IF (LPOINT .OR. LBLOCK) THEN
         JSTOP = 1
         JLAST = JPLMAX
      ELSE
         JSTOP = 0
         DO 100 JPL=1,JPLMAX
            IF (LMES(JPL)) THEN
               IF (JSTOP.EQ.0) JSTOP = JPL
               JLAST = JPL
            ENDIF
 100     CONTINUE
      ENDIF

      IF (LRISV) THEN
         JSTART = JFTPL(JPLRSV)
         IF (JSTART.LE.0) THEN
            CALL ERRLOG(391,'F:FFSTART: Starting plane mapped out')
            JSTART = JPLMAX/2
         ENDIF
      ELSE
         JSTART = JSTOP
      ENDIF

* Swim to 1st plane (ignoring MS)
      DZ = ZPL(JSTART) - ZSTART
      CALL FKTRAN(DZ,ZSTART,SSTART,SPRO(1,JSTART),DTRAN)
      CALL FKMUL(CSTART,DTRAN,CPRO(1,1,JSTART))

      LPRO(JSTART) = .TRUE.

      IF (LRISV) RETURN

* Fix for low-momentum tracks
      FAC = 1.
      IF (ABS(SPRO(3,JSTART)).GT.1.0) THEN
         FAC = FAC + (ABS(SPRO(3,JSTART)) - 1.0)*10.0
         IF (FAC.GT.100.) FAC = 100.
      ENDIF

* Starting errors - these are just fixed at the moment
      CALL UCOPY(CPRO(1,1,JSTART),CTEMP,50)
      CALL VZERO(CPRO(1,1,JSTART),50)

      CPRO(1,1,JSTART) = MAX(CTEMP(1,1),DBLE(DSX**2))
      CPRO(2,2,JSTART) = MAX(CTEMP(2,2),DBLE(DSY**2))
      CPRO(3,3,JSTART) = MAX(CTEMP(3,3),DBLE(DSQOP**2))*FAC**2
      CPRO(4,4,JSTART) = MAX(CTEMP(4,4),DBLE(DSTTH**2))
      CPRO(5,5,JSTART) = MAX(CTEMP(5,5),DBLE(DSPHI**2))

      RETURN
      END
*CMZ :  8.07/00 03/12/96  21.46.44  by  Stephen Burke
*CMZ :  8.06/00 11/11/96  18.56.00  by  Stephen Burke
*CMZ :  8.05/01 02/10/96  21.17.40  by  Stephen Burke
*CMZ :  8.04/00 27/06/96  20.28.22  by  Stephen Burke
*CMZ :  7.11/00 07/04/96  17.19.35  by  Stephen Burke
*CMZU:  7.03/03 29/11/95  18.33.42  by  Stephen Burke
*CMZU:  7.02/11 27/10/95  21.04.18  by  Stephen Burke
*CMZU:  7.02/00 12/08/95  17.58.00  by  Stephen Burke
*CMZ :  7.00/00 10/04/95  11.07.59  by  G. Raedel
*-- Author :    Stephen Burke   13/03/95
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fill monitoring histograms made per hit.
*
*HTMLI     : Describe the Input variables to the routine
*
* J1   - the z plane number (1 to 72) of the first hit on the track
* J2   - the z plane number (1 to 72) of the last hit on the track
* NPS  - the number of planar segments
* IMAP - the supermodule map (as in FTKR word 20)
*
* Information in various Kalman filter common blocks
*
*HTMLO     : Describe the Output of the routine
*
* Histograms are filled
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFHTHS(J1,J2,NPS,IMAP)
**********************************************************************
*                                                                    *
* Fill per-hit monitoring histograms                                 *
*                                                                    *
* J1 and J2 are the indices of the first and last planes with hits   *
* NPS is the number of planar segments                               *
* IMAP is the supermodule map                                        *
*                                                                    *
**********************************************************************

      DIMENSION DD(4),WW(4)
* sin and cos of the wedge angle
      DATA SPHIW/0.1305261922201/,CPHIW/0.9914448613738/
      SAVE SPHIW,CPHIW

*KEEP,FKNPL.
      CHARACTER*5 CKDBG
      PARAMETER (CKDBG='FKDBG')
      PARAMETER (NPL=72)
      LOGICAL LTRUE,LFIRST,LTRPL,LTRPLD
      DOUBLE PRECISION TRUE,RTRUE,CHITRU,SPRO,CPRO,SFIL,CFIL
     &,                SSMT,CSMT,SSMTR,CSMTR,DPRO,CBPRO,QPRO,QGAIN
     &,                RPRO,CRPRO,RFIL,CRFIL,RSMT,CRSMT,CHIFIL,CHISMT
*
* Per-track values can go in H1WORK; note that LTRUE and LFIRST must
* be set at least per event.
*
* This is about 36k words long; the remaining common blocks are
* about 3.6k in total. Some of this could be in /H1WORK/, but the
* blocks would have to be reorganised.
*
      COMMON /H1WORK/
* /FKPROJ/
     &                SPRO(5,NPL),CPRO(5,5,NPL)
* /FKFILT/
     &,               SFIL(5,NPL),CFIL(5,5,NPL)
* /FKSMTH/
     &,               SSMT(5,NPL),CSMT(5,5,NPL)
     &,               SSMTR(5,NPL),CSMTR(5,5,NPL)
* /FKINT/
     &,               DPRO(5,5,NPL),CBPRO(5,5,NPL),QPRO(5,5,NPL)
     &,               QGAIN(5,5,NPL),IAPROX,LFIRST
* /FKRSID/
     &,               RPRO(2,NPL),CRPRO(2,2,NPL),RFIL(2,NPL)
     &,               CRFIL(2,2,NPL),RSMT(2,NPL),CRSMT(2,2,NPL)
     &,               CHIFIL(NPL),CHISMT(NPL)
* /FKTRUE/
     &,               TRUE(5,NPL),RTRUE(5,NPL),CHITRU(NPL),LTRUE
* /FKDBG/
     &,               LTRPL(NPL),LTRPLD(NPL)
*KEEP,FKFLAG.
      LOGICAL LPRO,LFIL,LSMT,LMES,LRAD,LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
      COMMON /FKFLAG/ LPRO(NPL),LFIL(NPL),LSMT(NPL),LMES(NPL)
     &,               LRAD(NPL),LRPRO,LRFIL,LRSMT,LPOINT,LBLOCK
*KEEP,FFSTEE.
      PARAMETER (NFT=72)
      LOGICAL LRISV,LWMAP,LGRAPH,LTRUTH
      REAL DSX,DSY,DSQOP,DSTTH,DSPHI,PMCUT,PCUT,CHPCUT
     &,    QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
      COMMON /FFSTEE/ DSX,DSY,DSQOP,DSTTH,DSPHI
     &,               PMCUT,IDIAG,JPLRSV,LRISV,LWMAP(NFT),JPLMAX
     &,               IRP(NPL),JPLFT(NPL),JFTPL(NFT)
     &,               LUNGKS,IWKGKS,IDGKS,LUNHB,LUNGKM,IWKGKM,IDGKM
     &,               LGRAPH,LTRUTH,IHFF,IHFK,ISRJCT,PCUT,CHPCUT
     &,               QOPMAX,THEMAX,RFTMIN,RFTMAX,CEMAX
*KEEP,FKRSID.
*KEEP,FKMEAS.
      DOUBLE PRECISION WMES,CMES,HMES
      COMMON /FKMEAS/ WMES(2,NPL),CMES(2,2,NPL),HMES(2,2,NPL),MES(NPL)
*KEEP,FKSMTH.
*KEEP,FFGEO.
      COMMON /FFGEO/ INDG1(2),INDLC(2),IDIGI(NPL)
*KEEP,FTHIST.
* indices of filter farm histos
      COMMON/FTHIST/IHP(100)
*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/
*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,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.

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

      IPREV  = 0
      ICELL  = 0
      MASK   = 0
      MASK2  = 0
      ISLAST = 0

      DO 100 JPL=J1,J2
         IF (LMES(JPL)) THEN
            IPREV = IPREV + 1
            II    = IRP(JPL)
            JDIG  = ABS(IDIGI(JPL))
            IF (MOD(NEVENT,10).EQ.0) THEN
* Drift residuals
               CALL SHS(3+II,0,SNGL(RSMT(1,JPL)))
               IF (NPS.GT.1) CALL SHS(74+II,0,SNGL(RSMT(1,JPL)))
* Radius residuals for all hits, not just "good" ones
C               IF (MES(JPL).EQ.2) CALL SHS(6,0,SNGL(RSMT(2,JPL)))
               IF (II.EQ.2) THEN
                  RRES = WMES(2,JPL) - HMES(2,1,JPL)*SSMT(1,JPL)
     &                               - HMES(2,2,JPL)*SSMT(2,JPL)
                  CALL SHS(6,0,RRES)
               ENDIF
* Residuals vs. Q
               IF (II.EQ.1) THEN
                  Q = RBTAB(INDLC(1),5,JDIG)
                  CALL SHD(68,0,SNGL(RSMT(1,JPL)),Q)
               ELSE
                  Q = RBTAB(INDLC(2),7,JDIG)
     &              + RBTAB(INDLC(2),8,JDIG)
                  CALL SHD(69,0,SNGL(RSMT(1,JPL)),Q)
C                  IF (MES(JPL).EQ.2) CALL SHD(70,0,SNGL(RSMT(2,JPL)),Q)
                  CALL SHD(70,0,RRES,Q)
               ENDIF
            ENDIF
* Unpack drift sign and hit number
            ISGN = 0
            IF (IDIGI(JPL).LT.0) ISGN = 1
            IWR = MOD(JPL,4)
            IF (IWR.EQ.0) IWR = 4
            IC = IBTAB(INDLC(II),1,JDIG)
            IF (IPREV.NE.1 .AND. IC.NE.ICELL+1) IPREV = 0
            IF (IWR.EQ.1) THEN
               CALL SBIT1(MASK,IWR)
            ELSEIF (IWR.EQ.3 .AND. IC.NE.ICELL+1) THEN
               CALL SBIT1(MASK,IWR)
            ELSEIF (IWR.NE.3 .AND. IC.EQ.ICELL+1) THEN
               CALL SBIT1(MASK,IWR)
            ENDIF
            IF (IWR.EQ.1) THEN
               CALL SBIT1(MASK2,IWR)
            ELSEIF (IWR.EQ.3 .AND. ISGN.NE.ISLAST) THEN
               CALL SBIT1(MASK2,IWR)
            ELSEIF (IWR.NE.3 .AND. ISGN.EQ.ISLAST) THEN
               CALL SBIT1(MASK2,IWR)
            ENDIF
            ICELL  = IC
            ISLAST = ISGN
* Corrected drift distance
            DD(IWR) = RBTAB(INDLC(II),3+ISGN+3*II,JDIG)
            IF (MOD(NEVENT,10).EQ.0) THEN
               IF (II.EQ.1) THEN
                  CALL SHS(77,0,DD(IWR)*(-1)**ISGN)
               ELSEIF (WMES(2,JPL).GT.30. .AND. WMES(2,JPL).LT.40.) THEN
                  CALL SHS(78,0,DD(IWR)*(-1)**ISGN)
               ENDIF
               DUNC = RBTAB(INDLC(II),2,JDIG)
               IF (DUNC.LT.0.5) CALL SHS(82+II,0,SNGL(RSMT(1,JPL)))
            ENDIF
* Absolute drift coordinate
            WW(IWR) = WMES(1,JPL)
* Checksums (4 wire groups)
            IF (IWR.EQ.4) THEN
               C2W = 0.75*(WW(3) - WW(2)) - 0.25*(WW(4) - WW(1))
               IF (WW(4).LT.WW(1)) C2W = -C2W
               IF (IPREV.EQ.4) THEN
                  C1 = DD(2) - DD(1) - DD(4) + DD(3)
                  C2 = 0.75*(DD(3) - DD(2)) - 0.25*(DD(4) - DD(1))
                  CALL SHS(77+2*II,0,C1)
                  IF (ABS(C1).LT.0.1) CALL SHS(78+2*II,0,C2)
                  IF (MASK2.EQ.15) CALL SHS(86+II,0,C2W)
               ENDIF
               IF (MASK.EQ.15) THEN
                  IF (II.EQ.2) THEN
                     RR = SQRT(SSMT(1,JPL)**2 + SSMT(2,JPL)**2)
                     WW(3) = SIGN((RR - WW(3)**2/RR)*SPHIW -
     &                            ABS(WW(3))*CPHIW,-WW(3))
                     RR = SQRT(SSMT(1,JPL-1)**2 + SSMT(2,JPL-1)**2)
                     WW(4) = SIGN((RR - WW(4)**2/RR)*SPHIW -
     &                            ABS(WW(4))*CPHIW,-WW(4))
                     C2W = 0.75*(WW(3) - WW(2)) - 0.25*(WW(4) - WW(1))
                     IF (WW(4).LT.WW(1)) C2W = -C2W
                  ENDIF
                  CALL SHS(88+II,0,C2W)
               ENDIF
            ENDIF
* The rest are debug only
            IF (IDB.GT.1) THEN
* Residuals vs. supermodule map
               CALL SHD(64+II,0,SNGL(RSMT(1,JPL)),FLOAT(IMAP))
               IF (MES(JPL).EQ.2)
     &            CALL SHD(67,0,SNGL(RSMT(2,JPL)),FLOAT(IMAP))
            ENDIF
         ENDIF
         IF (MOD(JPL,4).EQ.0) THEN
            IPREV = 0
            MASK  = 0
            MASK2 = 0
         ENDIF
 100  CONTINUE

      RETURN
      END
*CMZ :  8.07/00 26/11/96  16.15.07  by  Stephen Burke
*-- Author :    Stephen Burke   26/11/96
*
*HTMLP*    : Describe the Purpose of the routine
*
* Fast version of FKTRAN: translates track parameters from one z
* plane to another. There is no calculation of the Jacobian, and
* the z distance over which the field is assumed constant (DZMAX)
* is 10 cm instead of 1 cm, but otherwise this is the same as
* FKTRAN. Bz is returned for use in FFCORR.
*
*HTMLI     : Describe the Input variables to the routine
*
* DZ - step length in cm (can be negative) (REAL*8)
* Z1 - Z coordinate of starting point in cm (REAL*8)
* S1 - (X,Y,q/P,Tan(Theta),Phi) = state vector at Z1 (REAL*8 5-vector)
*
*HTMLO     : Describe the Output of the routine
*
* S2    - state vector at Z1+DZ (REAL*8 5-vector)
* BZEND - z component of field at track end
*
* Note that S2 should not be the same as S1
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FFTRF(DZ,Z1,S1,S2,BZEND)
**********************************************************************
*                                                                    *
*  Transform track vector (S1) through DZ to (S2) in magnetic field. *
*                                                                    *
*  The field in kG must be supplied through call to GUFLD, and       *
*  is assumed to satisfy   |Bz| >> SQRT( Bx**2 + By**2 )  and        *
*                          |B2-B1| << |B1|                           *
*  ie that the field is constant and aligned with the +/- Z axis.    *
*  A helix track model is used to compute S2. First order            *
*  corrections are applied if necessary:                             *
*                                                                    *
*       IAPROX = 1 -> Straight line extrapolation (unused)           *
*       IAPROX = 2 -> As 1 for x and y, but Delta phi varying        *
*       IAPROX = 3 -> Helix model. Bz=constant, Bx = By = 0 (unused) *
*       IAPROX = 4 -> 1st order corrections assuming Bx and By are   *
*                     small but constant across DZ.                  *
*       IAPROX = 5 -> as 4 plus 1st order corrections for change     *
*                     in field along trajectory.                     *
*                                                                    *
* INPUT;   DZ    = step length in cm (can be negative)               *
*          Z1    = Z coordinate of starting point in cm              *
*          S1    = (X,Y,q/P,Tan(Theta),Phi) = state vector at Z1     *
*                                                                    *
* OUTPUT;  S2    = state vector at Z1 + DZ                           *
*          BZEND = Bz at track end                                   *
*                                                                    *
**********************************************************************

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      REAL R(3),R2(3),B2(3),DB(3),BR(3),BZEND
      DIMENSION S1(5),S2(5)

*KEEP,FKPIDP.
      DOUBLE PRECISION PI,TWOPI,PIBY2
      PARAMETER (PI=3.141592653589793238)
      PARAMETER (TWOPI=PI*2.0D0,PIBY2=PI/2.0D0)
*KEND.

      PARAMETER (BFACT=2.997886E-4)

**********************************************************************
*
* Thresholds for various approximations (*** UNOPTIMISED ***)
*

* Max z step over which field is assumed constant
      PARAMETER (DZMAX=1.0D1)
* If Dphi <E-3 errors in sin/cos are <E-6, and in dx/dy are <1 micron
      PARAMETER (DPHMAX=3.0D-2,DPHMX2=1.0D-3)
* Minimum significant changes in x/y for straight line approx
      PARAMETER (DXYMIN=1.0D-3)
* Min change in tan(theta) which is considered significant
      PARAMETER (DTTMIN=1.0D-3)

**********************************************************************
*
* Some parameters are remembered, as they may not need recalculating
*

      SAVE PHIR,CPHIR,SPHIR
      SAVE TTR,OPTSQ,SECT
      SAVE ZR,BR

      DATA PHIR/0.D0/,CPHIR/1.D0/,SPHIR/0.D0/
      DATA TTR/0.D0/,OPTSQ/1.D0/,SECT/1.D0/
      DATA ZR/-1.D6/

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

* S2 = S1 + corrections ...
      S2(1) = S1(1)
      S2(2) = S1(2)
      S2(3) = S1(3)
      S2(4) = S1(4)
      S2(5) = S1(5)

* Work out cos/sin phi, using remembered value if appropriate
      DPHI = S1(5) - PHIR
      IF (DABS(DPHI).LT.DPHMX2) THEN
* Change in phi is negligible
         CPHI1 = CPHIR
         SPHI1 = SPHIR
      ELSEIF (DABS(DPHI).LT.DPHMAX) THEN
* Small angle approximations for cos and sin (to order DPHI**2)
         CDPHI = 1.D0 - 0.5D0*DPHI*DPHI
         SPHI1 = SPHIR*CDPHI + CPHIR*DPHI
         CPHI1 = CPHIR*CDPHI - SPHIR*DPHI
      ELSE
* Full expressions
         CPHI1 = DCOS(S1(5))
         SPHI1 = DSQRT(1.D0 - CPHI1*CPHI1)
         IF (S1(5).GT.PI) SPHI1 = -SPHI1
* Remember values
         PHIR  = S1(5)
         CPHIR = CPHI1
         SPHIR = SPHI1
      ENDIF

* See whether we need to calculate various functions of theta
      IF (DABS(S1(4)-TTR).LT.DTTMIN) THEN
* Old values will do
         DZSECT = DZ*SECT
      ELSE
* Theta has changed so must recalculate
         OPTSQ  = 1.D0 + S1(4)*S1(4)
         SECT   = SQRT(OPTSQ)
         DZSECT = DZ*SECT
         TTR    = S1(4)
      ENDIF

      IF (ABS(Z1-ZR).GT.DZMAX) THEN
* Get the field
         R(1) = S1(1)
         R(2) = S1(2)
         R(3) = Z1
         CALL GUFLD(R,BR)
         IF (ABS(BR(3)).LT.0.01) BR(3) = SIGN(0.01,BR(3))
         ZR = Z1
      ENDIF

* Work out Delta phi
      DPHI  = -DZSECT*BR(3)*BFACT*S1(3)
      S2(5) = S2(5) + DPHI

* Choose the order of approximation
      IF (DABS(DZ).GT.DZMAX) THEN
* Must consider change in field over DZ
         IAPROX = 5
      ELSEIF (DABS(DZ*DPHI).GT.DXYMIN) THEN
* Must take helix (x and y affected by dphi)
         IAPROX = 4
      ELSE
* Ignore change in phi for DX and DY
         S2(1)  = S2(1) + DZ*CPHI1*S1(4)
         S2(2)  = S2(2) + DZ*SPHI1*S1(4)
         GOTO 9100
      ENDIF

      IF (DABS(DPHI).LT.DPHMAX) THEN
* Small angle approximations for cos and sin (to order DPHI**2)
         DPHI2 = 0.5D0*DPHI
         CDPHI = 1.D0 - DPHI2*DPHI
         SPHI2 = SPHI1*CDPHI + CPHI1*DPHI
         CPHI2 = CPHI1*CDPHI - SPHI1*DPHI
         DXOTT = DZ*(CPHI1 - SPHI1*DPHI2)
         DYOTT = DZ*(SPHI1 + CPHI1*DPHI2)
      ELSE
* Full expressions
         CPHI2 = DCOS(S2(5))
         SPHI2 = DSIN(S2(5))
         FAC   = DZ/DPHI
         DXOTT = FAC*(SPHI2 - SPHI1)
         DYOTT = FAC*(CPHI1 - CPHI2)
* Remember values
         PHIR  = S2(5)
         CPHIR = CPHI2
         SPHIR = SPHI2
      ENDIF

* Change in x and y
      S2(1) = S2(1) + DXOTT*S1(4)
      S2(2) = S2(2) + DYOTT*S1(4)

*
* Apply 1st order corrections assuming that Bx and By are
* small but non-zero ........ (Bx,By,Bz) is still assumed
* to be constant across DZ ......
*

      DPHIOB = DZSECT*S1(3)*BFACT
      CON1   = DPHIOB*DZ*0.5D0
      CON2   = DPHIOB*OPTSQ
      IF (S1(4).NE.0.D0) THEN
         CON3 = DPHIOB/S1(4)
      ELSE
* If theta = 0, phi is undefined, so CON3 can be set to any value
         CON3 = 0.D0
      ENDIF

      S2(1) = S2(1) - CON1*BR(2)
      S2(2) = S2(2) + CON1*BR(1)
      S2(4) = S2(4) + CON2*(BR(1)*SPHI1 - BR(2)*CPHI1)
      S2(5) = S2(5) + CON3*(BR(1)*CPHI1 + BR(2)*SPHI1)

* Are corrections for field variation required?
      IF (IAPROX.LT.5) GOTO 9000

* Get field at end point ...
      B2(1) = BR(1)
      B2(2) = BR(2)
      B2(3) = BR(3)
      R2(1) = S2(1)
      R2(2) = S2(2)
      R2(3) = Z1 + DZ
      ZR    = Z1 + DZ
      CALL GUFLD(R2,BR)
      IF (ABS(BR(3)).LT.0.01) BR(3) = SIGN(0.01,BR(3))
      DB(1) = 0.5*(BR(1) - B2(1))
      DB(2) = 0.5*(BR(2) - B2(2))
      DB(3) = 0.5*(BR(3) - B2(3))

*
* DB is the mean difference from the assumed field along the trajectory,
* assuming the field components vary linearly with Z over DZ.
* ie B and dB/dZ are non-zero but  d2B/dZ2  etc are assumed zero.
*

      DBZTT = DB(3)*S1(4)

      S2(1) = S2(1) + CON1*(DBZTT*SPHI1 - DB(2))
      S2(2) = S2(2) + CON1*(DB(1) - DBZTT*CPHI1)
      S2(4) = S2(4) + CON2*(DB(1)*SPHI1 - DB(2)*CPHI1)
      S2(5) = S2(5) + CON3*(DB(1)*CPHI1 + DB(2)*SPHI1) - DPHIOB*DB(3)

 9000 CONTINUE

      IF (S2(4).LT.0.D0) THEN
         S2(4) = DABS(S2(4))
         S2(5) = S2(5) + PI
      ENDIF

 9100 CONTINUE

      IF (DABS(S2(5)).GT.TWOPI) S2(5)=DMOD(S2(5),TWOPI)
      IF (S2(5).LT.0.D0) S2(5) = S2(5) + TWOPI

* Stop values getting too large (i.e. stop overflows)
      IF (ABS(S2(1)).GT.1.D4) S2(1) = SIGN(1.D4,S2(1))
      IF (ABS(S2(2)).GT.1.D4) S2(2) = SIGN(1.D4,S2(2))
      IF (S2(4).GT.1.D6) S2(4) = 1.D6

      BZEND = BR(3)

      RETURN
      END
*CMZU:  8.04/00 10/07/96  10.56.53  by  Girish D. Patel
*CMZU:  7.09/01 06/02/96  13.59.09  by  Girish D. Patel
*CMZU:  7.04/00 11/01/96  11.10.54  by  Girish D. Patel
*CMZ :  7.01/04 02/08/95  11.01.46  by  Gaby Raedel
*CMZU:  7.00/12 13/06/95  11.10.15  by  Girish D. Patel
*CMZ :  5.02/05 23/09/94  09.45.26  by  R. Gerhards
*CMZ :  5.02/01 08/09/94  14.33.18  by  R. Gerhards
*CMZU:  5.01/06 18/05/94  16.10.04  by  Girish D. Patel
*-- Author :    John V. Morris   23/06/93

      SUBROUTINE FTDEOR(JRUN,IERR)
************************************************************************
*                                                                      *
*           F T D   E N D - O F - R U N   M O N I T O R I N G          *
*                                                                      *
*  This package is to run on the SGI to analyse histograms created     *
*  by L4 and L5 before they are logged. The whole patch is IF=ONLREC   *
*  and additional histograms are analysed for L5 by using the H1ENVI   *
*  flag to differentiate.                                              *
*                                                                      *
* The output from L4 analysis is LOOK ntuples stored in SAREA FTDMON 0 *
*                                                                      *
* The output from L5 analysis is LOOK ntuples stored in SAREA FTDMON 0 *
*                                                    &  SAREA FTRMON 0 *
*                                                    &  SAREA FPOKE  0 *
*                                                                      *
*                                                                      *
************************************************************************

************************************************************************
* This routine is to be called once from the offline SGI end-of-run    *
* job TCL. It assumes that the FTD monitoring histograms, produced     *
* on the farm, have been read in and converted to LOOK by the routine  *
* TOLOOK.                                                              *
* FTDEOR copies the histograms from LOOK into the corresponding HBOOK  *
* objects ( FLK2HB ) and end-of-run statistics from a LOOK histogram   *
* into the relevant statistics arrays and variables ( FQEND ).         *
* The standard FTDMON fitting and summary routines are then called to  *
* generate monitored/calibrated quantities, which can be output to     *
* LOOK output files as a permanent record of FTD performance history.  *
*                                                                      *
* IERR = 0 on return indicates no errors have been detected.           *
*      = -10 no histograms were found by FLK2HB!                       *
*      = -2 Histogram title mis-match                                  *
*      = -3 Histogram bins mis-match                                   *
*      = -4 Histogram slice mis-match                                  *
*      = -5 Histogram empty                                            *
*                                                                      *
* The following output files/data are generated and/or updated in this *
* version by the TCL job running on the SGI                            *
*                                                                      *
* (1) LOOK ntuple file containing run history (updated)                *
*     filename is /h1/log/LOOK.FTDMON    for L4                        *
*     filename is ???????????????????    for L5                        *
*                                                                      *
* GDP 16/8/94                                                          *
************************************************************************

*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEEP,FCOUNT.
      COMMON/FCOUNT/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FTQRUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FTQRUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEND.

      CHARACTER*8  NAMES(19),NAMEB(24),NAMEL(14),NAMEH(9),NAMEC(9)
      CHARACTER*8  NAMEV(18),NAMET(18),NAMEP(26),NAMEE(39)
      CHARACTER*8  NAMIT(4)
      CHARACTER*8  FNAME1(6),FNAMET(13),FNAMEE(6)
      CHARACTER*8  FNAMEA(8),FNAMEP(8),FNAMER(13),FNAMEB(5),FNAMEC(10)
      CHARACTER*8  NAMES1(8),NAMES2(8),NAMES3(8),NAMES4(8)
      DIMENSION AVEC(14),IOUT(6),FOUT(17)

      LOGICAL LEXIST
      CHARACTER*8 ARNAME
      LOGICAL FIRST /.TRUE./
      DATA NAMIT/'Run_numb','CompCODE','RadialHV','PlanarHV'/
      DATA NAMEL/'Run_numb','Date    ','Time    ','Min92   ','Pressure',
     +           'Totevs  ','Run_lumi','H1R_lumi','Run_time','Run_eff ',
     +           'ILRET   ','e_curr  ','p_curr  ','Bfield  '/
      DATA NAMES/'Events  ','Htspev  ','Clupev  ','Cpev_err','PERHts  ',
     +           'PHt_err ','V2pk    ','V2pk_err','Vdt     ','Vdt_err ',
     +           'Qmph    ','Qmph_err','Resol   ','Reso_err','Tzero   ',
     +           'Tzer_err','Weff    ','Weff_err','HVflag  '/
      DATA NAMEH/'HitspL0 ','HitspL1 ','Hitspl2 ','HitspL3 ','HitspL4 ',
     +           'HitspL5 ','HitspL6 ','Hitspl7 ','HitspL8 '/
      DATA NAMEC/'CluspL0 ','CluspL1 ','CluspL2 ','Cluspl3 ','CluspL4 ',
     +           'CluspL5 ','CluspL6 ','CluspL7 ','Cluspl8 '/
      DATA NAMET/'V2pkL0  ','V2pkL1  ','V2pkL2  ','V2pkL3  ','V2pkL4  ',
     +           'V2pkL5  ','V2pkL6  ','V2pkL7  ','V2pkL8  ',
     +           'V2L0_err','V2L1_err','V2L2_err','V2L3_err','V2L4_err',
     +           'V2L5_err','V2L6_err','V2L7_err','V2L8_err'/
      DATA NAMEV/'V2p0    ','V2p0_err','V2p1    ','V2p1_err','V2p2    ',
     +           'V2p2_err','Res0    ','Res0_err','Res1    ','Res1_err',
     +           'Res2    ','Res2_err','Qmt0    ','Qmt0_err','Qmt1    ',
     +           'Qmt1_err','Qmt2    ','Qmt2_err'/
      DATA NAMEB/'Weff_0  ','Qmph_0  ','Weff_1  ','Qmph_1  ','Weff_2  ',
     +           'Qmph_2  ','Weff_3  ','Qmph_3  ','Weff_4  ','Qmph_4  ',
     +           'Weff_5  ','Qmph_5  ','Weff_6  ','Qmph_6  ','Weff_7  ',
     +           'Qmph_7  ','Weff_8  ','Qmph_8  ','Weff_9  ','Qmph_9  ',
     +           'Weff_10 ','Qmph_10 ','Weff_11 ','Qmph_11 '/
      DATA NAMEP/'Vdtall  ','VdtM0   ','VdtM1   ','VdtM2   ',
     +           'VdtL0   ','VdtL1   ','VdtL2   ','VdtL3   ','VdtL4   ',
     +           'VdtL5   ','VdtL6   ','VdtL7   ','VdtL8   ',
     +           'Vdal_err','VdM0_err','VdM1_err','VdM2_err',
     +           'VdL0_err','VdL1_err','VdL2_err','VdL3_err','VdL4_err',
     +           'VdL5_err','VdL6_err','VdL7_err','VdL8_err'/
      DATA NAMEE/'Winall  ','WinM0   ','WinM1   ','Winm2   ','WinL0   ',
     +           'WinL1   ','WinL2   ','Winl3   ','Winl4   ','Winl5   ',
     +           'WinL6   ','Winl7   ','WinL8   ',
     +           'Winall_n','WinM0_n ','WinM1_n ','Winm2_n ','WinL0_n ',
     +           'WinL1_n ','WinL2_n ','Winl3_n ','Winl4_n ','Winl5_n ',
     +           'WinL6_n ','Winl7_n ','WinL8_n ',
     +           'Winall_f','WinM0_f ','WinM1_f ','Winm2_f ','WinL0_f ',
     +           'WinL1_f ','WinL2_f ','Winl3_f ','Winl4_f ','Winl5_f ',
     +           'WinL6_f ','Winl7_f ','WinL8_f '/
*
      DATA FNAME1/'Run_numb','Trks_evt','Phit_trk','Rhit_trk',
     +            'Phit_use','Rhit_use'/
      DATA FNAMEA/'Npeak   ','Peak_pos','Sigma   ','Integral',
     +            'Peak_hgt','bkg_sig ','Mean    ','RMSSigma' /
      DATA FNAMET/'Npeak   ','Peakpos1','Sigma1  ','Integrl1',
     +            'Peakhgt1','bkgsig1 ','Peakpos2','Sigma2  ',
     +            'Integrl2','Peakhgt2','bkgsig2 ','Mean    ',
     +            'RMSSigma'/
      DATA FNAMEE/'CheffP0 ','CheffR0 ','CheffP1 ','CheffR1 ',
     +            'CheffP2 ','CheffR2 '/
      DATA FNAMEP/'Tot_seg ','Hit_seg0',
     +            'Hit_seg1','Hit_seg2','9ht_seg ','10ht_seg',
     +            '11ht_seg','12ht_seg'/
      DATA FNAMER/'Tot_seg ','Hit_seg0',
     +            'Hit_seg1','Hit_seg2','4ht_seg ','5ht_seg ',
     +            '6ht_seg ','7ht_seg ','8ht_seg ','9ht_seg ',
     +            '10ht_seg','11ht_seg','12ht_seg'/
      DATA FNAMEB/'Hits_seg','9ht_seg ','10ht_seg','11ht_seg',
     +            '12ht_seg'/
      DATA FNAMEC/'Hits_seg','4ht_seg ','5ht_seg ','6ht_seg ',
     +            '7ht_seg ','8ht_seg ','9ht_seg ','10ht_seg',
     +            '11ht_seg','12ht_seg'/

      DATA NAMES1/
     +    'Run_numb','Events  ',
     +    'Vmean   ','dVmean  ',
     +    'Vf0r8   ','dVf0r8  ',
     +    'intercep','dinterc '/
      DATA NAMES2/
     +    'Vplus   ','dVplus  ',
     +    'Splus   ','dSplus  ',
     +    'Intplus ','dIplus  ',
     +    'Nopplus ','Chiplus '/
      DATA NAMES3/
     +    'Vminus  ','dVminus ',
     +    'Sminus  ','dSminus ',
     +    'Intminus','dIminus',
     +    'Nopminus','Chiminus'/
      DATA NAMES4/
     +    'TanLor  ','dTanLor ',
     +    'IntLor  ','dIntLor ',
     +    'AngLor  ','dAngLor',
     +    'NopLor  ','ChLor   '/
*
      NRUN0  = JRUN
*
      IF(FIRST) THEN
        FIRST = .FALSE.
        CALL H1ENVI(IFLAG,IPROC,NPROC)
        IL4L5 = IFLAG
*
        IF(IL4L5.NE.1 .AND. IL4L5.NE.2) THEN
          WRITE(6,*) ' ** WARNING **  FTDEOR called
     & but H1ENVI flag wrong',IL4L5
          RETURN
        ENDIF

      ELSE
        CALL HDELET(0)
      ENDIF
*
      IERR = 0
*
* general initialisation
      CALL FTQINT

* Book histograms ...
      CALL FBOOKQ

* Copy LOOK histograms into HBOOK ...
      IF(IL4L5.EQ.1) CALL SAREA('L4',NRUN0)
      IF(IL4L5.EQ.2) CALL SAREA('FTDSGI',0)
*
      CALL FLK2HB(NHIST,IER1)

      CALL SAREA('FTDMON',0)

*     Book n-tuples..
      IF(.NOT.LEXIST('VEC',2,0)) THEN
        CALL BNT( 2, 0,     4, NAMIT)
      ENDIF
      IF(.NOT.LEXIST('VEC',1,0)) THEN
        CALL BNT( 1, 0,    14, NAMEL)
        CALL BNT( 7, 0,     8,FNAMEA)
        CALL BNT( 8, 0,     8,FNAMEA)
        CALL BNT( 9, 0,    26, NAMEP)
        CALL BNT(10, 0,    39, NAMEE)
        CALL BNT(11, 0,    19, NAMES)
        CALL BNT(12, 0,     8, NAMEB)
        CALL BNT(13, 0,    18, NAMEV)
        CALL BNT(14, 0,     9, NAMEH)
        CALL BNT(15, 0,     9, NAMEC)
        CALL BNT(16, 0,    18, NAMET)
        CALL BHD  (17,0,32,-0.5,31.5,36,0.5,36.5)
        CALL SHD  (17,0,40.,40.)
        CALL STEXT(17 ,4,'FT Planar')
        CALL STEXT(17 ,1,'Dead Cell No vs Wire Plane')
        CALL BHDW (18,0,32,-0.5,31.5,36,0.5,36.5)
        CALL SHDW (18,0,40.,40.,1.)
        CALL STEXT(18 ,4,'FT Planar')
        CALL STEXT(18 ,1,'Cell No vs Wire Plane')
        CALL BHS  (19,0,101,0.0,1.01)
        CALL SHS  (19,0,-1.)
        CALL STEXT(19 ,4,'FT Planar')
        CALL STEXT(19 ,1,'Relative Efficiency')

        CALL BNT(20, 0,    39, NAMEE)
        CALL BNT(21, 0,    19, NAMES)
        CALL BNT(22, 0,    24, NAMEB)
        CALL BNT(23, 0,    18, NAMEV)
        CALL BNT(24, 0,     9, NAMEH)
        CALL BNT(25, 0,     9, NAMEC)
        CALL BNT(26, 0,    18, NAMET)
        CALL BHD  (27,0,48,-0.5,47.5,36,0.5,36.5)
        CALL SHD  (27,0,40.,40.)
        CALL STEXT(27 ,4,'FT Radial')
        CALL STEXT(27 ,1,'Dead Wedge Pair No vs Wire Plane')
        CALL BHDW (28,0,48,-0.5,47.5,36,0.5,36.5)
        CALL SHDW (28,0,40.,40.,1.)
        CALL STEXT(28 ,4,'FT Radial')
        CALL STEXT(28 ,1,'Wedge Pair No vs Wire Plane')
        CALL BHS  (29,0,101,0.0,1.01)
        CALL SHS  (29,0,-1.)
        CALL STEXT(29 ,4,'FT Radial')
        CALL STEXT(29 ,1,'Relative Efficiency')

        IF(IL4L5.EQ.2) THEN

          CALL BHDW (40,0,32,0.0,32.0,36,0.0,36.0)
          CALL SHDW (40,0,40.,40.,1.)
          CALL STEXT(40 ,4,'FT Planar')
          CALL STEXT(40 ,1,'No. of hits        vs Wire Plane')
          CALL BHDW (41,0,32,0.0,32.0,36,0.0,36.0)
          CALL SHDW (41,0,40.,40.,1.)
          CALL STEXT(41 ,4,'FT Planar')
          CALL STEXT(41 ,1,'No. of used hits   vs Wire Plane')
          CALL BHDW (42,0,32,0.0,32.0,36,0.0,36.0)
          CALL SHDW (42,0,40.,40.,1.)
          CALL STEXT(42 ,4,'FT Planar')
          CALL STEXT(42 ,1,'No. of unused hits vs Wire Plane')

          CALL BHDW (50,0,24,0.0,24.0,36,0.0,36.0)
          CALL SHDW (50,0,40.,40.,1.)
          CALL STEXT(50 ,4,'FT Radial')
          CALL STEXT(50 ,1,'No. of hits        vs Wire Plane')
          CALL BHDW (51,0,24,0.0,24.0,36,0.0,36.0)
          CALL SHDW (51,0,40.,40.,1.)
          CALL STEXT(51 ,4,'FT Radial')
          CALL STEXT(51 ,1,'No. of used hits   vs Wire Plane')
          CALL BHDW (52,0,24,0.0,24.0,36,0.0,36.0)
          CALL SHDW (52,0,40.,40.,1.)
          CALL STEXT(52 ,4,'FT Radial')
          CALL STEXT(52 ,1,'No. of unused hits vs Wire Plane')

        ENDIF
      ENDIF

      IF(IL4L5.EQ.2) THEN
        CALL SAREA('FTRMON',0)
        IF(.NOT.LEXIST('VEC',1,0)) THEN
          CALL BNT( 1, 0,     6,FNAME1)
          CALL BNT( 4, 0,     8,FNAMEA)
          CALL BNT( 5, 0,     8,FNAMEA)
          CALL BNT( 6, 0,     8,FNAMEA)
          CALL BNT(75, 0,     8,FNAMEA)
          CALL BNT(76, 0,     8,FNAMEA)
*
          CALL BNT(79, 0,     8,FNAMEA)
          CALL BNT(81, 0,     8,FNAMEA)
          CALL BNT(80, 0,    13,FNAMET)
          CALL BNT(82, 0,    13,FNAMET)

          CALL BNT(87, 0,     8,FNAMEA)
          CALL BNT(88, 0,     8,FNAMEA)
          CALL BNT(89, 0,     8,FNAMEA)
          CALL BNT(90, 0,     8,FNAMEA)

          CALL BNT(19, 0,     6,FNAMEE)
*
          CALL BNT(100,0,     8,FNAMEP)
          CALL BNT(101,0,    13,FNAMER)
*
          CALL BNT(200,0,    10,FNAMEC)
          CALL BNT(201,0,    10,FNAMEC)
          CALL BNT(202,0,    10,FNAMEC)
          CALL BNT(203,0,    10,FNAMEC)
*
          CALL BNT(320,0,     5,FNAMEB)
          CALL BNT(321,0,     5,FNAMEB)
          CALL BNT(322,0,     5,FNAMEB)
          CALL BNT(323,0,     5,FNAMEB)
*
          CALL BNT(2016, 0,     8,FNAMEA)
          CALL BNT(2017, 0,     8,FNAMEA)
*
          CALL BNT(907, 0,     8,FNAMEA)
          CALL BNT(908, 0,     8,FNAMEA)
*
          CALL BNT(650, 0,     8,FNAMEA)
          CALL BNT(651, 0,     8,FNAMEA)
          CALL BNT(652, 0,     8,FNAMEA)
          CALL BNT(653, 0,     8,FNAMEA)
          CALL BNT(654, 0,     8,FNAMEA)
          CALL BNT(655, 0,     8,FNAMEA)
          CALL BNT(656, 0,     8,FNAMEA)
          CALL BNT(657, 0,     8,FNAMEA)
*
        ENDIF
        CALL SAREA('FPOKER',0)
        IF(.NOT.LEXIST('VEC',1,0)) THEN
          CALL BNT(1, 0, 8, NAMES1)
          CALL BNT(2, 0, 8, NAMES2)
          CALL BNT(3, 0, 8, NAMES3)
          CALL BNT(4, 0, 8, NAMES4)
        ENDIF
      ENDIF

      CALL SAREA('FTDMON',0)

      IF( IER1.NE.0 )THEN   ! no histograms copied so abort
         IERR = IER1
         CALL FMOUT(NRUN0,IERR)
         GOTO 9000
      ELSE IF( NHIST.EQ.0 )THEN
         IERR = -10
         CALL FMOUT(NRUN0,IERR)
         GOTO 9000
      ENDIF

      AVEC(1) = FLOAT(NRUN0)
      AVEC(2) = FLOAT(NDATE0)
      AVEC(3) = FLOAT(NTIME0)
      AVEC(4) = FLOAT(NMIN92)
      AVEC(5) = FLOAT(NPRES0)
      AVEC(6) = FLOAT(IEVIN)
      AVEC(7) = TOTL
      AVEC(8) = H1L
      AVEC(9) = RTIME
      AVEC(10) = REFF
      AVEC(11) = FLOAT(ILRET)
      AVEC(12) = -1.
      AVEC(13) = -1.
      IF(IRTE0.EQ.0) AVEC(12) = FLOAT(NECUR0)
      IF(IRTP0.EQ.0) AVEC(13) = FLOAT(NPCUR0)
      AVEC(14) = FLOAT(NFIEL0)
      CALL SVEC(1,0,AVEC)

* Analyse Planars and Radials ...
      CALL FQENDP
      CALL FQENDR
      IF(ISTATP(1).GE.1000) CALL FDEADP
      IF(ISTATR(1).GE.1000) CALL FDEADR

* Analysis mean event time histograms with peak-parm
      IF(IL4L5.EQ.1) CALL SAREA('L4',NRUN0)
      IF(IL4L5.EQ.2) CALL SAREA('FTDSGI',0)
      CALL FMEANT
*
      IERR = 0
      CALL FMOUT(NRUN0,IERR)

 9000 CONTINUE

      IF(IL4L5.EQ.2) THEN
        CALL FHTMAP
        CALL FTRMON(NRUN0)
        CALL FPOKEM(NRUN0)
      ENDIF

      CALL SAREA('FTDMON',0)

      RETURN
      END
*CMZU:  8.04/00 07/07/96  12.40.30  by  Girish D. Patel
*CMZU:  7.04/00 12/01/96  15.38.40  by  Girish D. Patel
*CMZU:  5.01/06 05/01/94  15.06.51  by  Girish D. Patel
*-- Author :    John V. Morris
      SUBROUTINE FLK2HB(NHISTS,IERR)
**********************************************************************
*                                                                    *
* Extract FTDMONitoring histograms from LOOK and transfer them to    *
* HBOOK tables/histograms which have already been booked.            *
*                                                                    *
* Histograms are identified through /FFARML/                         *
* NHISTS returns the number of histograms with non-zero content.     *
*                                                                    *
* IERR = 0 ; normal return code, no errors detected                  *
* IERR < 0 ; some mis-match found in expected histogram parameters   *
*                                                                    *
* IERR < 0 should lead to termination of FTDMON within TCL           *
* JVM 21/6/93                                                        *
*                                                                    *
**********************************************************************

*KEEP,FFARML.
      PARAMETER( MAXL=300 )
      CHARACTER*30 TL1, TL4
      CHARACTER*4  DTP
      COMMON/FFARML/ NLK, NSQ(MAXL), DTP(MAXL), TL1(MAXL), TL4(MAXL),
     &               NBX(MAXL), NBY(MAXL),
     &               XBA(MAXL), XBB(MAXL), YBA(MAXL), YBB(MAXL),
     &               NHB(MAXL), LHB(MAXL)

*KEEP,FLKSTA.
      PARAMETER( MAXH=300)            ! number of FTD histograms
      PARAMETER( MAXH4=MAXH*4 )
      COMMON/FLKSTA/ NENT(MAXH), NIN(MAXH), SUMW(MAXH), RNEFF(MAXH),
     &               XSTAT(MAXH4), YSTAT(MAXH4)
* FLKSTA holds statistical information extracted from LOOK ....
* NENT         total entries
* NIN          entries in range
* SUMW         summed weights for all entries
* RNEFF        effective number of entries
* XSTAT 1/2    min/max x-value
* XSTAT 3      mean x
* XSTAT 4      sigma x
* YSTAT 1/2    min/max y-value
* YSTAT 3      mean y
* YSTAT 4      sigma y
*KEEP,FTOTST.
      PARAMETER(LENST=66)
      COMMON/FTOTST/ ISTSUM(LENST)
*KEEP,FTQRUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FTQRUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEND.

      DATA LKOFF/19500/                ! farm <-> LOOK offset ????
      CHARACTER*30 TITLE

      DIMENSION STORE(4800)            ! for contents transfer ?
      DIMENSION STOR2(60,80)
      EQUIVALENCE( STORE(1),STOR2(1,1) )

      IERR   = 0
      NHISTS = 0


* check that there will be some histograms to process!
      IF( NLK.LE.0 )THEN
         IERR = -1
         GOTO 2000
      ENDIF

* cycle through the list of histograms, check for a match with
* those expected, and copy to the corresponding HBOOK hist(s) ...
      DO 1000 JL=1,NLK

        IDH = LHB(JL)             ! ID of referenced HBOOK hist
        IDL = NSQ(JL)             ! farm hist sequence number
        LFG = IDL + LKOFF         ! careful !!??
        INR = 0

* check that the LOOK histo has the correct title, which identifies
* it uniquely ...
        CALL GTEXT(LFG,4,NCHAR,TITLE)
        IF( TITLE.NE.TL1(JL) )THEN     ! mis-match
           IERR = -2
           WRITE(6,'('' FLK2HB ** -2 ,JL,IDH,IDL,LFG '',4I6)')
     &     JL,IDH,IDL,LFG
           GOTO 2000
        ENDIF

* check that the number of bins is as expected ...
        CALL GHBINS(DTP(JL),LFG,INR,NX,XA,XB,NY,YA,YB)
        IF( NX.NE.NBX(JL) .OR. NY.NE.NBY(JL) )THEN     ! mis-match
          WRITE(6,'('' FLK2HB ** -3 JL, NX, NY, NBX, NBY '',8I6)')
     &                  JL,IDH,IDL,LFG,NX,NY,NBX(JL),NBY(JL)
           IERR = -3
           GOTO 2000
        ENDIF

* Check that histogram has some entries....
        CALL GHSTAT(DTP(JL),LFG,INR,NENT(JL),SUMW(JL),RNEFF(JL),
     &       XSTAT(JL*4-3),YSTAT(JL*4-3))
        IF(NENT(JL).EQ.0) THEN
           WRITE(6,'('' FLK2HB ** -5 ,JL,IDH,IDL,LFG '',4I6)')
     &     JL,IDH,IDL,LFG
          IERR = -5
          GO TO 2000
        ENDIF

* now copy to HBOOK .... what dimensions are we dealing with ?

        IF( NY.EQ.0 .AND. NX.GT.0 )THEN     ! 1-D

           LEN = NX
           IF(DTP(JL).EQ.'HSW') LEN = LEN*2
           CALL FDATA(DTP(JL),LFG,INR,0,NR,STORE,LEN)

           IF(DTP(JL).EQ.'HSW') THEN
             DO 100 IBIN = 2 , NX
  100          STORE(IBIN) = STORE(IBIN*2 - 1)
           ENDIF

           CALL HPAK(IDH,STORE)
           NHISTS = NHISTS+1

           IF( IDL.EQ.26 )THEN   ! copy to ISTSUM
              DO 1002 JX=1,LENST
1002          ISTSUM(JX) = NINT(STORE(JX))

* Copy end-of-run statistics information ...
              CALL FQEND
           ENDIF

        ELSE IF( NX*NY.GT.0 )THEN           ! 2-D

           LENX = NX
           IF(DTP(JL).EQ.'HDW') LENX = LENX*2
           LEN = LENX*NY
           IF( NHB(JL).EQ.1 )THEN            ! straight copy
              CALL FDATA(DTP(JL),LFG,INR,0,NR,STORE,LEN)
              IF(DTP(JL).EQ.'HDW') THEN
              DO 101 JY=1,NY
                LOC = (JY-1)*LENX
                LOCN= (JY-1)*LENX/2
                DO 101 IBIN = 2 , LENX
  101            STORE(LOCN+ IBIN) = STORE(LOC + IBIN*2 - 1)
              ENDIF
              CALL HPAK(IDH,STOR2)          ! ... I hope! ..?
              NHISTS = NHISTS+1
           ELSE IF( NHB(JL).GT.1 )THEN      ! copy slice-by-slice

              IF( NHB(JL).NE.NY )THEN       ! mis-match
                 IERR = -4
                 GOTO 2000
              ENDIF

              CALL FDATA(DTP(JL),LFG,INR,0,NR,STORE,LEN)
              DO 1001 JY=1,NY
                LOC = (JY-1)*LENX

              IF(DTP(JL).EQ.'HDW') THEN
                DO 102 IBIN = 2 , LENX
  102            STORE(LOC + IBIN) = STORE(LOC + IBIN*2 - 1)
              ENDIF

                NHISTS = NHISTS+1
                IDSTO = IDH+JY-1
                IF(IDL.EQ.8 .OR. IDL.EQ.23) THEN
                  IDSTO = IDH + INT((JY-1)/13)*1000 +
     &                     JY - INT((JY-1)/13)*13 - 1
                ENDIF
 1001           CALL HPAK(IDSTO,STORE(LOC+1))
           ENDIF

        ENDIF

 1000 CONTINUE

 2000 CONTINUE         ! error messages are printed by FTDEOR

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.28  by  Stephen Burke
*CMZU:  5.01/06 09/08/94  14.51.01  by  Girish D. Patel
*-- Author :    John V. Morris   28/06/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FQEND
**********************************************************************
*                                                                    *
* Copy the end-of-run statistics from histogram number 26, filled on *
* the farm, into the corresponding off-line arrays and variables.    *
*                                                                    *
* JVM 22/6/93                                                        *
*                                                                    *
**********************************************************************

*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEEP,FHITLS.
      COMMON/FHITLS/ LHITSP(0:8), LHITSR(0:8)
*KEEP,FCOUNT.
      COMMON/FCOUNT/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FTOTST.
      PARAMETER(LENST=66)
      COMMON/FTOTST/ ISTSUM(LENST)
*KEEP,FTQRUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FTQRUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEND.
      INTEGER  IBT(220)


* ISTSUM should have been filled in FLK2HB
* fill the elements of ISTATP and ISTATR ....

      DO 101 J=1,20
      LOCP = 7+J
      LOCR = 27+J
      ISTATP(J) = ISTSUM(LOCP)
      ISTATR(J) = ISTSUM(LOCR)
  101 CONTINUE

      DO 201 J=0,8
      LOCP = 48+J
      LOCR = 57+J
      LHITSP(J) = ISTSUM(LOCP)
      LHITSR(J) = ISTSUM(LOCR)
  201 CONTINUE

      IF(NRUN0.LT.59419 .OR. NRUN0.GT.59922) IEVIN  = ISTSUM(LENST)

* fill the remaining run statistics in /FCOUNT/
* in principle the first 7 elements of ISTSUM hold this data, but
* it can equally well be extracted from the database?
      CALL GETEAR(NRUN0,IDATE,ITIME,IBFLD,IPRESS,IFR,IFP,IRET)
      IF(IRET.EQ.0) THEN
        NDATE0 = IDATE
        NTIME0 = ITIME
        CALL DMIN92(NDATE0,NTIME0,NMIN92)
        NFIEL0 = IBFLD
        NPRES0 = IPRESS
        IFRHV = IFR
        IFPHV = IFP
      ELSE
        NPROC  = INT(FLOAT(ISTSUM(1))/FLOAT(NRUN0)+0.5)
        NDATE0 = ISTSUM(2)/NPROC
        NTIME0 = ISTSUM(3)/NPROC
        CALL DMIN92(NDATE0,NTIME0,NMIN92)
        NFIEL0 = ISTSUM(4)/NPROC
        NPRES0 = ISTSUM(5)/NPROC
        IFRHV = 2
        IFPHV = 2
      ENDIF
      CALL EPBEAM(NRUN0,PTC,PPC,ETC,EPC,IBT,IRET)
      IF(IRET.EQ.0) THEN
        NECUR0 = INT(ETC)
        IRTE0 = 0
        NPCUR0 = INT(PTC)
        IRTP0 = 0
      ELSE
        IRTE0 = 1
        IRTP0 = 1
      ENDIF
      NRUN1  = NRUN0
      NRUN   = NRUN0

      CALL GETH1L (NRUN0,TOTL,H1L,RTIME,REFF,ILRET)

      RETURN
      END
*CMZU:  8.04/00 10/07/96  10.23.26  by  Girish D. Patel
*CMZU:  5.01/06 09/08/94  15.06.04  by  Girish D. Patel
*-- Author :    Girish D. Patel
      SUBROUTINE GETEAR(IRUN,IDATE,ITIME,IBFLD,IPRESS,IFR,IFP,IRET)
*======================================================================
*     Input:  IRUN   ep-run number
*             ZEAR   the bank from the database
*     Output: IDATE  Run date (yymmdd)
*             ITIME  Run time (hhmmss)
*             IBFLD  Bfield (gauss)
*             IPRESS Pressure (mbar)
*             IFR    Forward Tracker Radial HV flag 1 = off, 0 = on
*             IFP    Forward Tracker Planar HV flag 1 = off, 0 = on
*             IRET   return flag: 0 - ok,  1 - no inf. found in H1DB
*
*======================================================================
      COMMON /CHEAR/ JDATE,JTIME,JBFLD,JPRES,JBBL3
*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,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.
      LOGICAL FIRST /.TRUE./
      IF(FIRST) THEN
        FIRST = .FALSE.
        CALL H1ENVI(IFLAG,IPROC,NPROC)
      ENDIF
      IL4L5 = IFLAG
      IF(IL4L5.EQ.2) THEN
        IROLD  = NCCRUN
        NCCRUN = IRUN
        IRET=1
        IND=IABS(MDB('ZEAR'))
        NCCRUN = IROLD
        IF(IND.GT.0) THEN
           IDATE = IW(IND+3)
           ITIME = IW(IND+4)
           IBFLD = IW(IND+8)
           IPRESS = IW(IND+10)
           IBBL3  = IW(IND+11)
           IFR = JBIT(IBBL3,19)
           IFP = JBIT(IBBL3,20)
           IRET = 0
        ENDIF
      ELSE IF(IL4L5.EQ.1) THEN

        WRITE(*,*) 'GETEAR is called for Run =',IRUN

        IRET=1
        IF(JDATE.GT.0) THEN
           IDATE = JDATE
           ITIME = JTIME
           IBFLD = JBFLD
           IPRESS = JPRES
           IFR = JBIT(JBBL3,19)
           IFP = JBIT(JBBL3,20)
           IRET = 0
        END IF
      ELSE

        WRITE(*,*) ' WARNING GETEAR is called for Run =',IRUN,
     & ' with illegal IL4L5 flag',IL4L5

      ENDIF
      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.28  by  Stephen Burke
*CMZU:  5.01/06 26/10/93  15.57.04  by  Girish D. Patel
*-- Author :    Girish D. Patel
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE DMIN92(IDATE,ITIME,MIN92)
*======================================================================
*     Input:  IDATE  Run date (yymmdd)
*             ITIME  Run time (hhmmss)
*     Output: MIN92  Elapsed minutes since midnight 0/1/92
*
*======================================================================
      DIMENSION IDY(0:10),IDM(0:11)
      DATA IDY /0,366,731,1096,1461,1827,2192,2557,2992,3288,3653/
      DATA IDM /0,31,59,90,120,151,181,212,243,273,304,334/
      JIN92 = 0
      IF(IDATE.NE.0) THEN
        IYY = IDATE/10000
        IMM = (IDATE - IYY*10000)/100
        IDD = (IDATE - IYY*10000 - IMM*100)
        IHH = ITIME/10000
        MIN = (ITIME - IHH*10000)/100
        IF(IYY.GE.92) THEN
          IDD92 =   IDY(IYY - 92) + IDM(IMM-1) + IDD
        ELSE IF(IYY.LE.10) THEN
          IDD92 = 2992 + IDY(IYY) + IDM(IMM-1) + IDD
        ELSE
          IDD92 = 0
          WRITE(6,*) ' ** WARNING ** FTDEOR - Routine DMIN92 too OLD'
        ENDIF
        IF(MOD(IYY,4).EQ.0.AND.IMM.GT.2) IDD92 = IDD92 + 1
        IF(IDD92.NE.0) JIN92 = ( IDD92*24 + IHH )*60 + MIN
      ELSE
        JIN92 = 0
      ENDIF
      MIN92 = JIN92
      RETURN
      END
*CMZU:  8.04/00 06/07/96  18.31.26  by  Girish D. Patel
*CMZU:  5.01/06 18/05/94  16.14.21  by  Girish D. Patel
*-- Author :    Girish D. Patel
      SUBROUTINE FTQINT
C
*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEEP,FTQRUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FTQRUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FCISCA.
      COMMON /FCISCA/ ISCA
*KEEP,FCOUNT.
      COMMON/FCOUNT/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FHITLS.
      COMMON/FHITLS/ LHITSP(0:8), LHITSR(0:8)
*KEND.

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



* set up logical unit numbers for output files ...
* LMES for error messages etc.
      LMES   = 6  ! default Lun for error messages etc...also on farm?
      LUNH   = 6  ! default Lun for error messages etc...also on farm?


      PLANAR = .TRUE.
      RADIAL = .TRUE.

      ISCA = 50


      NTIME = 0
      IRTE0 = 1
      IRTP0 = 1
      IEVIN = 0
      NFPEVT= 0
      NHITSP= 0
      NFREVT= 0
      NHITSR= 0

* initialise hits per orientation count
      CALL VZERO( LHITSP(0),9 )
      CALL VZERO( LHITSR(0),9 )
      CALL VZERO( ISTATP(1),20 )
      CALL VZERO( ISTATR(1),20 )


      RETURN
      END
*CMZU:  8.04/00 07/07/96  09.01.18  by  Girish D. Patel
*CMZU:  8.03/00 21/06/96  12.07.22  by  Girish D. Patel
*CMZU:  7.00/12 02/05/95  15.43.29  by  Girish D. Patel
*CMZ :  5.02/05 20/09/94  13.46.52  by  Girish D. Patel
*CMZU:  5.01/06 31/01/94  18.00.52  by  Girish D. Patel
*-- Author :    John V. Morris
      SUBROUTINE FBOOKQ
************************************************************************
* This reverts back to version 1.03/01                                 *
************************************************************************
************************************************************************
* HBOOKing of histograms for PLANAR and RADIAL monitoring              *
************************************************************************
* Modified for running on SGI
*KEEP,FNBINR.
      PARAMETER( NBINR=40 )           ! number of radius bins
*KEEP,FTOTST.
      PARAMETER(LENST=66)
      COMMON/FTOTST/ ISTSUM(LENST)
*KEEP,FFARML.
      PARAMETER( MAXL=300 )
      CHARACTER*30 TL1, TL4
      CHARACTER*4  DTP
      COMMON/FFARML/ NLK, NSQ(MAXL), DTP(MAXL), TL1(MAXL), TL4(MAXL),
     &               NBX(MAXL), NBY(MAXL),
     &               XBA(MAXL), XBB(MAXL), YBA(MAXL), YBB(MAXL),
     &               NHB(MAXL), LHB(MAXL)

*KEEP,FTQRUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FTQRUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEND.

      LOGICAL L5

      L5 = .FALSE.
      IF(IL4L5.EQ.2) L5 = .TRUE.
* book some histograms
      IF(PLANAR) THEN

      CALL HTABLE(1,'Cell No. (0-31) vs Wire Plane (1-36)$',
     &     32,-0.5,31.5,36,0.5,36.5,0.)
      CALL HBOOK1(2,'HIT MULTIPLICITY/CELL$',50,-0.5,49.5,0.)

      CALL HBOOK1(3,'RAW D-TIME ALL HITS  $',100,0.,2000.,0.)
      CALL HBOOK1(7,'INTER-HIT TIME;ALL HITS$',100,0.,1000.,0.)
      CALL HBOOK1(8,'INTER-HIT TIME;SM0     $',100,0.,1000.,0.)
      CALL HBOOK1(9,'INTER-HIT TIME;SM1     $',100,0.,1000.,0.)
      CALL HBOOK1(10,'INTER-HIT TIME;SM2     $',100,0.,1000.,0.)
      CALL HBOOK2(11,'LN(Q) V T FOR ALL HITS$',
     &            32,0.,1600.,30,4.,10.,0.)
*JVM  CALL HBOOK1(12,'LN(Q) FOR ALL HITS$',60,0.,12.,0.)
      CALL HBOOK1(13,'Ln(Q) for all hits$',  30,4.,10.  ,0.)
      CALL HBOOK1(14,'Ln(Q) for   WIRE 1$',  30,4.,10.  ,0.)
      CALL HBOOK1(15,'Ln(Q) for   WIRE 2$',  30,4.,10.  ,0.)
      CALL HBOOK1(16,'Ln(Q) for   WIRE 3$',  30,4.,10.  ,0.)
      CALL HBOOK1(17,'Ln(Q) for   WIRE 4$',  30,4.,10.  ,0.)

      CALL HBOOK1(18,'Ln(Q) FOR ID=5011$', 30,4.,10.,0.)
      CALL HBOOK1(19,'Ln(Q) FOR SM0    $', 30,4.,10.,0.)
      CALL HBOOK1(20,'Ln(Q) FOR SM1    $', 30,4.,10.,0.)
      CALL HBOOK1(21,'Ln(Q) FOR SM2    $', 30,4.,10.,0.)

      CALL HBOOK1(22,'CLASS I 4-hit twin peaks TOTAL$', 34,-51.,51.,0.)
      CALL HBOOK1(23,'CLASS I 4-hit twin peaks MOD 0$', 34,-51.,51.,0.)
      CALL HBOOK1(24,'CLASS I 4-hit twin peaks MOD 1$', 34,-51.,51.,0.)
      CALL HBOOK1(25,'CLASS I 4-hit twin peaks MOD 2$', 34,-51.,51.,0.)
      CALL HBOOK1(26,'CLASS I 4-hit twin peaks LAY 0$', 34,-51.,51.,0.)
      CALL HBOOK1(27,'CLASS I 4-hit twin peaks LAY 1$', 34,-51.,51.,0.)
      CALL HBOOK1(28,'CLASS I 4-hit twin peaks LAY 2$', 34,-51.,51.,0.)
      CALL HBOOK1(29,'CLASS I 4-hit twin peaks LAY 3$', 34,-51.,51.,0.)
      CALL HBOOK1(30,'CLASS I 4-hit twin peaks LAY 4$', 34,-51.,51.,0.)
      CALL HBOOK1(31,'CLASS I 4-hit twin peaks LAY 5$', 34,-51.,51.,0.)
      CALL HBOOK1(32,'CLASS I 4-hit twin peaks LAY 6$', 34,-51.,51.,0.)
      CALL HBOOK1(33,'CLASS I 4-hit twin peaks LAY 7$', 34,-51.,51.,0.)
      CALL HBOOK1(34,'CLASS I 4-hit twin peaks LAY 8$', 34,-51.,51.,0.)

      CALL HBOOK1(1022,'MULTI 1 3-hit twin peaks TOTAL$',34,-51.,51.,0.)
      CALL HBOOK1(1023,'MULTI 1 3-hit twin peaks MOD 0$',34,-51.,51.,0.)
      CALL HBOOK1(1024,'MULTI 1 3-hit twin peaks MOD 1$',34,-51.,51.,0.)
      CALL HBOOK1(1025,'MULTI 1 3-hit twin peaks MOD 2$',34,-51.,51.,0.)
      CALL HBOOK1(1026,'MULTI 1 3-hit twin peaks LAY 0$',34,-51.,51.,0.)
      CALL HBOOK1(1027,'MULTI 1 3-hit twin peaks LAY 1$',34,-51.,51.,0.)
      CALL HBOOK1(1028,'MULTI 1 3-hit twin peaks LAY 2$',34,-51.,51.,0.)
      CALL HBOOK1(1029,'MULTI 1 3-hit twin peaks LAY 3$',34,-51.,51.,0.)
      CALL HBOOK1(1030,'MULTI 1 3-hit twin peaks LAY 4$',34,-51.,51.,0.)
      CALL HBOOK1(1031,'MULTI 1 3-hit twin peaks LAY 5$',34,-51.,51.,0.)
      CALL HBOOK1(1032,'MULTI 1 3-hit twin peaks LAY 6$',34,-51.,51.,0.)
      CALL HBOOK1(1033,'MULTI 1 3-hit twin peaks LAY 7$',34,-51.,51.,0.)
      CALL HBOOK1(1034,'MULTI 1 3-hit twin peaks LAY 8$',34,-51.,51.,0.)

      CALL HBOOK1(2022,'MULTI 0 3-hit twin peaks TOTAL$',34,-51.,51.,0.)
      CALL HBOOK1(2023,'MULTI 0 3-hit twin peaks MOD 0$',34,-51.,51.,0.)
      CALL HBOOK1(2024,'MULTI 0 3-hit twin peaks MOD 1$',34,-51.,51.,0.)
      CALL HBOOK1(2025,'MULTI 0 3-hit twin peaks MOD 2$',34,-51.,51.,0.)
      CALL HBOOK1(2026,'MULTI 0 3-hit twin peaks LAY 0$',34,-51.,51.,0.)
      CALL HBOOK1(2027,'MULTI 0 3-hit twin peaks LAY 1$',34,-51.,51.,0.)
      CALL HBOOK1(2028,'MULTI 0 3-hit twin peaks LAY 2$',34,-51.,51.,0.)
      CALL HBOOK1(2029,'MULTI 0 3-hit twin peaks LAY 3$',34,-51.,51.,0.)
      CALL HBOOK1(2030,'MULTI 0 3-hit twin peaks LAY 4$',34,-51.,51.,0.)
      CALL HBOOK1(2031,'MULTI 0 3-hit twin peaks LAY 5$',34,-51.,51.,0.)
      CALL HBOOK1(2032,'MULTI 0 3-hit twin peaks LAY 6$',34,-51.,51.,0.)
      CALL HBOOK1(2033,'MULTI 0 3-hit twin peaks LAY 7$',34,-51.,51.,0.)
      CALL HBOOK1(2034,'MULTI 0 3-hit twin peaks LAY 8$',34,-51.,51.,0.)

      CALL HBOOK2(38,'RAW D-TIME DOS/BACK  $', 40,800.,1200.
     &                                         ,13,0.,13.,0.)
      CALL HBSLIX(38,13,0.0)
      CALL HBOOK2(39,'RAW D-TIME DOS/FRONT $', 40, 80., 280.
     &                                         ,13,0.,13.,0.)
      CALL HBSLIX(39,13,0.0)

      CALL HBOOK1(138,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(139,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(140,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(141,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(142,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(143,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(144,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(145,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(146,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(147,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(148,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(149,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)
      CALL HBOOK1(150,'RAW D-TIME DOS/BACK  $', 40,800.,1200.,0.)

      CALL HBOOK1(151,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(152,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(153,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(154,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(155,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(156,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(157,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(158,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(159,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(160,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(161,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(162,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)
      CALL HBOOK1(163,'RAW D-TIME DOS/FRONT $', 40, 80., 280.,0.)

      NLK = 0                ! zero histogram counter
          NLK = NLK + 1
          NSQ(NLK) = 1
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Cell No vs Wire Plane'
          NBX(NLK) = 32
          NBY(NLK) = 36
          XBA(NLK) = -0.5
          XBB(NLK) = 31.5
          YBA(NLK) = 0.5
          YBB(NLK) = 36.5
          NHB(NLK) = 1
          LHB(NLK) = 1


          NLK = NLK + 1
          NSQ(NLK) = 2
          DTP(NLK) = 'HS'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Hit Multiplicity/Cell'
          NBX(NLK) = 50
          NBY(NLK) =  0
          XBA(NLK) = -0.5
          XBB(NLK) = 49.5
          YBA(NLK) = 0.0
          YBB(NLK) = 0.0
          NHB(NLK) = 1
          LHB(NLK) = 2


          NLK = NLK + 1
          NSQ(NLK) = 3
          DTP(NLK) = 'HS'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Raw D-Time ALL Hits'
          NBX(NLK) = 100
          NBY(NLK) = 0
          XBA(NLK) = 0.0
          XBB(NLK) = 2000.0
          YBA(NLK) = 0.0
          YBB(NLK) = 0.0
          NHB(NLK) = 1
          LHB(NLK) = 3

          NLK = NLK + 1
          NSQ(NLK) = 4
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Inter-Hit Time, ALL + per SM'
          NBX(NLK) = 100
          NBY(NLK) = 4
          XBA(NLK) = 0.0
          XBB(NLK) = 1000.0
          YBA(NLK) = 0.0
          YBB(NLK) = 4.0
          NHB(NLK) = 4
          LHB(NLK) = 7

          NLK = NLK + 1
          NSQ(NLK) = 5
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Ln(Q) vs T, ALL Hits'
          NBX(NLK) = 32
          NBY(NLK) = 30
          XBA(NLK) = 0.0
          XBB(NLK) = 1600.0
          YBA(NLK) = 4.0
          YBB(NLK) = 10.0
          NHB(NLK) = 1
          LHB(NLK) = 11

          NLK = NLK + 1
          NSQ(NLK) = 6
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Ln(Q) ALL Hits + per wire'
          NBX(NLK) = 30
          NBY(NLK) = 5
          XBA(NLK) = 4.0
          XBB(NLK) = 10.0
          YBA(NLK) = 0.0
          YBB(NLK) = 5.0
          NHB(NLK) = 5
          LHB(NLK) = 13

          NLK = NLK + 1
          NSQ(NLK) = 7
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Ln(Q) for Cluster hits + per SM'
          NBX(NLK) = 30
          NBY(NLK) = 4
          XBA(NLK) = 4.0
          XBB(NLK) = 10.0
          YBA(NLK) = 0.0
          YBB(NLK) = 4.0
          NHB(NLK) = 4
          LHB(NLK) = 18

          NLK = NLK + 1
          NSQ(NLK) = 8
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = '+/-2S/V All+SM+Layer'
          NBX(NLK) = 34
          NBY(NLK) = 39
          XBA(NLK) = -51.
          XBB(NLK) = 51.
          YBA(NLK) = 0.
          YBB(NLK) = 39.
          NHB(NLK) = 39
          LHB(NLK) = 22

          NLK = NLK + 1
          NSQ(NLK) = 9
          DTP(NLK) = 'HD'
          IF(L5) DTP(NLK) = 'HDW'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Raw D-Time DOS/Back'
          NBX(NLK) = 40
          NBY(NLK) = 13
          XBA(NLK) = 800.
          XBB(NLK) = 1200.
          YBA(NLK) = 0.
          YBB(NLK) = 13.
          NHB(NLK) = 13
          LHB(NLK) = 138

          NLK = NLK + 1
          NSQ(NLK) = 10
          DTP(NLK) = 'HD'
          IF(L5) DTP(NLK) = 'HDW'
          TL1(NLK) = 'FT Planar'
          TL4(NLK) = 'Raw D-Time DOS/Front'
          NBX(NLK) = 40
          NBY(NLK) = 13
          XBA(NLK) = 80.
          XBB(NLK) = 280.
          YBA(NLK) = 0.
          YBB(NLK) = 13.
          NHB(NLK) = 13
          LHB(NLK) = 151

      ENDIF



      IF(RADIAL) THEN
      CALL HTABLE(40,'Wedge Pair No*2+- (0-47) vs Wire Plane (1-36)$',
     &     48,-0.5,47.5,36,0.5,36.5,0.)
      CALL HBOOK1(41,'HIT MULTIPLICITY/CELL$',30,-0.5,29.5,0.)

      CALL HBOOK1(42,'RAW D-TIME ALL HITS  $',100,0.,2000.,0.)
      CALL HBOOK1(44,'Radius     ALL HITS  $',80,-80.0,80.0,0.)
      CALL HBOOK1(45,'ABS(Radius) ALL HITS  $',80,0.0,80.0,0.)
      CALL HBOOK2(46,' Drift T vs Radius ALL HITS$',
     &            50,0.,2500.,40,0.0,80.0,0.)

      CALL HBOOK1(49,'INTER-HIT TIME;ALL HITS$',100,0.,1000.,0.)
      CALL HBOOK1(50,'INTER-HIT TIME;SM0     $',100,0.,1000.,0.)
      CALL HBOOK1(51,'INTER-HIT TIME;SM1     $',100,0.,1000.,0.)
      CALL HBOOK1(52,'INTER-HIT TIME;SM2     $',100,0.,1000.,0.)

      CALL HBOOK2(53,'LN(Q) V T FOR ALL HITS$',
     &            50,0.,2500.,30,4.,10.,0.)
      CALL HBOOK1(54,'LN(Q) FOR ALL HITS$',30,4.,10.,0.)

      CALL HBOOK1(55,'Ln(Q) for all hits$',   30,4.,10.  ,0.)
      CALL HBOOK1(56,'Ln(Q)       WIRE  1$',  30,4.,10.  ,0.)
      CALL HBOOK1(57,'Ln(Q)       WIRE  2$',  30,4.,10.  ,0.)
      CALL HBOOK1(58,'Ln(Q)       WIRE  3$',  30,4.,10.  ,0.)
      CALL HBOOK1(59,'Ln(Q)       WIRE  4$',  30,4.,10.  ,0.)
      CALL HBOOK1(60,'Ln(Q)       WIRE  5$',  30,4.,10.  ,0.)
      CALL HBOOK1(61,'Ln(Q)       WIRE  6$',  30,4.,10.  ,0.)
      CALL HBOOK1(62,'Ln(Q)       WIRE  7$',  30,4.,10.  ,0.)
      CALL HBOOK1(63,'Ln(Q)       WIRE  8$',  30,4.,10.  ,0.)
      CALL HBOOK1(64,'Ln(Q)       WIRE  9$',  30,4.,10.  ,0.)
      CALL HBOOK1(65,'Ln(Q)       WIRE 10$',  30,4.,10.  ,0.)
      CALL HBOOK1(66,'Ln(Q)       WIRE 11$',  30,4.,10.  ,0.)
      CALL HBOOK1(67,'Ln(Q)       WIRE 12$',  30,4.,10.  ,0.)

      CALL HBOOK1(68,'Q FOR ID=  72$', 50,0.,5000.,0.)
      CALL HBOOK1(69,'Q FOR SM0    $', 50,0.,5000.,0.)
      CALL HBOOK1(70,'Q FOR SM1    $', 50,0.,5000.,0.)
      CALL HBOOK1(71,'Q FOR SM2    $', 50,0.,5000.,0.)

      CALL HBOOK1(72,'CLASS I 4-hit twin peaks ALL  $', 34,-51.,51.,0.)
      CALL HBOOK1(73,'CLASS I 4-hit twin peaks MOD 0$', 34,-51.,51.,0.)
      CALL HBOOK1(74,'CLASS I 4-hit twin peaks MOD 1$', 34,-51.,51.,0.)
      CALL HBOOK1(75,'CLASS I 4-hit twin peaks MOD 2$', 34,-51.,51.,0.)
      CALL HBOOK1(76,'CLASS I 4-hit twin peaks LAY 0$', 34,-51.,51.,0.)
      CALL HBOOK1(77,'CLASS I 4-hit twin peaks LAY 1$', 34,-51.,51.,0.)
      CALL HBOOK1(78,'CLASS I 4-hit twin peaks LAY 2$', 34,-51.,51.,0.)
      CALL HBOOK1(79,'CLASS I 4-hit twin peaks LAY 3$', 34,-51.,51.,0.)
      CALL HBOOK1(80,'CLASS I 4-hit twin peaks LAY 4$', 34,-51.,51.,0.)
      CALL HBOOK1(81,'CLASS I 4-hit twin peaks LAY 5$', 34,-51.,51.,0.)
      CALL HBOOK1(82,'CLASS I 4-hit twin peaks LAY 6$', 34,-51.,51.,0.)
      CALL HBOOK1(83,'CLASS I 4-hit twin peaks LAY 7$', 34,-51.,51.,0.)
      CALL HBOOK1(84,'CLASS I 4-hit twin peaks LAY 8$', 34,-51.,51.,0.)

      CALL HBOOK1(1072,'MULTI 1 3-hit twin peaks ALL  $',34,-51.,51.,0.)
      CALL HBOOK1(1073,'MULTI 1 3-hit twin peaks MOD 0$',34,-51.,51.,0.)
      CALL HBOOK1(1074,'MULTI 1 3-hit twin peaks MOD 1$',34,-51.,51.,0.)
      CALL HBOOK1(1075,'MULTI 1 3-hit twin peaks MOD 2$',34,-51.,51.,0.)
      CALL HBOOK1(1076,'MULTI 1 3-hit twin peaks LAY 0$',34,-51.,51.,0.)
      CALL HBOOK1(1077,'MULTI 1 3-hit twin peaks LAY 1$',34,-51.,51.,0.)
      CALL HBOOK1(1078,'MULTI 1 3-hit twin peaks LAY 2$',34,-51.,51.,0.)
      CALL HBOOK1(1079,'MULTI 1 3-hit twin peaks LAY 3$',34,-51.,51.,0.)
      CALL HBOOK1(1080,'MULTI 1 3-hit twin peaks LAY 4$',34,-51.,51.,0.)
      CALL HBOOK1(1081,'MULTI 1 3-hit twin peaks LAY 5$',34,-51.,51.,0.)
      CALL HBOOK1(1082,'MULTI 1 3-hit twin peaks LAY 6$',34,-51.,51.,0.)
      CALL HBOOK1(1083,'MULTI 1 3-hit twin peaks LAY 7$',34,-51.,51.,0.)
      CALL HBOOK1(1084,'MULTI 1 3-hit twin peaks LAY 8$',34,-51.,51.,0.)

      CALL HBOOK1(2072,'MULTI 0 3-hit twin peaks ALL  $',34,-51.,51.,0.)
      CALL HBOOK1(2073,'MULTI 0 3-hit twin peaks MOD 0$',34,-51.,51.,0.)
      CALL HBOOK1(2074,'MULTI 0 3-hit twin peaks MOD 1$',34,-51.,51.,0.)
      CALL HBOOK1(2075,'MULTI 0 3-hit twin peaks MOD 2$',34,-51.,51.,0.)
      CALL HBOOK1(2076,'MULTI 0 3-hit twin peaks LAY 0$',34,-51.,51.,0.)
      CALL HBOOK1(2077,'MULTI 0 3-hit twin peaks LAY 1$',34,-51.,51.,0.)
      CALL HBOOK1(2078,'MULTI 0 3-hit twin peaks LAY 2$',34,-51.,51.,0.)
      CALL HBOOK1(2079,'MULTI 0 3-hit twin peaks LAY 3$',34,-51.,51.,0.)
      CALL HBOOK1(2080,'MULTI 0 3-hit twin peaks LAY 4$',34,-51.,51.,0.)
      CALL HBOOK1(2081,'MULTI 0 3-hit twin peaks LAY 5$',34,-51.,51.,0.)
      CALL HBOOK1(2082,'MULTI 0 3-hit twin peaks LAY 6$',34,-51.,51.,0.)
      CALL HBOOK1(2083,'MULTI 0 3-hit twin peaks LAY 7$',34,-51.,51.,0.)
      CALL HBOOK1(2084,'MULTI 0 3-hit twin peaks LAY 8$',34,-51.,51.,0.)

      CALL HBOOK1(88,'DOS/BACK as F(RAD)  $',NBINR,  0.,  80.,0.)
      CALL HBOOK1(89,'RAW D-TIME DOS/FRONT R < 80 $',60,80., 380.,0.)
*      CALL HBOOK1(188,'DOS/BACK as F(RAD) +$',NBINR,  0.,  80.,0.)
*      CALL HBOOK1(288,'DOS/BACK as F(RAD) -$',NBINR,  0.,  80.,0.)

      DO 10 J = 1 , NBINR
       CALL HBOOK1(89+J,'RAW D-TIME DOS/BACK Rbins$',24,300.,1740.,0.)
       CALL HIDOPT(89+J,'PERR')
*       CALL HBOOK1(189+J,'RAW D-TIME DOS/BACK + $',27,300.,1920.,0.)
*       CALL HIDOPT(189+J,'PERR')
*       CALL HBOOK1(289+J,'RAW D-TIME DOS/BACK - $',27,300.,1920.,0.)
*       CALL HIDOPT(289+J,'PERR')
   10 CONTINUE


          NLK = NLK + 1
          NSQ(NLK) = 11
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Wedge Pair*2+- vs Wire Plane'
          NBX(NLK) = 48
          NBY(NLK) = 36
          XBA(NLK) = -0.5
          XBB(NLK) = 47.5
          YBA(NLK) = 0.5
          YBB(NLK) = 36.5
          NHB(NLK) = 1
          LHB(NLK) = 40


          NLK = NLK + 1
          NSQ(NLK) = 12
          DTP(NLK) = 'HS'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Hit Multiplicity/Cell'
          NBX(NLK) = 30
          NBY(NLK) = 0
          XBA(NLK) = -0.5
          XBB(NLK) = 29.5
          YBA(NLK) = 0.
          YBB(NLK) = 0.
          NHB(NLK) = 1
          LHB(NLK) = 41

          NLK = NLK + 1
          NSQ(NLK) = 13
          DTP(NLK) = 'HS'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Raw D-Time ALL Hits'
          NBX(NLK) = 100
          NBY(NLK) = 0
          XBA(NLK) = 0.
          XBB(NLK) = 2000.
          YBA(NLK) = 0.
          YBB(NLK) = 0.
          NHB(NLK) = 1
          LHB(NLK) = 42

*          NLK = NLK + 1
*          NSQ(NLK) = 14
*          DTP(NLK) = 'HS'
*          TL1(NLK) = 'FT Radial'
*          TL4(NLK) = 'Radius  ALL Hits'
*          NBX(NLK) = 80
*          NBY(NLK) = 0
*          XBA(NLK) = -80.
*          XBB(NLK) = 80.
*          YBA(NLK) = 0.
*          YBB(NLK) = 0.
*          NHB(NLK) = 1
*          LHB(NLK) = 44

          NLK = NLK + 1
          NSQ(NLK) = 15
          DTP(NLK) = 'HS'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'ABS(Radius)  ALL Hits'
          NBX(NLK) = 80
          NBY(NLK) = 0
          XBA(NLK) = 0.
          XBB(NLK) = 80.
          YBA(NLK) = 0.
          YBB(NLK) = 0.
          NHB(NLK) = 1
          LHB(NLK) = 45

*          NLK = NLK + 1
*          NSQ(NLK) = 16
*          DTP(NLK) = 'HD'
*          TL1(NLK) = 'FT Radial'
*          TL4(NLK) = 'Drift T vs Radius, ALL Hits'
*          NBX(NLK) = 50
*          NBY(NLK) = 40
*          XBA(NLK) = 0.
*          XBB(NLK) = 2500.
*          YBA(NLK) = 0.
*          YBB(NLK) = 80.
*          NHB(NLK) = 1
*          LHB(NLK) = 46

*         NLK = NLK + 1
*         NSQ(NLK) = 17
*         DTP(NLK) = 'HD'
*         TL1(NLK) = 'FT Radial'
*         TL4(NLK) = 'D-T vs R, Front edge+All Hits'
*         NBX(NLK) = 60
*         NBY(NLK) = 40
*         XBA(NLK) = 0.
*         XBB(NLK) = 300.
*         YBA(NLK) = 0.
*         YBB(NLK) = 80.
*         NHB(NLK) = 1
*         LHB(NLK) = 47
*          NLK = NLK + 1
*          NSQ(NLK) = 17
*          DTP(NLK) = 'HD'
*          IF(L5) DTP(NLK) = 'HDW'
*          TL1(NLK) = 'FT Radial'
*          TL4(NLK) = 'Raw D-Time DOS/Back +   '
*          NBX(NLK) = 27
*          NBY(NLK) = NBINR
*          XBA(NLK) = 300.
*          XBB(NLK) = 1920.
*          YBA(NLK) = 0.
*          YBB(NLK) = FLOAT(NBINR)
*          NHB(NLK) = NBINR
*          LHB(NLK) = 190

*         NLK = NLK + 1
*         NSQ(NLK) = 18
*         DTP(NLK) = 'HD'
*         TL1(NLK) = 'FT Radial'
*         TL4(NLK) = 'D-T vs R, Back edge+All Hits'
*         NBX(NLK) = 40
*         NBY(NLK) = 40
*         XBA(NLK) = 300.
*         XBB(NLK) = 1900.
*         YBA(NLK) = 0.
*         YBB(NLK) = 80.
*         NHB(NLK) = 1
*         LHB(NLK) = 48
*          NLK = NLK + 1
*          NSQ(NLK) = 18
*          DTP(NLK) = 'HD'
*          IF(L5) DTP(NLK) = 'HDW'
*          TL1(NLK) = 'FT Radial'
*          TL4(NLK) = 'Raw D-Time DOS/Back -   '
*          NBX(NLK) = 27
*          NBY(NLK) = NBINR
*          XBA(NLK) = 300.
*          XBB(NLK) = 1920.
*          YBA(NLK) = 0.
*          YBB(NLK) = FLOAT(NBINR)
*          NHB(NLK) = NBINR
*          LHB(NLK) = 290

          NLK = NLK + 1
          NSQ(NLK) = 19
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Inter-Hit Time all + SM'
          NBX(NLK) = 100
          NBY(NLK) = 4
          XBA(NLK) = 0.
          XBB(NLK) = 1000.
          YBA(NLK) = 0.
          YBB(NLK) = 4.
          NHB(NLK) = 4
          LHB(NLK) = 49

          NLK = NLK + 1
          NSQ(NLK) = 20
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Ln(Q) vs T, ALL Hits'
          NBX(NLK) = 50
          NBY(NLK) = 30
          XBA(NLK) = 0.
          XBB(NLK) = 2500.
          YBA(NLK) = 4.
          YBB(NLK) = 10.
          NHB(NLK) = 1
          LHB(NLK) = 53

          NLK = NLK + 1
          NSQ(NLK) = 21
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Ln(Q) ALL Hits and per wire'
          NBX(NLK) = 30
          NBY(NLK) = 13
          XBA(NLK) = 4.
          XBB(NLK) = 10.
          YBA(NLK) = 0.
          YBB(NLK) = 13.
          NHB(NLK) = 13
          LHB(NLK) = 55

          NLK = NLK + 1
          NSQ(NLK) = 22
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Q for Cluster hits + SM'
          NBX(NLK) = 50
          NBY(NLK) = 4
          XBA(NLK) = 0.
          XBB(NLK) = 5000.
          YBA(NLK) = 0.
          YBB(NLK) = 4.
          NHB(NLK) = 4
          LHB(NLK) = 68

          NLK = NLK + 1
          NSQ(NLK) = 23
          DTP(NLK) = 'HD'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = '+/-2S/V All + SM + Layer'
          NBX(NLK) = 34
          NBY(NLK) = 39
          XBA(NLK) = -51.
          XBB(NLK) = 51.
          YBA(NLK) = 0.
          YBB(NLK) = 39.
          NHB(NLK) = 39
          LHB(NLK) = 72

          NLK = NLK + 1
          NSQ(NLK) = 24
          DTP(NLK) = 'HS'
          IF(L5) DTP(NLK) = 'HSW'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Raw D-Time DOS/Front R<80'
          NBX(NLK) = 60
          NBY(NLK) = 0
          XBA(NLK) = 80.
          XBB(NLK) = 380.
          YBA(NLK) = 0.
          YBB(NLK) = 0.
          NHB(NLK) = 1
          LHB(NLK) = 89

          NLK = NLK + 1
          NSQ(NLK) = 25
          DTP(NLK) = 'HD'
          IF(L5) DTP(NLK) = 'HDW'
          TL1(NLK) = 'FT Radial'
          TL4(NLK) = 'Raw D-Time DOS/Back Rbin'
          NBX(NLK) = 24
          NBY(NLK) = NBINR
          XBA(NLK) = 300.
          XBB(NLK) = 1740.
          YBA(NLK) = 0.
          YBB(NLK) = FLOAT(NBINR)
          NHB(NLK) = NBINR
          LHB(NLK) = 90
      ENDIF

      GMIN = 0.5
      GMAX = FLOAT(LENST) + 0.5
      CALL HBOOK1(170,'Run Statistics$',LENST,GMIN,GMAX,0.)

          NLK = NLK + 1
          NSQ(NLK) = 26
          DTP(NLK) = 'HS'
          IF(L5) DTP(NLK) = 'HSW'
          TL1(NLK) = 'FTD Monitoring'
          TL4(NLK) = 'Run Statistics'
          NBX(NLK) = LENST
          NBY(NLK) = 0
          XBA(NLK) = GMIN
          XBB(NLK) = GMAX
          YBA(NLK) = 0.
          YBB(NLK) = 0.
          NHB(NLK) = 1
          LHB(NLK) = 170
          IF(NRUN0.GE.59419.AND.NRUN0.LE.59922) NBX(NLK) = 65

      RETURN
      END
*CMZU:  8.04/00 07/07/96  12.33.21  by  Girish D. Patel
*CMZU:  7.00/12 07/06/95  16.44.53  by  Girish D. Patel
*CMZU:  5.01/06 22/10/93  13.26.41  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/06/93
      SUBROUTINE FPEAKF(IDH,area,xmax,thresh)
************************************************************************
*                                                                      *
* Find bin with max contents and set errors and contents to zero apart *
* from around MAXBIN - 4 to MAXBIN + 5                                 *
*                                                                      *
************************************************************************

*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEND.

      PARAMETER (NBIN=100)
      DIMENSION BAK(100),BAKE(100)
      CHARACTER*80 CTITL

      AREA = 0.0
      L = LMES
* fit back edge (DOS) of drift time distribution
      CALL HGIVE(IDH,CTITL,NX,XMI,XMA,NY,YMI,YMA,NWT,LOC)
      IF(NX.GT.NBIN) THEN
        WRITE(L,*) ' FPEAKF Histogram ',IDH,' has more than 100 bins '
        GOTO 100
      ENDIF
      BINW = (XMA-XMI)/FLOAT(NX)
      CALL HUNPAK(IDH,BAK,'HIST',1)
      CALL HUNPKE(IDH,BAKE,'HIST',1)
      YMAX = -1.
      IMAX = -1
      DO 10 I = 2 , NX
        IF(BAK(I).GT.YMAX) THEN
          YMAX = BAK(I)
          IMAX = I
        ENDIF
   10 CONTINUE

      IF(IMAX.EQ.-1) THEN
*       WRITE(L,*) ' FPEAKF Histogram ',IDH,' has no positive entries '
        GOTO 100
      ENDIF

      ISTART = IMAX - 4
      IF(ISTART.LT.1) ISTART = 1
      IEND   = IMAX + 5
      IF(IEND .GT.NX) IEND   = NX

      DO 20 I = 1 , NX
        IF(I.LT.ISTART .or. I.GT.IEND .or. BAK(I).LT.0.) THEN
          BAKE(I) = 0.0
          BAK(I) = 0.0
         ELSE
           AREA = AREA + BAK(I)*BINW
        ENDIF
   20 CONTINUE

      xmax = XMI + FLOAT(IMAX)*BINW
      thresh= xmax - 8.0*BINW

      CALL HPAK(IDH,BAK)
      CALL HPAKE(IDH,BAKE)

  100 RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 06/12/93  13.37.15  by  Girish D. Patel
*-- Author :    John V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      FUNCTION FM2SOV(T)
************************************************************************
*                                                                      *
* Symmetric double Gaussian plus quadratic background.                 *
*                                                                      *
* JVM  31/7/91                                                         *
************************************************************************

*KEEP,FCOMF.
      PARAMETER( NP = 8 )            ! number of fit parameters
      COMMON/FCOMF/PAR(NP),STAG
*KEND.

* PAR(1 to 3) ; Background = PAR(1) + PAR(2)*T + PAR(3)*T**2
* PAR(4)      ; Lower peak height
* PAR(5)      ; Upper peak height
* PAR(6)      ; Drift Velocity in microns/nsec
* PAR(7)      ; Timing Resolution in nsec
* PAR(8)      ; Asymmetry in nsec

      RMS = 0.5*SQRT(5.)*PAR(7)
      SEP = 2.0*STAG/PAR(6)
      FM2SOV = 0.0

      B   = PAR(1) + PAR(2)*T + PAR(3)*T*T
      IF( B.GT.0. ) THEN
      FM2SOV = B
      ENDIF

      F1  = ( (T+SEP+PAR(8))/RMS )**2
      IF( F1.LT.50. )THEN
      FM2SOV = FM2SOV + PAR(4)*EXP( -0.5*F1 )
      ENDIF

      F2  = ( (T-SEP+PAR(8))/RMS )**2
      IF( F2.LT.50. )THEN
      FM2SOV = FM2SOV + PAR(5)*EXP( -0.5*F2 )
      ENDIF

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 09/08/94  12.39.21  by  Girish D. Patel
*-- Author :    Girish D. Patel
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FQENDP
************************************************************************
*                                                                      *
* End of run processing for PLANAR Monitoring                          *
*                                                                      *
* JVM  29/04/93                                                        *
*                                                                      *
************************************************************************
*KEEP,FCOMF.
      PARAMETER( NP = 8 )            ! number of fit parameters
      COMMON/FCOMF/PAR(NP),STAG
*KEND.
*  Set wire stagger to correct value for use in FM2SOV

      STAG = 300.0

      CALL FVFITP( 1,22)                   ! Global      DON'T
      CALL FVFITP( 2,23)                   ! SM0         CHANGE
      CALL FVFITP( 3,24)                   ! SM1         THIS
      CALL FVFITP( 4,25)                   ! SM2         ORDER *!*!

      CALL FVFITP( 5,26)                   ! Layer 0
      CALL FVFITP( 6,27)                   ! Layer 1    Module 0
      CALL FVFITP( 7,28)                   ! Layer 2
      CALL FVFITP( 8,29)                   ! Layer 0
      CALL FVFITP( 9,30)                   ! Layer 1    Module 1
      CALL FVFITP(10,31)                   ! Layer 2
      CALL FVFITP(11,32)                   ! Layer 0
      CALL FVFITP(12,33)                   ! Layer 1    Module 1
      CALL FVFITP(13,34)                   ! Layer 2

      CALL FVFITP(14,1022)                 ! Global
      CALL FVFITP(15,1023)                 ! SM0       3-hit sum
      CALL FVFITP(16,1024)                 ! SM1
      CALL FVFITP(17,1025)                 ! SM2

      CALL FVFITP(18,1026)                 ! Layer 0
      CALL FVFITP(19,1027)                 ! Layer 1    Module 0
      CALL FVFITP(20,1028)                 ! Layer 2
      CALL FVFITP(21,1029)                 ! Layer 0
      CALL FVFITP(22,1030)                 ! Layer 1    Module 1
      CALL FVFITP(23,1031)                 ! Layer 2
      CALL FVFITP(24,1032)                 ! Layer 0
      CALL FVFITP(25,1033)                 ! Layer 1    Module 1
      CALL FVFITP(26,1034)                 ! Layer 2

      CALL FVFITP(27,2022)                 ! Global
      CALL FVFITP(28,2023)                 ! SM0       3-hit sum
      CALL FVFITP(29,2024)                 ! SM1
      CALL FVFITP(30,2025)                 ! SM2

      CALL FVFITP(31,2026)                 ! Layer 0
      CALL FVFITP(32,2027)                 ! Layer 1    Module 0
      CALL FVFITP(33,2028)                 ! Layer 2
      CALL FVFITP(34,2029)                 ! Layer 0
      CALL FVFITP(35,2030)                 ! Layer 1    Module 1
      CALL FVFITP(36,2031)                 ! Layer 2
      CALL FVFITP(37,2032)                 ! Layer 0
      CALL FVFITP(38,2033)                 ! Layer 1    Module 1
      CALL FVFITP(39,2034)                 ! Layer 2


********************************************************************
* Histogram only selected plots for monitoring ...******************


      CALL HMINIM(0,0.)
      CALL HIDOPT(3,'BLAC')
      CALL HIDOPT(7,'BLAC')
      CALL HIDOPT(8,'BLAC')
      CALL HIDOPT(9,'BLAC')
      CALL HIDOPT(10,'BLAC')
      CALL HIDOPT(11,'BLAC')
*JVM  CALL HIDOPT(12,'BLAC')
      CALL HIDOPT(13,'BLAC')
      CALL HIDOPT(14,'BLAC')
      CALL HIDOPT(15,'BLAC')
      CALL HIDOPT(16,'BLAC')
      CALL HIDOPT(17,'BLAC')
      CALL HIDOPT(18,'BLAC')


      CALL FSUMP

* End of monitoring histogram output *******************************
********************************************************************

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 06/12/93  13.52.02  by  Girish D. Patel
*-- Author :    John V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVFITP(NC,IDF)
************************************************************************
*                                                                      *
* Fit the Class I plot IDF to determine Drift Velocity and resolution  *
* JVM  24/9/91                                                         *
*                                                                      *
* Scale errors on fitted parameters by SQRT(CHISQ/NDF) for bad Chisq!? *
* JVM  29/7/92  not very sanitary, but takes care of some systematics  *
************************************************************************


*KEEP,FCOMF.
      PARAMETER( NP = 8 )            ! number of fit parameters
      COMMON/FCOMF/PAR(NP),STAG
*KEEP,FVOUTP.
      PARAMETER( MXC=40 )             ! maximum stored results
      COMMON/FVOUTP/VEL(MXC),EVEL(MXC),RMIC(MXC),EMIC(MXC),IDVF(MXC),
     &             SEGS(MXC),ESEG(MXC),ASYM(MXC),EASYM(MXC),
     &             SEGN(MXC),ESEGN(MXC),SEGF(MXC),ESEGF(MXC)
*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEND.
      CHARACTER*30 TITL

      EXTERNAL FM2SOV

      DATA IC/ 2/
      DIMENSION P(NP),ST0(NP),PMI0(NP),PMA0(NP),SIG(NP),COV(NP*(NP+1)/2)
      DIMENSION      ST(NP) ,PMI(NP) ,PMA(NP)
      DATA    P/0.0,0.0,0.0,300.,300.,40.0,4.0,0.0/
      DATA  ST0/10.,1.0,1.0, 30., 30., 4., 0.4,0.5/
      DATA PMI0/0.0,-99.,-99.,0.,  0.,10.0,1.0,-10./
      DATA PMA0/999.,99.,99.,9999.,9999.,80.0,20.,10./

* is there anything to fit ??
      IF( NC.GT.MXC )THEN
*       WRITE(LUNH,1002)IDF,MXC
 1002   FORMAT(1X,'*** FVFITP ID ',I10,' Max calls exceeded ',I10)
        RETURN
      ENDIF
        VEL(NC) = 0.0
        EVEL(NC)= 0.0
        RMIC(NC)= 0.0
        EMIC(NC)= 0.0
        IDVF(NC)= IDF
        SEGS(NC)= 0.0
        ESEG(NC)= 0.0
        SEGN(NC)= 0.0
        ESEGN(NC)= 0.0
        SEGF(NC)= 0.0
        ESEGF(NC)= 0.0
      IF( HSUM(IDF).LT.300. )THEN
*       WRITE(LUNH,1000)IDF,HSUM(IDF)
 1000   FORMAT(1X,'*** FVFITP ID ',I10,' Low contents',F10.1)
        RETURN
      ENDIF


      P(6) = 25.0          ! start at standard Full Field Drift V
      P(4) = HMAX(IDF)
      P(5) = P(4)
      P(1) = HMIN(IDF)
      PMA0(1) = HMAX(IDF)
      PMA0(4) = 2.0*HMAX(IDF)
      PMA0(5) = PMA0(4)

      CALL UCOPY( P,PAR,NP )
      CALL UCOPY( ST0,ST,NP )
      CALL UCOPY( PMI0,PMI,NP )
      CALL UCOPY( PMA0,PMA,NP )

      CALL HFIT(IDF,FM2SOV,NP,PAR,CHISQ,IC,SIG,COV,ST,PMI,PMA)
* compute scaling factor for errors .. ?? ..
      CALL HGIVE(IDF,TITL,NBIN,XMIN,XMAX,NY,YMI,YMA,NWT,LOC) ! get bin size
      SCER = SQRT( CHISQ/FLOAT(NBIN-NP) )
      IF( SCER.LT.1. ) SCER = 1.
* compute resolution in microns and print results
      VEL(NC)  = PAR(6)
      EVEL(NC) = SIG(6)*SCER
      RMIC(NC) = PAR(6)*PAR(7)
      EMIC(NC) = ( SIG(6)*PAR(7) )**2 + ( SIG(7)*PAR(6) )**2 +
     &         2.0*COV(27)*PAR(6)*PAR(7)
      IF(EMIC(NC).GT.0.0) THEN
        EMIC(NC) = SQRT(EMIC(NC))*SCER
      ELSE
        EMIC(NC) = -1.0
      ENDIF
      ASYM(NC) = PAR(8)
      EASYM(NC) = SIG(8)
*     WRITE(LUNH,9600)PAR(6),SIG(6),PAR(7),SIG(7),RMIC(NC),EMIC(NC)
*    & ,ASYM(NC),EASYM(NC)
*9600 FORMAT(/,1X,'Drift Velocity =',F10.2,' +/-',F6.2,' micr/nsec',
*    &       /,1X,'Resolution     =',F10.2,' +/-',F6.2,' nsec     ',
*    &       /,1X,'               =',F10.2,' +/-',F6.2,' microns  ',
*    &       /,1X,'Asymmetry      =',F10.2,' +/-',F6.2,' nsec     ')
*
* recompute RMIC in nsecs for compatibility with FSUMP
      RMIC(NC) = PAR(7)
      EMIC(NC) = SIG(7)*SCER

* compute number of fitted 4-hit track segments and error
      BIN = (XMAX-XMIN)/FLOAT(NBIN)
*     BIN = 3.0
      CON = 2.8024956/BIN                 ! Sqrt(10pi)/2*Bin size
* note than this constant includes the conversion factor of
* sqrt(5)/2 which converts PAR(7) to the actual RMS of the peaks.
      SEGS(NC) = (PAR(4)+PAR(5))*PAR(7)*CON   ! number of 4-hit segs
      DXDP4 = PAR(7)*CON
      DXDP5 = DXDP4
      DXDP7 = (PAR(4)+PAR(5))*CON
      ESEG(NC)=(DXDP4*SIG(4))**2+(DXDP5*SIG(5))**2+(DXDP7*SIG(7))**2
     &      +2.0*DXDP4*DXDP5*COV(23) +2.0*DXDP4*DXDP7*COV(25)
     &      +2.0*DXDP5*DXDP7*COV(29)
      IF(ESEG(NC).GT.0.0) THEN
        ESEG(NC)= SQRT( ESEG(NC) )*SCER
      ELSE
        ESEG(NC)= -1.0
      ENDIF
*     WRITE(LUNH,9601)SEGS(NC),ESEG(NC)
 9601 FORMAT(/,1X,'4-hit Segments =',F10.1,' +/-',F6.1,'          ')

      SEGF(NC) = PAR(4)*PAR(7)*CON   ! number of 4-hit segs
      DXDP4 = PAR(7)*CON
      DXDP7 = PAR(4)*CON
      ESEGF(NC)=(DXDP4*SIG(4))**2+(DXDP7*SIG(7))**2
     &      +2.0*DXDP4*DXDP7*COV(25)
      IF(ESEGF(NC).GT.0.0) THEN
        ESEGF(NC)= SQRT( ESEGF(NC) )*SCER
      ELSE
        ESEGF(NC)= -1.0
      ENDIF
*     WRITE(LUNH,9602)SEGF(NC),ESEGF(NC)
 9602 FORMAT(/,1X,'4-hit Far  Seg =',F10.1,' +/-',F6.1,'          ')

      SEGN(NC) = PAR(5)*PAR(7)*CON   ! number of 4-hit segs
      DXDP5 = PAR(7)*CON
      DXDP7 = PAR(5)*CON
      ESEGN(NC)=(DXDP5*SIG(5))**2+(DXDP7*SIG(7))**2
     &      +2.0*DXDP5*DXDP7*COV(29)
      IF(ESEGN(NC).GT.0.0) THEN
        ESEGN(NC)= SQRT( ESEGN(NC) )*SCER
      ELSE
        ESEGN(NC)= -1.0
      ENDIF
*     WRITE(LUNH,9603)SEGN(NC),ESEGN(NC)
 9603 FORMAT(/,1X,'4-hit Near Seg =',F10.1,' +/-',F6.1,'          ')

      RETURN
      END
*CMZU:  8.04/00 11/07/96  12.34.12  by  Girish D. Patel
*CMZU:  7.00/12 07/06/95  16.36.11  by  Girish D. Patel
*CMZU:  5.01/06 31/01/94  15.31.23  by  Girish D. Patel
*-- Author :    John V. Morris
      SUBROUTINE FSUMP
************************************************************************
*                                                                      *
* Summarise the results from a monitoring run.                         *
*                                                                      *
* JVM  10/10/91                                                        *
*                                                                      *
* Extend to show results per Supermodule including hits/event/layer    *
* JVM   1/11/91                                                        *
************************************************************************

      DIMENSION IOUT(6), FOUT(17)
*KEEP,FCOUNT.
      COMMON/FCOUNT/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FVOUTP.
      PARAMETER( MXC=40 )             ! maximum stored results
      COMMON/FVOUTP/VEL(MXC),EVEL(MXC),RMIC(MXC),EMIC(MXC),IDVF(MXC),
     &             SEGS(MXC),ESEG(MXC),ASYM(MXC),EASYM(MXC),
     &             SEGN(MXC),ESEGN(MXC),SEGF(MXC),ESEGF(MXC)
*KEEP,FTQRUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FTQRUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FHITLS.
      COMMON/FHITLS/ LHITSP(0:8), LHITSR(0:8)
*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEND.
*====================================================================

      PARAMETER( NP = 4 )            ! number of fit parameters
      Common/PawPar/ PAR(NP)

      EXTERNAL Fwiebl

      DATA IC/12/
      DIMENSION P(NP),ST0(NP),PMI0(NP),PMA0(NP),SIG(NP),COV(NP*(NP+1)/2)
      DIMENSION      ST(NP) ,PMI(NP) ,PMA(NP)
      DATA    P/0.0,0.0,2.5,0.0/
      DATA  ST0/100.,10.0,1.0,10./
      DATA PMI0/0.0,0.0,0.0,0.0/
      DATA PMA0/9999999.,2500.,5.,2500./

*====================================================================
      DIMENSION PERCY(10),RELEF(4),ERLEF(4),QWR(4)
      DIMENSION ABIEFF(13),ABINEF(13),ABIFEF(13)
      DIMENSION AVEC(19),BVEC(8),VVEC(18),HVEC(9),CVEC(9),TVEC(18)
      DIMENSION EVEC(39),PVEC(26)
      DIMENSION HSIG(3),CONTEN(60)
      DIMENSION BACK(13),EBACK(13),RTZERO(13),ETZERO(13),VELD(13)
      DIMENSION EVELD(13),LERR(13)
      DATA ICH/ 2/
      CHARACTER*20 UNITS
      DIMENSION UNITS(6)
      DIMENSION XEFF(9)
      DATA UNITS/' microns/nsec',' microns','   ',' per-cent',
     +           ' nsec           ',' from DT width'/

      CALL VZERO(PERCY,10)

      IF(IEVIN.GT.0)THEN
         DO 1099 J=1,6
 1099    PERCY(J) = FLOAT(ISTATP(J))*100.0/FLOAT(IEVIN)
      ENDIF
      IF( ISTATP(7).GT.0 )THEN
         DO 1098 J=7,10
 1098    PERCY(J) = FLOAT(ISTATP(J))/FLOAT(ISTATP(7))
      ENDIF

      DO 10 IVD = 1 , 13

        IF((SEGS(13+IVD) + SEGS(26+IVD)).EQ.0.0) THEN
          ABIEFF(IVD) = 0.0
        ELSE
          ABIEFF(IVD) = SEGS(13+IVD) / (SEGS(13+IVD) + SEGS(26+IVD))
        ENDIF
        IF((SEGN(13+IVD) + SEGN(26+IVD)).EQ.0.0) THEN
          ABINEF(IVD) = 0.0
        ELSE
          ABINEF(IVD) = SEGN(13+IVD) / (SEGN(13+IVD) + SEGN(26+IVD))
        ENDIF
        IF((SEGF(13+IVD) + SEGF(26+IVD)).EQ.0.0) THEN
          ABIFEF(IVD) = 0.0
        ELSE
          ABIFEF(IVD) = SEGF(13+IVD) / (SEGF(13+IVD) + SEGF(26+IVD))
        ENDIF
        EVEC(IVD)   = ABIEFF(IVD)
        EVEC(IVD+13)= ABINEF(IVD)
        EVEC(IVD+26)= ABIFEF(IVD)

*       CALL HUNPAK(38,CONTEN,'SLIX',IVD)
*       CALL HPAK(138,CONTEN)
*       CALL HUNPAK(39,CONTEN,'SLIX',IVD)
*       CALL HPAK(139,CONTEN)
        IDB = 137 + IVD
        IDF = 150 + IVD

* fit back edge (DOS) of drift time distribution
      IF( HMAX(IDB).GT.250. )THEN
*         CALL FPEAKF(IDB)
*         CALL HFITGA(IDB,G1,G2,G3,GXHI,ICH,HSIG)
*         S6701 = GXHI
*         IF( S6701.GT.1. ) THEN
*            S6701 = SQRT(S6701)
*         ELSE
*            S6701 = 1.0
*         ENDIF
*         CALL HMINIM(IDB,-500.)
*        CALL HPRINT(IDB) ! DOS of Drift Time
* save back edge position and error ...
*         BACK(IVD) = G2
*         EBACK(IVD) = HSIG(2)*S6701
*         LERR(IVD) = 0
*====================================================================
      CALL FPEAKF(IDB,area,xmax,thresh)
      P(1) = area
      P(2) = xmax
      P(3) = 2.5
      P(4) = thresh
      PMA0(1) = area*5.
      PMA0(2) = xmax*2.
      PMA0(4) = thresh*2.

      CALL UCOPY( P,PAR,NP )
      CALL UCOPY( ST0,ST,NP )
      CALL UCOPY( PMI0,PMI,NP )
      CALL UCOPY( PMA0,PMA,NP )

      CALL HFIT(IDB,Fwiebl,NP,PAR,CHISQ,IC,SIG,COV,ST,PMI,PMA)
         CALL HMINIM(IDB,-500.)
         CALL HPRINT(IDB) ! DOS of Drift Time
* save back edge position and error ...
         SCER = SQRT(CHISQ/6.0)
         IF(SCER.lt.1.0) SCER = 1.0
         BACK(IVD) = PAR(2)
         EBACK(IVD) = SIG(2)*SCER
         LERR(IVD) = 0
*====================================================================
      ELSE
         LERR(IVD) = 1
         BACK(IVD) = 0.0
         EBACK(IVD)= 0.0
      ENDIF

* fit front edge (DOS) of drift time distribution
      IF( HMAX(IDF).GT.250. )THEN
         CALL FPEAKF(IDF,area,xmax,thresh)
         CALL HFITGA(IDF,G1,G2,G3,GXHI,ICH,HSIG)
         CALL HMINIM(IDF,-500.)
*        CALL HPRINT(IDF) ! DOS of Drift Time
         S6702 = GXHI
         IF( S6702.GT.1. )THEN
            S6702 = SQRT(S6702)
         ELSE
            S6702 = 1.0
         ENDIF
* compute raw Tzero from front edge and drift velocity from back-front
         RTZERO(IVD) = G2
         ETZERO(IVD) = HSIG(2)*S6702
      ELSE
         LERR(IVD)   = LERR(IVD) + 1
         RTZERO(IVD) = 0.
         ETZERO(IVD) = 0.
      ENDIF

      IF(LERR(IVD).EQ.0) THEN
         VELD(IVD) = 28100.0/(BACK(IVD)-RTZERO(IVD))
         EVELD(IVD) = VELD(IVD)*SQRT(ETZERO(IVD)**2 + EBACK(IVD)*2)
     &                        /(BACK(IVD)-RTZERO(IVD))
         IF(RMIC(1).GT.0.0 .AND. IVD.EQ.1) THEN
           EPCNT = SQRT( (EVELD(IVD)/VELD(IVD))**2
     &                 + (EMIC(1)/RMIC(1))**2 )
           RMIC(1)= RMIC(1)*VELD(IVD)
           EMIC(1)= RMIC(1)*EPCNT
         ENDIF
      ELSE
         VELD(IVD)   = 0.
         EVELD(IVD)  = 0.
         IF(IVD.EQ.1) THEN
           RMIC(1)= 0.
           EMIC(1)= 0.
         ENDIF
      ENDIF

      PVEC(IVD)   = VELD(IVD)
      PVEC(IVD+13)= EVELD(IVD)

   10 CONTINUE

* relative efficiencies/wire in cell
      NNMAX = 0
      DO 1080 JW=1,4
         IDH = 13 + JW
         NN = NINT( HSUM(IDH) )
         QWR(JW) = HSTATI(IDH,1,'HIST',1)
         IF( NN.GT.NNMAX ) NNMAX=NN
         RELEF(JW) = FLOAT(NN)
         ERLEF(JW) = SQRT( RELEF(JW) )
 1080 CONTINUE
      EFCEN = 0.0
      ERCEN = 0.0
      IF( NNMAX.GT.0 ) THEN
         EFCEN = ( RELEF(2)+RELEF(3) )*100.0/( RELEF(1)+RELEF(4) )
         ERCEN = SQRT( RELEF(2)+RELEF(3) )
         ERCEN = 100.0*ERCEN/( RELEF(1)+RELEF(4) )
         DO 1081 JW=1,4
            RELEF(JW) = 100.0*RELEF(JW)/FLOAT(NNMAX)
            ERLEF(JW) = 100.0*ERLEF(JW)/FLOAT(NNMAX)
 1081    CONTINUE
      ENDIF

* compute track segments per FRPE and per digitising
      TFR = SEGS(1)/FLOAT( ISTATP(1) )
      ETF = ESEG(1)/FLOAT( ISTATP(1) )
      TDG = SEGS(1)*400.0/FLOAT( ISTATP(11) )
      EDG = ESEG(1)*400.0/FLOAT( ISTATP(11) )
* mean number of hits per FRPE bank
      HPE = FLOAT(ISTATP(11))/FLOAT(ISTATP(1))

* fill arrays for routine FMOUTP ...
      IOUT(1) = NRUN0
      IOUT(2) = NDATE0
      IOUT(3) = NTIME0
      IOUT(4) = NPRES0
      IOUT(5) = ISTATP(1)

      FOUT(1) = HPE
      FOUT(2) = TFR
      FOUT(3) = ETF
      FOUT(4) = TDG
      FOUT(5) = EDG
      FOUT(6) = VEL(1)
      FOUT(7) = EVEL(1)
      FOUT(8) = VELD(1)
      FOUT(9) = EVELD(1)
      FOUT(12)= RMIC(1)
      FOUT(13)= EMIC(1)
      FOUT(14)= RTZERO(1)
      FOUT(15)= ETZERO(1)
      FOUT(16)= EFCEN
      FOUT(17)= ERCEN

      AVQ = HSTATI(18,1,'HIST',1)
      RMS = HSTATI(18,2,'HIST',2)
      XN  = HSUM(18)
      IF(XN.GT.0.0) RMS = RMS/SQRT(XN)
      FOUT(10)= EXP(AVQ)
      FOUT(11)= RMS
      DO 3001 NSM=0,2
         NL0 = NSM*3
         HLE0 = FLOAT( LHITSP(NL0) )/FLOAT(ISTATP(1))
         HLE1 = FLOAT( LHITSP(NL0+1) )/FLOAT(ISTATP(1))
         HLE2 = FLOAT( LHITSP(NL0+2) )/FLOAT(ISTATP(1))
         HVEC(NL0+1) = HLE0
         HVEC(NL0+2) = HLE1
         HVEC(NL0+3) = HLE2
 3001 CONTINUE
 3101 FORMAT(1X)

      DO 3201 NSM=0,2
         NL0 = NSM*3
         CLE0 = SEGS(NL0+5)/FLOAT(ISTATP(1))
         CLE1 = SEGS(NL0+6)/FLOAT(ISTATP(1))
         CLE2 = SEGS(NL0+7)/FLOAT(ISTATP(1))
         CVEC(NL0+1) = CLE0
         CVEC(NL0+2) = CLE1
         CVEC(NL0+3) = CLE2
 3201 CONTINUE

      DO 3002 NSM=0,2
        VVEC(NSM*2+1) = VEL(NSM+2)
        VVEC(NSM*2+2) = EVEL(NSM+2)
 3002 CONTINUE
      DO 3022 NSO=0,8
         TVEC(NSO+1)  = VEL(NSO+5)
         TVEC(NSO+10) = EVEL(NSO+5)
 3022 CONTINUE
      DO 3003 NSM=0,2
        VVEC(NSM*2+7) = RMIC(NSM+2)
        VVEC(NSM*2+8) = EMIC(NSM+2)
 3003 CONTINUE
      DO 3004 NSM=0,2
         AVQ = HSTATI(19+NSM,1,'HIST',1)
         RMS = HSTATI(19+NSM,2,'HIST',2)
         XN = HSUM(19+NSM)
         IF(XN.GT.0.0) RMS = RMS/SQRT(XN)
         VVEC(NSM*2+13) = AVQ
         VVEC(NSM*2+14) = RMS
 3004 CONTINUE
*
* IOUT(6) is a flag to indicate if it was a LUMI run & if HV was on
* The information is from the database.
* UNITS part means:
* 0 means that bank was found on database and H1L >  0
* 1 means that bank was found on database and H1L <= 0
* 2 means that bank was NOT found on database
* TENS  part means:
* 0 means HV was ON
* 1 means HV was OFF
* 2 means that bank was NOT found on database
      IF(ILRET.EQ.0) THEN
        IF(H1L.GT.0.0) THEN
          IOUT(6) = 0 + IFPHV*10
        ELSE
          IOUT(6) = 1 + IFPHV*10
        ENDIF
      ELSE
        IOUT(6) = 2 + IFPHV*10
      ENDIF

      AVEC(1) = FLOAT(IOUT(5))
      DO 100 I = 1 , 17
        AVEC(1+I) = FOUT(I)
        IF(I.LT.5) BVEC(I*2-1) = RELEF(I)
        IF(I.LT.5) BVEC(I*2  ) = QWR(I)
  100 CONTINUE
      AVEC(19) = FLOAT(IFPHV)

      CALL SVEC( 9,0,PVEC)
      CALL SVEC(10,0,EVEC)
      CALL SVEC(11,0,AVEC)
      CALL SVEC(12,0,BVEC)
      CALL SVEC(13,0,VVEC)
      CALL SVEC(14,0,HVEC)
      CALL SVEC(15,0,CVEC)
      CALL SVEC(16,0,TVEC)


      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZ :  5.02/00 07/09/94  17.13.18  by  Unknown
*CMZU:  5.01/06 02/11/93  16.55.44  by  Girish D. Patel
*-- Author :    Girish D. Patel
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FMOUT(IRUN,ICODE)
************************************************************************
*                                                                      *
* Output a minimum of information to an ntuple that has one row entered*
* for every run processed, even if the subsequent analysis failed for  *
* any reason.                                                          *
*                                                                      *
* GDP 16/8/94                                                          *
*                                                                      *
************************************************************************

*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEEP,FCOUNT.
      COMMON/FCOUNT/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEND.
      DIMENSION AVEC(4)

      IF(ICODE.EQ.-10) THEN
        CALL GETEAR(IRUN,IDATE,ITIME,IBFLD,IPRESS,IFR,IFP,IRET)
        IF(IRET.EQ.0) THEN
          IFRHV = IFR
          IFPHV = IFP
        ELSE
          IFRHV = 2
          IFPHV = 2
        ENDIF
      ENDIF

      AVEC(1) = IRUN
      AVEC(2) = ICODE
      AVEC(3) = IFRHV
      AVEC(4) = IFPHV
      CALL SVEC(2,0,AVEC)

*     WRITE(6,*) ' FMOUT ',IRUN,ICODE,IFRHV,IFPHV, ' stored'

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 13/09/93  11.07.59  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/06/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FDEADP
************************************************************************
*                                                                      *
*                                                                      *
************************************************************************

      PARAMETER (NX=32)
      PARAMETER (NY=36)
      DIMENSION CON(NX,NY),YMAX(32,3),YTOT(32,3),ZMAX(NY)

      CALL HUNPAK(1,CON,'HIST',1)

      CALL VZERO(ZMAX,NY)
      CALL VZERO(YMAX,96)
      CALL VZERO(YTOT,96)

      DO 10 K = 1 , 3
        DO 10 J = (K-1)*12+1 , K*12
          DO 10 I = 1 , NX
            IF(CON(I,J).GT.YMAX(I,K)) THEN
              YMAX(I,K) = CON(I,J)
            ENDIF
          YTOT(I,K) = YTOT(I,K) + CON(I,J)
   10 CONTINUE

      DO 20 K = 1 , 3
        DO 20 J = (K-1)*12+1 , K*12
          DO 20 I = 1 , NX
            CON(I,J) = CON(I,J)/YMAX(I,K)
            IF(CON(I,J).GT.ZMAX(J)) THEN
              ZMAX(J) = CON(I,J)
            ENDIF
   20 CONTINUE

      DO 30 K = 1 , 3
        DO 30 J = (K-1)*12+1 , K*12
          DO 30 I = 1 , NX
            CON(I,J) = CON(I,J)/ZMAX(J)
            IF(CON(I,J).LT.0.02) CALL SHD(17,0,FLOAT(I-1),FLOAT(J))
            CALL SHDW(18,0,FLOAT(I-1),FLOAT(J),CON(I,J))
            CALL SHS (19,0,CON(I,J))
   30 CONTINUE

  100 RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 06/12/93  14.09.05  by  Girish D. Patel
*-- Author :    John V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FQENDR
************************************************************************
*                                                                      *
* End of run processing for RADIAL Monitoring                          *
*                                                                      *
* JVM  29/04/93                                                        *
*                                                                      *
************************************************************************
*KEEP,FCOMF.
      PARAMETER( NP = 8 )            ! number of fit parameters
      COMMON/FCOMF/PAR(NP),STAG
*KEND.
*  Set wire stagger to correct value for use in FM2SOV

      STAG = 288.0

      CALL FVFITR( 1,72)                   ! Global      DON'T
      CALL FVFITR( 2,73)                   ! SM0         CHANGE
      CALL FVFITR( 3,74)                   ! SM1         THIS
      CALL FVFITR( 4,75)                   ! SM2         ORDER *!*!

      CALL FVFITR( 5,76)                   ! SM0 Layer 1
      CALL FVFITR( 6,77)                   ! SM0 Layer 2
      CALL FVFITR( 7,78)                   ! SM0 Layer 3
      CALL FVFITR( 8,79)                   ! SM1 Layer 4
      CALL FVFITR( 9,80)                   ! SM1 Layer 5
      CALL FVFITR(10,81)                   ! SM1 Layer 6
      CALL FVFITR(11,82)                   ! SM2 Layer 7
      CALL FVFITR(12,83)                   ! SM2 Layer 8
      CALL FVFITR(13,84)                   ! SM2 Layer 9

      CALL FVFITR(14,1072)                 ! Global
      CALL FVFITR(15,1073)                 ! SM0       3-hit sum
      CALL FVFITR(16,1074)                 ! SM1
      CALL FVFITR(17,1075)                 ! SM2

      CALL FVFITR(18,1076)                 ! Layer 0
      CALL FVFITR(19,1077)                 ! Layer 1    Module 0
      CALL FVFITR(20,1078)                 ! Layer 2
      CALL FVFITR(21,1079)                 ! Layer 0
      CALL FVFITR(22,1080)                 ! Layer 1    Module 1
      CALL FVFITR(23,1081)                 ! Layer 2
      CALL FVFITR(24,1082)                 ! Layer 0
      CALL FVFITR(25,1083)                 ! Layer 1    Module 1
      CALL FVFITR(26,1084)                 ! Layer 2

      CALL FVFITR(27,2072)                 ! Global
      CALL FVFITR(28,2073)                 ! SM0       3-hit sum
      CALL FVFITR(29,2074)                 ! SM1
      CALL FVFITR(30,2075)                 ! SM2

      CALL FVFITR(31,2076)                 ! Layer 0
      CALL FVFITR(32,2077)                 ! Layer 1    Module 0
      CALL FVFITR(33,2078)                 ! Layer 2
      CALL FVFITR(34,2079)                 ! Layer 0
      CALL FVFITR(35,2080)                 ! Layer 1    Module 1
      CALL FVFITR(36,2081)                 ! Layer 2
      CALL FVFITR(37,2082)                 ! Layer 0
      CALL FVFITR(38,2083)                 ! Layer 1    Module 1
      CALL FVFITR(39,2084)                 ! Layer 2


********************************************************************
* Histogram only selected plots for monitoring ...******************


      CALL HMINIM(0,0.)
      CALL HIDOPT(40,'BLAC')
      CALL HIDOPT(44,'BLAC')
      CALL HIDOPT(45,'BLAC')
      CALL HIDOPT(46,'BLAC')
*     CALL HIDOPT(47,'BLAC')
*     CALL HIDOPT(48,'BLAC')
      CALL HIDOPT(49,'BLAC')
      CALL HIDOPT(50,'BLAC')
      CALL HIDOPT(51,'BLAC')
      CALL HIDOPT(52,'BLAC')
      CALL HIDOPT(53,'BLAC')
*JVM  CALL HIDOPT(54,'BLAC')
      CALL HIDOPT(55,'BLAC')
      CALL HIDOPT(56,'BLAC')
      CALL HIDOPT(57,'BLAC')
      CALL HIDOPT(58,'BLAC')
      CALL HIDOPT(59,'BLAC')
      CALL HIDOPT(60,'BLAC')
      CALL HIDOPT(61,'BLAC')
      CALL HIDOPT(62,'BLAC')
      CALL HIDOPT(63,'BLAC')
      CALL HIDOPT(64,'BLAC')
      CALL HIDOPT(65,'BLAC')
      CALL HIDOPT(66,'BLAC')
      CALL HIDOPT(67,'BLAC')
      CALL HIDOPT(68,'BLAC')
      CALL HIDOPT(89,'PERR')
      CALL HIDOPT(88,'PERR')


      CALL FSUMR

* End of monitoring histogram output *******************************
********************************************************************

      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 06/12/93  14.14.35  by  Girish D. Patel
*-- Author :    John V. Morris
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FVFITR(NC,IDF)
************************************************************************
*                                                                      *
* Fit the Class I plot IDF to determine Drift Velocity and resolution  *
* JVM  24/9/91                                                         *
*                                                                      *
* Scale errors on fitted parameters by SQRT(CHISQ/NDF) for bad Chisq!? *
* JVM  29/7/92  not very sanitary, but takes care of some systematics  *
************************************************************************


*KEEP,FCOMF.
      PARAMETER( NP = 8 )            ! number of fit parameters
      COMMON/FCOMF/PAR(NP),STAG
*KEEP,FVOUTR.
      PARAMETER( MXC=40 )             ! maximum stored results
      COMMON/FVOUTR/VEL(MXC),EVEL(MXC),RMIC(MXC),EMIC(MXC),IDVF(MXC),
     &             SEGS(MXC),ESEG(MXC),ASYM(MXC),EASYM(MXC),
     &             SEGN(MXC),ESEGN(MXC),SEGF(MXC),ESEGF(MXC)
*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEND.
      CHARACTER*30 TITL

      EXTERNAL FM2SOV

      DATA IC/ 2/
      DIMENSION P(NP),ST0(NP),PMI0(NP),PMA0(NP),SIG(NP),COV(NP*(NP+1)/2)
      DIMENSION      ST(NP) ,PMI(NP) ,PMA(NP)
      DATA    P/0.0,0.0,0.0,300.,300.,40.0,4.0,0.0/
      DATA  ST0/10.,1.0,1.0, 30., 30., 4., 0.4,0.5/
      DATA PMI0/0.0,-99.,-99.,0.,  0.,10.0,1.0,-10./
      DATA PMA0/999.,99.,99.,9999.,9999.,80.0,20.,10./

* is there anything to fit ??
      IF( NC.GT.MXC )THEN
*       WRITE(LUNH,1002)IDF,MXC
 1002   FORMAT(1X,'*** FVFITR ID ',I10,' Max calls exceeded ',I10)
        RETURN
      ENDIF
        VEL(NC) = 0.0
        EVEL(NC)= 0.0
        RMIC(NC)= 0.0
        EMIC(NC)= 0.0
        IDVF(NC)= IDF
        SEGS(NC)= 0.0
        ESEG(NC)= 0.0
        SEGN(NC)= 0.0
        ESEGN(NC)= 0.0
        SEGF(NC)= 0.0
        ESEGF(NC)= 0.0
      IF( HSUM(IDF).LT.300. )THEN
*       WRITE(LUNH,1000)IDF,HSUM(IDF)
 1000   FORMAT(1X,'*** FVFITR ID ',I10,' Low contents',F10.1)
        RETURN
      ENDIF


      P(6) = 25.0          ! start at standard Full Field Drift V
      P(4) = HMAX(IDF)
      P(5) = P(4)
      P(1) = HMIN(IDF)
      PMA0(1) = HMAX(IDF)
      PMA0(4) = 2.0*HMAX(IDF)
      PMA0(5) = PMA0(4)

      CALL UCOPY( P,PAR,NP )
      CALL UCOPY( ST0,ST,NP )
      CALL UCOPY( PMI0,PMI,NP )
      CALL UCOPY( PMA0,PMA,NP )

      CALL HFIT(IDF,FM2SOV,NP,PAR,CHISQ,IC,SIG,COV,ST,PMI,PMA)
* compute scaling factor for errors .. ?? ..
      CALL HGIVE(IDF,TITL,NBIN,XMIN,XMAX,NY,YMI,YMA,NWT,LOC) ! get bin size
      SCER = SQRT( CHISQ/FLOAT(NBIN-NP) )
      IF( SCER.LT.1. ) SCER = 1.
* compute resolution in microns and print results
      VEL(NC)  = PAR(6)
      EVEL(NC) = SIG(6)*SCER
      RMIC(NC) = PAR(6)*PAR(7)
      EMIC(NC) = ( SIG(6)*PAR(7) )**2 + ( SIG(7)*PAR(6) )**2 +
     &         2.0*COV(27)*PAR(6)*PAR(7)
      IF(EMIC(NC).GT.0.0) THEN
        EMIC(NC) = SQRT(EMIC(NC))*SCER
      ELSE
        EMIC(NC) = -1.0
      ENDIF
      ASYM(NC) = PAR(8)
      EASYM(NC)= SIG(8)

*     WRITE(LUNH,9600)PAR(6),SIG(6),PAR(7),SIG(7),RMIC(NC),EMIC(NC)
*    & ,ASYM(NC),EASYM(NC)
*9600 FORMAT(/,1X,'Drift Velocity =',F10.2,' +/-',F6.2,' micr/nsec',
*    &       /,1X,'Resolution     =',F10.2,' +/-',F6.2,' nsec     ',
*    &       /,1X,'               =',F10.2,' +/-',F6.2,' microns  ',
*    &       /,1X,'Asymmetry      =',F10.2,' +/-',F6.2,' nsec     ')

* recompute RMIC in nsecs for compatibility with FSUMR
      RMIC(NC) = PAR(7)
      EMIC(NC) = SIG(7)*SCER

* compute number of fitted 4-hit track segments and error
      BIN = (XMAX-XMIN)/FLOAT(NBIN)
*     BIN = 3.0
      CON = 2.8024956/BIN                 ! Sqrt(10pi)/2*Bin size
* note than this constant includes the conversion factor of
* sqrt(5)/2 which converts PAR(7) to the actual RMS of the peaks.
      SEGS(NC) = (PAR(4)+PAR(5))*PAR(7)*CON   ! number of 4-hit segs
      DXDP4 = PAR(7)*CON
      DXDP5 = DXDP4
      DXDP7 = (PAR(4)+PAR(5))*CON
      ESEG(NC)=(DXDP4*SIG(4))**2+(DXDP5*SIG(5))**2+(DXDP7*SIG(7))**2
     &      +2.0*DXDP4*DXDP5*COV(23) +2.0*DXDP4*DXDP7*COV(25)
     &      +2.0*DXDP5*DXDP7*COV(29)
      IF(ESEG(NC).GT.0.0) THEN
        ESEG(NC)= SQRT( ESEG(NC) )*SCER
      ELSE
        ESEG(NC)= -1.0
      ENDIF
*     WRITE(LUNH,9601)SEGS(NC),ESEG(NC)
 9601 FORMAT(/,1X,'4-hit Segments =',F10.1,' +/-',F6.1,'          ')

      SEGF(NC) = PAR(4)*PAR(7)*CON   ! number of 4-hit segs
      DXDP4 = PAR(7)*CON
      DXDP7 = PAR(4)*CON
      ESEGF(NC)=(DXDP4*SIG(4))**2+(DXDP7*SIG(7))**2
     &      +2.0*DXDP4*DXDP7*COV(25)
      IF(ESEGF(NC).GT.0.0) THEN
        ESEGF(NC)= SQRT( ESEGF(NC) )*SCER
      ELSE
        ESEGF(NC)= -1.0
      ENDIF
*     WRITE(LUNH,9602)SEGF(NC),ESEGF(NC)
 9602 FORMAT(/,1X,'4-hit Far  Seg =',F10.1,' +/-',F6.1,'          ')

      SEGN(NC) = PAR(5)*PAR(7)*CON   ! number of 4-hit segs
      DXDP5 = PAR(7)*CON
      DXDP7 = PAR(5)*CON
      ESEGN(NC)=(DXDP5*SIG(5))**2+(DXDP7*SIG(7))**2
     &      +2.0*DXDP5*DXDP7*COV(29)
      IF(ESEGN(NC).GT.0.0) THEN
        ESEGN(NC)= SQRT( ESEGN(NC) )*SCER
      ELSE
        ESEGN(NC)= -1.0
      ENDIF
*     WRITE(LUNH,9603)SEGN(NC),ESEGN(NC)
 9603 FORMAT(/,1X,'4-hit Near Seg =',F10.1,' +/-',F6.1,'          ')

      RETURN
      END
*CMZU:  8.04/00 06/07/96  16.31.57  by  Girish D. Patel
*CMZU:  7.00/12 07/06/95  16.54.34  by  Girish D. Patel
*CMZU:  5.01/06 04/02/94  15.49.28  by  Girish D. Patel
*-- Author :    John V. Morris
      SUBROUTINE FSUMR
************************************************************************
*                                                                      *
* Summarise the results from a monitoring run.                         *
*                                                                      *
* JVM  10/10/91                                                        *
*                                                                      *
* Extend to show results per Supermodule including hits/event/layer    *
* JVM   1/11/91                                                        *
************************************************************************
      PARAMETER( TWOPI=6.283185)
*KEEP,FNBINR.
      PARAMETER( NBINR=40 )           ! number of radius bins
*KEEP,FTQRUN.
      LOGICAL PLANAR,RADIAL
      COMMON /FTQRUN/  NRUN,NRUN0,NRUN1,MAXEV,PLANAR,RADIAL
*KEEP,FVOUTR.
      PARAMETER( MXC=40 )             ! maximum stored results
      COMMON/FVOUTR/VEL(MXC),EVEL(MXC),RMIC(MXC),EMIC(MXC),IDVF(MXC),
     &             SEGS(MXC),ESEG(MXC),ASYM(MXC),EASYM(MXC),
     &             SEGN(MXC),ESEGN(MXC),SEGF(MXC),ESEGF(MXC)
*KEEP,FCOUNT.
      COMMON/FCOUNT/ NDATE0,NTIME0,ISTATP(20),ISTATR(20),IFRHV,IFPHV,
     &               NEVENT,NFIEL0,NPRES0,NECUR0,NPCUR0,IRTE0,IRTP0,
     &               IEVIN,NFPEVT,NHITSP,NFREVT,NHITSR,NMIN92,
     &               TOTL,H1L,RTIME,REFF,ILRET
*     TOTL   total run luminosity (mb^-1)
*     H1L    H1 gated run luminosity (mb^-1)
*     RTIME  total run time (sec)
*     REFF   run efficiency = (1 - dead_time/run_time)
*     ILRET  return flag: 0 - ok,  1 - no inf. found in H1DB
*KEEP,FHITLS.
      COMMON/FHITLS/ LHITSP(0:8), LHITSR(0:8)
*KEEP,FHLUN.
      COMMON/FHLUN/ LUNH, LUNS, LMES, IL4L5
*KEND.
      COMMON /QUEST/ IQUEST(100)
      DIMENSION  IOUT(6), FOUT(17)
      DIMENSION PERCY(4)
      DIMENSION RELEF(12),ERLEF(12),QWR(12)
      DIMENSION ABIEFF(13),ABINEF(13),ABIFEF(13)
      DIMENSION AVEC(19),BVEC(24),HVEC(9),CVEC(9),VVEC(18),TVEC(18)
      DIMENSION EVEC(39)
      DIMENSION HSIG(3)
      DIMENSION AR(2),ASIG(2)
      DATA ICH/ 2/
      CHARACTER*20 UNITS
      DIMENSION UNITS(6)
      DIMENSION XEFF(9)
      DIMENSION C6703(NBINR),E6703(NBINR)
      DATA UNITS/' microns/nsec',' microns','   ',' per-cent',
     +           ' nsec           ',' from DT width'/

      BETA = TAN(TWOPI/96.)

      CALL VZERO(PERCY,4)
      IF(IEVIN.GT.0)THEN
         DO 1099 J=1,4
 1099    PERCY(J) = FLOAT(ISTATR(J))*100.0/FLOAT(IEVIN)
      ENDIF

* fit back edge (DOS) of TOTAL drift time distribution
      NPOL   = 0
      NBINST = 3*NBINR/8 + 1
      NBINEN = 6*NBINR/8
      DO 69011 J = 1 , NBINR
         N = NINT( HMAX(89+J) )
*     WRITE(LMES,*) ' FSUMR HMAX  FOR 89+',J,' = ',N
         IF( N.GT.250 )THEN
            CALL FPEAKF(89+J,area,xmax,thresh)
            CALL HFITGA(89+J,G1,G2,G3,GXHI,ICH,HSIG)
            S6701 = GXHI
            IF( S6701.GT.1. ) THEN
               S6701 = SQRT(S6701)
            ELSE
               S6701 = 1.0
            ENDIF
            CALL HMINIM(89+J,-100.)
* save back edge position and error ...
            BACK = G2
            C6703(J) = BACK
            EBACK  = HSIG(2)*S6701
            IF(J.GE.NBINST.and.J.LE.NBINEN) THEN
               NPOL = NPOL + 1
               E6703(J) = EBACK
            ELSE
               E6703(J) = 0.0
            ENDIF
*       WRITE(LMES,*) ' FSUMR 89+',J,BACK,HSIG(2),HSIG(2)*S6701,GXHI
         ELSE
            C6703(J) = 0.0
            E6703(J) = 0.0
         ENDIF

69011 CONTINUE

      CALL HPAK(88,C6703)
      CALL HPAKE(88,E6703)
      IF(NPOL.GT.10) THEN
        CALL HFITPO(88,2,AR,GXHI,ICH,ASIG)
*       CALL HPRINT(88)            ! DOS/Back vs radius

        SLD = AR(2)
        ESLD = ASIG(2)
        VELD = BETA/AR(2)*10000.
        EVELD = VELD*ASIG(2)/AR(2)
        IF(RMIC(1).GT.0.0) THEN
          EPCNT = SQRT( (EVELD/VELD)**2 + (EMIC(1)/RMIC(1))**2 )
          RMIC(1)= RMIC(1)*VELD
          EMIC(1)= RMIC(1)*EPCNT
        ENDIF
      ELSE
        VELD   = 0.
        EVELD  = 0.
      ENDIF



* fit front edge (DOS) of drift time distribution
      IF( HMAX(89).GT.250. )THEN
         CALL FPEAKF(89,area,xmax,thresh)
         CALL HFITGA(89,G1,G2,G3,GXHI,ICH,HSIG)
         CALL HMINIM(89,-100.)
*        CALL HPRINT(89) ! DOS of Drift Time
         S6702 = GXHI
         IF( S6702.GT.1. )THEN
            S6702 = SQRT(S6702)
         ELSE
            S6702 = 1.0
         ENDIF
* compute raw Tzero from front edge and drift velocity from back-front
         RTZERO = G2
         ETZERO = HSIG(2)*S6702
      ELSE
         RTZERO = 0.
         ETZERO = 0.
      ENDIF

* relative efficiencies/wire in radial cell wires 1 - 12
      NNMAX = 0
      DO 1080 JW=1,12
         IDH = 55 + JW
         NN = NINT( HSUM(IDH) )
         QWR(JW) = HSTATI(IDH,1,'HIST',1)
         IF( NN.GT.NNMAX ) NNMAX=NN
         RELEF(JW) = FLOAT(NN)
         ERLEF(JW) = SQRT( RELEF(JW) )
 1080 CONTINUE
      EFCEN = 0.0
      ERCEN = 0.0
      IF( NNMAX.GT.0 ) THEN
         EFCEN = ( RELEF(1)+RELEF(2)+RELEF(3)+RELEF(10)+RELEF(11)
     &            +RELEF(12) )*100.0 /(RELEF(4)+RELEF(5)+RELEF(6)
     &            +RELEF(7)+RELEF(8)+RELEF(9) )
         ERCEN = SQRT( RELEF(1)+RELEF(2)+RELEF(3)+RELEF(10)+RELEF(11)
     &            +RELEF(12) )
         ERCEN = 100.0*ERCEN/( RELEF(4)+RELEF(5)+RELEF(6)
     &                        +RELEF(7)+RELEF(8)+RELEF(9) )
         DO 1081 JW=1,12
            RELEF(JW) = 100.0*RELEF(JW)/FLOAT(NNMAX)
            ERLEF(JW) = 100.0*ERLEF(JW)/FLOAT(NNMAX)
 1081    CONTINUE
      ENDIF

      DO 10 IVD = 1 , 13
        IF((SEGS(13+IVD) + SEGS(26+IVD)).EQ.0.0) THEN
          ABIEFF(IVD) = 0.0
        ELSE
          ABIEFF(IVD) = SEGS(13+IVD) / (SEGS(13+IVD) + SEGS(26+IVD))
        ENDIF
        IF((SEGN(13+IVD) + SEGN(26+IVD)).EQ.0.0) THEN
          ABINEF(IVD) = 0.0
        ELSE
          ABINEF(IVD) = SEGN(13+IVD) / (SEGN(13+IVD) + SEGN(26+IVD))
        ENDIF
        IF((SEGF(13+IVD) + SEGF(26+IVD)).EQ.0.0) THEN
          ABIFEF(IVD) = 0.0
        ELSE
          ABIFEF(IVD) = SEGF(13+IVD) / (SEGF(13+IVD) + SEGF(26+IVD))
        ENDIF
        EVEC(IVD)   = ABIEFF(IVD)
        EVEC(13+IVD)= ABINEF(IVD)
        EVEC(26+IVD)= ABIFEF(IVD)
   10 CONTINUE

* compute track segments per FRRE and per digitising
      TFR = SEGS(1)/FLOAT( ISTATR(1) )
      ETF = ESEG(1)/FLOAT( ISTATR(1) )
      TDG = SEGS(1)*400.0/FLOAT( ISTATR(11) )
      EDG = ESEG(1)*400.0/FLOAT( ISTATR(11) )
* mean number of hits per FRRE bank
      HPE = FLOAT(ISTATR(11))/FLOAT(ISTATR(1))

      IOUT(1) = NRUN0
      IOUT(2) = NDATE0
      IOUT(3) = NTIME0
      IOUT(4) = NPRES0
      IOUT(5) = ISTATR(1)

      FOUT(1) = HPE
      FOUT(2) = TFR
      FOUT(3) = ETF
      FOUT(4) = TDG
      FOUT(5) = EDG
      FOUT(6) = VEL(1)
      FOUT(7) = EVEL(1)
      FOUT(8) = VELD
      FOUT(9) = EVELD
      FOUT(12)= RMIC(1)
      FOUT(13)= EMIC(1)
      FOUT(14)= RTZERO
      FOUT(15)= ETZERO
      FOUT(16)= EFCEN
      FOUT(17)= ERCEN

      AVQ = HSTATI(68,1,'HIST',1)
      RMS = HSTATI(68,2,'HIST',2)
      XN  = HSUM(68)
      IF(XN.GT.0.0) RMS = RMS/SQRT(XN)
      FOUT(10)= AVQ
      FOUT(11)= RMS

      DO 3001 NSM=0,2
         NL0 = NSM*3
         HLE0 = FLOAT( LHITSR(NL0) )/FLOAT(ISTATR(1))
         HLE1 = FLOAT( LHITSR(NL0+1) )/FLOAT(ISTATR(1))
         HLE2 = FLOAT( LHITSR(NL0+2) )/FLOAT(ISTATR(1))
         HVEC(NL0+1) = HLE0
         HVEC(NL0+2) = HLE1
         HVEC(NL0+3) = HLE2
 3001 CONTINUE

      DO 3201 NSM=0,2
         NL0 = NSM*3
         CLE0 = SEGS(NL0+5)/FLOAT(ISTATR(1))
         CLE1 = SEGS(NL0+6)/FLOAT(ISTATR(1))
         CLE2 = SEGS(NL0+7)/FLOAT(ISTATR(1))
         CVEC(NL0+1) = CLE0
         CVEC(NL0+2) = CLE1
         CVEC(NL0+3) = CLE2
 3201 CONTINUE

      DO 3002 NSM=0,2
      VVEC(NSM*2+1) = VEL(NSM+2)
      VVEC(NSM*2+2) = EVEL(NSM+2)
 3002 CONTINUE
      DO 3022 NSO=0,8
         TVEC(NSO+1)  = VEL(NSO+5)
         TVEC(NSO+10) = EVEL(NSO+5)
 3022 CONTINUE
      DO 3003 NSM=0,2
      VVEC(NSM*2+7) = RMIC(NSM+2)
      VVEC(NSM*2+8) = EMIC(NSM+2)
 3003 CONTINUE

      DO 3004 NSM=0,2
         AVQ = HSTATI(69+NSM,1,'HIST',1)
         RMS = HSTATI(69+NSM,2,'HIST',2)
         XN = HSUM(69+NSM)
         IF(XN.GT.0.0) RMS = RMS/SQRT(XN)
         VVEC(NSM*2+13) = AVQ
         VVEC(NSM*2+14) = RMS
 3004 CONTINUE
*
* IOUT(6) is a flag to indicate if it was a LUMI run & if HV was on
* The information is from the database.
* UNITS part means:
* 0 means that bank was found on database and H1L >  0
* 1 means that bank was found on database and H1L <= 0
* 2 means that bank was NOT found on database
* TENS  part means:
* 0 means HV was ON
* 1 means HV was OFF
* 2 means that bank was NOT found on database
      IF(ILRET.EQ.0) THEN
        IF(H1L.GT.0.0) THEN
          IOUT(6) = 0 + IFRHV*10
        ELSE
          IOUT(6) = 1 + IFRHV*10
        ENDIF
      ELSE
        IOUT(6) = 2 + IFRHV*10
      ENDIF

      AVEC(1) = FLOAT(IOUT(5))
      DO 100 I = 1 , 17
        AVEC(1+I) = FOUT(I)
        IF(I.LT.13) BVEC(I*2-1) = RELEF(I)
        IF(I.LT.13) BVEC(I*2  ) = QWR(I)
  100 CONTINUE
      AVEC(19) = FLOAT(IFRHV)

      CALL SVEC(20,0,EVEC)
      CALL SVEC(21,0,AVEC)
      CALL SVEC(22,0,BVEC)
      CALL SVEC(23,0,VVEC)
      CALL SVEC(24,0,HVEC)
      CALL SVEC(25,0,CVEC)
      CALL SVEC(26,0,TVEC)


      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 02/02/94  12.39.35  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/06/93
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FDEADR
************************************************************************
*                                                                      *
*                                                                      *
************************************************************************

      PARAMETER (NX=48)
      PARAMETER (NY=36)
      DIMENSION CON(NX,NY),YMAX(3),YTOT(3),ZMAX(NY)

      CALL HUNPAK(40,CON,'HIST',1)

      CALL VZERO(ZMAX,NY)
      CALL VZERO(YMAX,3)
      CALL VZERO(YTOT,3)

      DO 10 K = 1 , 3
        DO 10 J = (K-1)*12+1 , K*12
          DO 10 I = 1 , NX
           IF(CON(I,J).GT.YMAX(K)) THEN
             YMAX(K) = CON(I,J)
           ENDIF
           IF(CON(I,J).GT.ZMAX(J)) THEN
             ZMAX(J) = CON(I,J)
           ENDIF
           YTOT(K) = YTOT(K) + CON(I,J)
   10 CONTINUE

      DO 20 K = 1 , 3
        YMEAN = YTOT(K)/NX/12.
        DO 20 J = (K-1)*12+1 , K*12
          DO 20 I = 1 , NX
*           CON(I,J) = CON(I,J)/YMAX(K)
            CON(I,J) = CON(I,J)/ZMAX(J)
            IF(CON(I,J).LT.0.02) CALL SHD(27,0,FLOAT(I-1),FLOAT(J))
            CALL SHDW(28,0,FLOAT(I-1),FLOAT(J),CON(I,J))
            CALL SHS (29,0,CON(I,J))
   20 CONTINUE

  100 RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.29  by  Stephen Burke
*CMZU:  5.01/06 04/02/94  15.47.44  by  Girish D. Patel
*-- Author :    Girish D. Patel   02/02/94
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FHTMAP
*
* Copy the hit map, used hit map and unused hit map for radials
* and planars to the FTDMON area and sum over all runs.
*
      DIMENSION ST40(32,36)
      DIMENSION ST41(32,36)
      DIMENSION ST42(32,36)
      DIMENSION ST50(48,36)
      DIMENSION ST51(48,36)
      DIMENSION ST52(24,36)
      DIMENSION ITRAN(0:47)
      DATA ITRAN/0,1,8,9,2,3,10,11,4,5,12,13,6,7,14,15,8,9,16,17,10,11,
     & 18,19,12,13,20,21,14,15,22,23,16,17,0,1,18,19,2,3,20,21,4,5,22,
     & 23,6,7/
*
      CALL SAREA('FTREC',0)
      CALL TAREA('FTDMON',0)
      CALL COPYFG(71,71,IER)
      CALL COPYFG(72,72,IER)
      CALL COPYFG(73,73,IER)
      CALL COPYFG(74,74,IER)
      CALL DTAREA

      CALL SAREA('FTDSGI',0)
      CALL TAREA('FTDMON',0)
      CALL COPYFG(19501,80,IER)
      CALL COPYFG(19511,81,IER)
      CALL DTAREA

      CALL SAREA('FTDMON',0)

      LEN = 32*36
      CALL FDATA('HD',80,0,0,NR,ST40,LEN)
      CALL FDATA('HD',71,0,0,NR,ST41,LEN)
      CALL FDATA('HD',73,0,0,NR,ST42,LEN)
      DO 20 NY = 1 , 36
      DO 10 NX = 1 , 32
        CALL SHDW (40,0,FLOAT(NX)-0.5,FLOAT(NY)-0.5,ST40(NX,NY))
        CALL SHDW (41,0,FLOAT(NX)-0.5,FLOAT(NY)-0.5,ST41(NX,NY))
        CALL SHDW (42,0,FLOAT(NX)-0.5,FLOAT(NY)-0.5,ST42(NX,NY))
   10 CONTINUE
   20 CONTINUE

      LEN = 48*36
      CALL FDATA('HD',81,0,0,NR,ST50,LEN)
      CALL FDATA('HD',72,0,0,NR,ST51,LEN)
      LEN = 24*36
      CALL FDATA('HD',74,0,0,NR,ST52,LEN)
      DO 40 NY = 1 , 36
      DO 30 NX = 1 , 24
        CALL SHDW (50,0,FLOAT(NX)-0.5,FLOAT(NY)-0.5,ST50(NX*2-1,NY))
        CALL SHDW (50,0,FLOAT(NX)-0.5,FLOAT(NY)-0.5,ST50(NX*2,NY))
        CALL SHDW (52,0,FLOAT(NX)-0.5,FLOAT(NY)-0.5,ST52(NX,NY))
   30 CONTINUE
   40 CONTINUE
      DO 60 NY = 1 , 36
      DO 50 NX = 1 , 48
        NEWX = ITRAN(NX-1)+1
        CALL SHDW (51,0,FLOAT(NEWX)-0.5,FLOAT(NY)-0.5,ST51(NX,NY))
   50 CONTINUE
   60 CONTINUE

      CALL PURGEF(80)
      CALL PURGEF(81)
      CALL PURGEF(71)
      CALL PURGEF(72)
      CALL PURGEF(73)
      CALL PURGEF(74)

      RETURN
      END
*CMZ :  8.07/00 21/11/96  17.49.56  by  Stephen Burke
*CMZU:  8.04/00 07/07/96  09.25.24  by  Girish D. Patel
*CMZU:  7.04/00 11/01/96  11.08.26  by  Girish D. Patel
*CMZU:  7.00/12 13/06/95  11.08.57  by  Girish D. Patel
*CMZU:  5.01/06 02/03/94  13.32.27  by  Girish D. Patel
*-- Author :    Girish D. Patel   02/02/94
      SUBROUTINE FTRMON(NRUN)
*
* Extract useful/interesting information from the FTREC LOOK
* histograms.
*
      DIMENSION RP(5,5),AVEC(13),IDS(13),XSTAT(4),YSTAT(4),BINS(37)
      DIMENSION PVEC(10),RVEC(15),BMASK(64)
      LOGICAL R0,R1,R2,P0,P1,P2,BTEST
      DATA IDS /4,5,6,75,76,79,81,87,88,89,90,80,82/
*
      DO 10 I = 1 , 13
        CALL SAREA('FTREC',0)
        CALL GHSTAT('HS',IDS(I),0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
        CALL HPEAK('HS',IDS(I),0,NP,RP)
        AVEC(1) = FLOAT(NP)
        IF(NP.GE.1 .AND. I.LE.11) THEN
          AVEC(2) = RP(1,1)
          AVEC(3) = RP(2,1)
          AVEC(4) = RP(3,1)
          AVEC(5) = RP(4,1)
          AVEC(6) = RP(5,1)
          AVEC(7) = XSTAT(3)
          AVEC(8) = XSTAT(4)
        ELSEIF(NP.EQ.2 .AND. I.GT.7) THEN
          IF(RP(1,1) .LT. 0.0) THEN
            J1 = 1
            J2 = 2
          ELSE
            J1 = 2
            J2 = 1
          ENDIF
          AVEC(2) = RP(1,J1)
          AVEC(3) = RP(2,J1)
          AVEC(4) = RP(3,J1)
          AVEC(5) = RP(4,J1)
          AVEC(6) = RP(5,J1)
          AVEC(7) = RP(1,J2)
          AVEC(8) = RP(2,J2)
          AVEC(9) = RP(3,J2)
          AVEC(10) = RP(4,J2)
          AVEC(11) = RP(5,J2)
          AVEC(12) = XSTAT(3)
          AVEC(13) = XSTAT(4)
        ELSE
          AVEC(2) = 0.
          AVEC(3) = 0.
          AVEC(4) = 0.
          AVEC(5) = 0.
          AVEC(6) = 0.
          AVEC(7) = 0.
          AVEC(8) = 0.
          AVEC(9) = 0.
          AVEC(10) = 0.
          AVEC(11) = 0.
          AVEC(12) = XSTAT(3)
          AVEC(13) = XSTAT(4)
        ENDIF
        CALL SAREA('FTRMON',0)
        CALL SVEC(IDS(I),0,AVEC)
   10 CONTINUE

      CALL SAREA('FTREC',0)

      AVEC(1) = FLOAT(NRUN)
      CALL GHSTAT('HS', 1,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
      AVEC(2) = XSTAT(3)
      CALL GHSTAT('HS', 2,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
      CALL GDATA('HS', 2,0,NR,BINS,37)
      AVEC(3) = XSTAT(3)*FLOAT(NENT)/(FLOAT(NENT) - BINS(1))
      CALL GHSTAT('HS', 3,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
      CALL GDATA('HS', 3,0,NR,BINS,37)
      AVEC(4) = XSTAT(3)*FLOAT(NENT)/(FLOAT(NENT) - BINS(1))
      CALL GHSTAT('HS',15,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
      AVEC(5) = XSTAT(3)
      CALL GHSTAT('HS',16,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
      AVEC(6) = XSTAT(3)
*
      CALL GDATA('HS',17,0,NR,BINS,37)
      NSEG0   = BINS(10)  +BINS(11)   +BINS(12)   +BINS(13)
      PVEC(2) = (BINS(10)*9+BINS(11)*10+BINS(12)*11+BINS(13)*12)/NSEG0
      NSEG1   = BINS(22)  +BINS(23)   +BINS(24)   +BINS(25)
      PVEC(3) = (BINS(22)*9+BINS(23)*10+BINS(24)*11+BINS(25)*12)/NSEG1
      NSEG2   = BINS(34)  +BINS(35)   +BINS(36)   +BINS(37)
      PVEC(4) = (BINS(34)*9+BINS(35)*10+BINS(36)*11+BINS(37)*12)/NSEG2
      PVEC(1) = NSEG0 + NSEG1 + NSEG2
      PVEC(5) = BINS(10)  +BINS(22)   +BINS(34)
      PVEC(6) = BINS(11)  +BINS(23)   +BINS(35)
      PVEC(7) = BINS(12)  +BINS(24)   +BINS(36)
      PVEC(8) = BINS(13)  +BINS(25)   +BINS(37)

      CALL GDATA('HS',18,0,NR,BINS,37)
      NSEG0   = BINS(5)+BINS(6)+BINS(7)+BINS(8)+BINS(9)
     &         +BINS(10)+BINS(11)+BINS(12)+BINS(13)
      RVEC(2) = (BINS(5)*4+BINS(6)*5+BINS(7)*6+BINS(8)*7+BINS(9)*8
     &         +BINS(10)*9+BINS(11)*10+BINS(12)*11+BINS(13)*12)/NSEG0
      NSEG1   = BINS(17)+BINS(18)+BINS(19)+BINS(20)+BINS(21)
     &         +BINS(22)+BINS(23)+BINS(24)+BINS(25)
      RVEC(3) = (BINS(17)*4+BINS(18)*5+BINS(19)*6+BINS(20)*7+BINS(21)*8
     &         +BINS(22)*9+BINS(23)*10+BINS(24)*11+BINS(25)*12)/NSEG1
      NSEG2   = BINS(29)+BINS(30)+BINS(31)+BINS(32)+BINS(33)
     &         +BINS(34)+BINS(35)+BINS(36)+BINS(37)
      RVEC(4) = (BINS(29)*4+BINS(30)*5+BINS(31)*6+BINS(32)*7+BINS(33)*8
     &         +BINS(34)*9+BINS(35)*10+BINS(36)*11+BINS(37)*12)/NSEG2
      RVEC(1) = NSEG0 + NSEG1 + NSEG2
      RVEC(5) = BINS( 5)+BINS(17)+BINS(29)
      RVEC(6) = BINS( 6)+BINS(18)+BINS(30)
      RVEC(7) = BINS( 7)+BINS(19)+BINS(31)
      RVEC(8) = BINS( 8)+BINS(20)+BINS(32)
      RVEC(9) = BINS( 9)+BINS(21)+BINS(33)
      RVEC(10)= BINS(10)+BINS(22)+BINS(34)
      RVEC(11)= BINS(11)+BINS(23)+BINS(35)
      RVEC(12)= BINS(12)+BINS(24)+BINS(36)
      RVEC(13)= BINS(13)+BINS(25)+BINS(37)

      CALL SAREA('FTRMON',0)
      CALL SVEC(1,0,AVEC)
      CALL SVEC(100,0,PVEC)
      CALL SVEC(101,0,RVEC)

      CALL SAREA('FTREC',0)
      CALL GDATA('HS',19,0,NR,BMASK,64)
      P0P1 = 0.
      P0R0P1 = 0.
      R0P1 = 0.
      P0R1 = 0.
      P0R0R1 = 0.
      P0P1R1 = 0.
      P0P2 = 0.
      P0R0P2 = 0.
      P0P1P2 = 0.
      P0R1P2 = 0.
      P0R2 = 0.
      P0R0R2 = 0.
      P0P1R2 = 0.
      P0R1R2 = 0.
      P0P2R2 = 0.
      R0R1 = 0.
      R0P1R1 = 0.
      R0P2 = 0.
      R0P1P2 = 0.
      R0R1P2 = 0.
      R0R2 = 0.
      R0P1R2 = 0.
      R0R1R2 = 0.
      R0P2R2 = 0.
      P1P2 = 0.
      P1R1P2 = 0.
      P1R2 = 0.
      P1R1R2 = 0.
      P1P2R2 = 0.
      R1R2 = 0.
      R1P2R2 = 0.
      R1P2 = 0.

      DO 15 I = 0, 63
        R0 = BTEST(I,0)
        R1 = BTEST(I,1)
        R2 = BTEST(I,2)
        P0 = BTEST(I,3)
        P1 = BTEST(I,4)
        P2 = BTEST(I,5)
        IF(P0 .AND. P1) P0P1 = P0P1 + BMASK(I+1)
        IF(P0 .AND. P1 .AND. R0) P0R0P1 = P0R0P1 + BMASK(I+1)
        IF(R0 .AND. P1) R0P1 = R0P1 + BMASK(I+1)
        IF(P0 .AND. R1) P0R1 = P0R1 + BMASK(I+1)
        IF(P0 .AND. R1 .AND. R0) P0R0R1 = P0R0R1 + BMASK(I+1)
        IF(P0 .AND. R1 .AND. P1) P0P1R1 = P0P1R1 + BMASK(I+1)
        IF(P0 .AND. P2) P0P2 = P0P2 + BMASK(I+1)
        IF(P0 .AND. P2 .AND. R0) P0R0P2 = P0R0P2 + BMASK(I+1)
        IF(P0 .AND. P2 .AND. P1) P0P1P2 = P0P1P2 + BMASK(I+1)
        IF(P0 .AND. P2 .AND. R1) P0R1P2 = P0R1P2 + BMASK(I+1)
        IF(P0 .AND. R2) P0R2 = P0R2 + BMASK(I+1)
        IF(P0 .AND. R2 .AND. R0) P0R0R2 = P0R0R2 + BMASK(I+1)
        IF(P0 .AND. R2 .AND. P1) P0P1R2 = P0P1R2 + BMASK(I+1)
        IF(P0 .AND. R2 .AND. R1) P0R1R2 = P0R1R2 + BMASK(I+1)
        IF(P0 .AND. R2 .AND. P2) P0P2R2 = P0P2R2 + BMASK(I+1)
        IF(R0 .AND. R1) R0R1 = R0R1 + BMASK(I+1)
        IF(R0 .AND. R1 .AND. P1) R0P1R1 = R0P1R1 + BMASK(I+1)
        IF(R0 .AND. P2) R0P2 = R0P2 + BMASK(I+1)
        IF(R0 .AND. P2 .AND. P1) R0P1P2 = R0P1P2 + BMASK(I+1)
        IF(R0 .AND. P2 .AND. R1) R0R1P2 = R0R1P2 + BMASK(I+1)
        IF(R0 .AND. R2) R0R2 = R0R2 + BMASK(I+1)
        IF(R0 .AND. R2 .AND. P1) R0P1R2 = R0P1R2 + BMASK(I+1)
        IF(R0 .AND. R2 .AND. R1) R0R1R2 = R0R1R2 + BMASK(I+1)
        IF(R0 .AND. R2 .AND. P2) R0P2R2 = R0P2R2 + BMASK(I+1)
        IF(P1 .AND. P2) P1P2 = P1P2 + BMASK(I+1)
        IF(P1 .AND. P2 .AND. R1) P1R1P2 = P1R1P2 + BMASK(I+1)
        IF(P1 .AND. R2) P1R2 = P1R2 + BMASK(I+1)
        IF(P1 .AND. R2 .AND. R1) P1R1R2 = P1R1R2 + BMASK(I+1)
        IF(P1 .AND. R2 .AND. P2) P1P2R2 = P1P2R2 + BMASK(I+1)
        IF(R1 .AND. R2) R1R2 = R1R2 + BMASK(I+1)
        IF(R1 .AND. R2 .AND. P2) R1P2R2 = R1P2R2 + BMASK(I+1)
        IF(R1 .AND. P2) R1P2 = R1P2 + BMASK(I+1)
   15 CONTINUE
      AVEC(1) = P0R0P1/R0P1
      AVEC(2) = (P0R0P1/P0P1 + P0R0R1/P0R1 + P0R0P2/P0P2 +
     &           P0R0R2/P0R2)/4.0
      AVEC(3) = (P0P1R1/P0R1 + P0P1P2/P0P2 + P0P1R2/P0R2 +
     &           R0P1R1/R0R1 + R0P1P2/R0P2 + R0P1R2/R0R2)/6.0
      AVEC(4) = (P0R1P2/P0P2 + P0R1R2/P0R2 + R0R1P2/R0P2 +
     &           R0R1R2/R0R2 + P1R1P2/P1P2 + P1R1R2/P1R2)/6.0
      AVEC(5) = (P0P2R2/P0R2 + R0P2R2/R0R2 + P1P2R2/P1R2 +
     &           R1P2R2/R1R2)/4.0
      AVEC(6) = R1P2R2/R1P2

      CALL SAREA('FTRMON',0)
      CALL SVEC(19,0,AVEC)

      DO 30 I = 200, 203
        CALL SAREA('FTREC',1)
        CALL GHSTAT('HS',I,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
        RVEC(1) = XSTAT(3)
        CALL GDATA('HS',I,0,NR,BINS,20)
        DO 20 J = 5, 13
          RVEC(J-3) = BINS(J)
   20   CONTINUE
        CALL SAREA('FTRMON',0)
        CALL SVEC(I,0,RVEC)
   30 CONTINUE

      DO 60 I = 320, 323
        CALL SAREA('FTREC',1)
        CALL GHSTAT('HS',I,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
        PVEC(1) = XSTAT(3)
        CALL GDATA('HS',I,0,NR,BINS,20)
        DO 50 J = 10, 13
          PVEC(J-8) = BINS(J)
   50   CONTINUE
        CALL SAREA('FTRMON',0)
        CALL SVEC(I,0,PVEC)
   60 CONTINUE

      DO 70 ID = 2016, 2017
        CALL SAREA('FTREC',1)
        CALL GHSTAT('HS',ID,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
        CALL HPEAK('HS',ID,0,NP,RP)
        AVEC(1) = FLOAT(NP)
        AVEC(7) = XSTAT(3)
        AVEC(8) = XSTAT(4)
        IF(NP.GE.1) THEN
          AVEC(2) = RP(1,1)
          AVEC(3) = RP(2,1)
          AVEC(4) = RP(3,1)
          AVEC(5) = RP(4,1)
          AVEC(6) = RP(5,1)
        ELSE
          AVEC(2) = 0.
          AVEC(3) = 0.
          AVEC(4) = 0.
          AVEC(5) = 0.
          AVEC(6) = 0.
        ENDIF
        CALL SAREA('FTRMON',0)
        CALL SVEC(ID,0,AVEC)
   70 CONTINUE

      DO 80 ID = 907, 908
        CALL SAREA('FTREC',2)
        CALL GHSTAT('HS',ID,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
        CALL HPEAK('HS',ID,0,NP,RP)
        AVEC(1) = FLOAT(NP)
        AVEC(7) = XSTAT(3)
        AVEC(8) = XSTAT(4)
        IF(NP.GE.1) THEN
          AVEC(2) = RP(1,1)
          AVEC(3) = RP(2,1)
          AVEC(4) = RP(3,1)
          AVEC(5) = RP(4,1)
          AVEC(6) = RP(5,1)
        ELSE
          AVEC(2) = 0.
          AVEC(3) = 0.
          AVEC(4) = 0.
          AVEC(5) = 0.
          AVEC(6) = 0.
        ENDIF
        CALL SAREA('FTRMON',0)
        CALL SVEC(ID,0,AVEC)
   80 CONTINUE

      DO 90 ID = 650, 657
        CALL SAREA('FTREC',1)
        CALL GHSTAT('HS',ID,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
        CALL HPEAK('HS',ID,0,NP,RP)
        AVEC(1) = FLOAT(NP)
        AVEC(7) = XSTAT(3)
        AVEC(8) = XSTAT(4)
        IF(NP.GE.1) THEN
          AVEC(2) = RP(1,1)
          AVEC(3) = RP(2,1)
          AVEC(4) = RP(3,1)
          AVEC(5) = RP(4,1)
          AVEC(6) = RP(5,1)
        ELSE
          AVEC(2) = 0.
          AVEC(3) = 0.
          AVEC(4) = 0.
          AVEC(5) = 0.
          AVEC(6) = 0.
        ENDIF
        CALL SAREA('FTRMON',0)
        CALL SVEC(ID,0,AVEC)
   90 CONTINUE


      RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.30  by  Stephen Burke
*CMZU:  5.02/14 24/10/94  14.07.39  by  Girish D. Patel
*CMZU:  5.01/06 02/03/94  13.32.27  by  Girish D. Patel
*-- Author :    Stephen J. Maxfield
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      SUBROUTINE FPOKEM(NRUN0)
**----------------------------------------------------------------------
*
      PARAMETER (NBIN=200)
      PARAMETER (NBINLR=40)
      PARAMETER (RADEG=57.295779)

      DIMENSION CVEC(6)
      DIMENSION IOUT(4)
      DIMENSION FOUT(5)
      DIMENSION GOUT(8)
      DIMENSION PDAT(5,5)
      DIMENSION PAR(2), PMIN(2), PMAX(2), EPAR(2), COV(3)
      DIMENSION XST(4), YST(4)
      DIMENSION AVEC(8)



      DATA NEMAX/20/

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


*     Get number of events...
      CALL SAREA('FTREC', 0)
      CALL GHSTAT('HS', 1, 0, NENT, SUMW, RNEFF, XST, YST)
      ITOTAN = NENT

      CALL SAREA('FPOKE', 0)
*     Book histograms...
      CALL BVEC(100, 0, 6)
      CALL STEXT(100, 4,'D-time (scaled) vs. Dist(predicted)')

*     Lorentz Angle stuff...
      CALL BVEC(7500, 0, 6)
      CALL BHD(7501, 0, 100, -25., 25., 100, -25., 25.)
      CALL STEXT(7501, 4,' Delta R-perp vs. Pred drift')


*     Analyse the data.
*     ------- --- ----
*     Analysis of histogram results.
*     Write(6,*) ' Fpkanl >> Begin peaks analysis...'

*     Do peakparm analysis of the pred drift histograms...

      NPEAK = 0
      DO KBIN = 1, NBIN

       DLO       = -5. + (KBIN-1) * 0.05
       DHI       = DLO + 0.05

       JHIS1 = 2000 + KBIN
       JHIS2 = 3000 + KBIN

*      Get average predicted drift distance in the slice...
       CALL GHSTAT('HS', JHIS2, 0, NENT, SUMW, RNEFF, XST, YST)
       DMAV = XST(3)
       IF(NENT .GT. NEMAX) THEN
       CALL HPEAK('HS',JHIS1, 0, NPK, PDAT)

         IF (NPK .GE. 1) THEN
           NPEAK = NPEAK + 1
*          peak position and error on...
           PPOS  = PDAT(1,1)
           PERR  = ABS(PDAT(2,1))
           PINT  = ABS(PDAT(3,1))
*          comment out next line for 'full width errors'
           PERR  = 2.0*(PERR  / SQRT(PINT))

*          Hence Drift distance vs. drift time:-

           CVEC(1) = DMAV
           CVEC(2) = PPOS
           CVEC(3) = DMAV - DLO
           CVEC(4) = DHI  - DMAV
           CVEC(5) = PERR
           CVEC(6) = PERR
           CALL SVEC(100, 0, CVEC)
         ENDIF

       ENDIF

*      Now purge figures - no longer needed.
       CALL PURGEF(JHIS1)
       CALL PURGEF(JHIS2)

      ENDDO

*     Lorentz Angle stuff...
      NPEAKL = 0
      DO KBIN = 1, NBINLR

       DLO = -5.0 + (KBIN-1)*0.25
       DHI = DLO + 0.25

       JHIS1 = 10000 + KBIN
       JHIS2 = 11000 + KBIN
*      Get average predicted drift distance in the slice...
       CALL GHSTAT('HS', JHIS2, 0, NENT, SUMW, RNEFF, XST, YST)
       DMAV = XST(3)
*      Write(6,*) KBIN, NENT, DMAV

       IF(NENT .GT. 20) THEN
       CALL HPEAK('HS',JHIS1, 0, NPK, PDAT)

         IF (NPK .GE. 1) THEN
           NPEAKL = NPEAKL + 1
*          peak position and error on...
           PPOS  = PDAT(1,1)
           PERR  = ABS(PDAT(2,1))
           PINT  = ABS(PDAT(3,1))
*          comment out next line for 'full width errors'
           PERR  = 2.0*(PERR  / SQRT(PINT))

*          Hence Delta R vs. predicted drift...

           CVEC(1) = DMAV
           CVEC(2) = PPOS
           CVEC(3) = DMAV - DLO
           CVEC(4) = DHI  - DMAV
           CVEC(5) = PERR
           CVEC(6) = PERR
           CALL SVEC(7500, 0, CVEC)
         ENDIF

       ENDIF
      ENDDO


*     Extraction of calibration data. Not for online at moment...


*     Now fit the drift stuff to two straight lines...
*     Set x-ranges.
      CALL SAREA('FPOKE', 0)

                      IF(NPEAK.GE.4) THEN
      KKHIS = 100

      XMI = 0.6
      XMA = 3.5

      PAR(1)  = 0.0
      PMIN(1)= -0.5
      PMAX(1)=  0.5

      PAR(2)  = 1.0
      PMIN(2)=  0.5
      PMAX(2)=  1.5

      CALL LKFPAR (2,PAR,PMIN,PMAX,IERR)
      CALL LKFITY(KKHIS, 0, 1, XMI, XMA, 'P1', IERRP)
      CALL LKFGET(IFLAG,CHIS,NPT,NPAR,PAR,EPAR,COV)

      IF(IERRP .EQ. 0) THEN
       SLPLUS  = PAR(2)
       DSPLUS  = EPAR(2)
       ALPLUS  = PAR(1)
       DAPLUS  = EPAR(1)
       VPLUS   = 7.9/(0.192308*PAR(2))
       DVPLUS  = VPLUS * EPAR(2)/ PAR(2)
       NPPLUS  = NPT
       CHPLUS  = CHIS
      ELSE
       SLPLUS  = 0.
       DSPLUS  = 0.
       ALPLUS  = 0.
       DAPLUS  = 0.
       VPLUS   = 0.
       DVPLUS  = 0.
       NPPLUS  = 0.
       CHPLUS  = 0.
      ENDIF

      PAR(1)  = 0.0
      PMIN(1)= -0.5
      PMAX(1)=  0.5

      PAR(2)  = 1.0
      PMIN(2)=  0.5
      PMAX(2)=  1.5

      CALL LKFPAR (2,PAR,PMIN,PMAX,IERR)
      CALL LKFITY(KKHIS, 0, 2, -XMA, -XMI, 'P1', IERRM)
      CALL LKFGET(IFLAG,CHIS,NPT,NPAR,PAR,EPAR,COV)

      IF(IERRM .EQ. 0) THEN
       SLMINU  = PAR(2)
       DSMINU  = EPAR(2)
       ALMINU  = PAR(1)
       DAMINU  = EPAR(1)
       VMINU   = 7.9/(0.192308*PAR(2))
       DVMINU  = VPLUS * EPAR(2)/ PAR(2)
       NPMINU  = NPT
       CHMINU  = CHIS
      ELSE
       SLMINU  = 0.
       DSMINU  = 0.
       ALMINU  = 0.
       DAMINU  = 0.
       VMINU   = 0.
       DVMINU  = 0.
       NPMINU  = 0.
       CHMINU  = 0.
      ENDIF

*     Compute mean of +/- sides and F0R8 value...
      IF(DVPLUS .GT. 0.0) THEN
        WTP = 1.0/(DVPLUS**2)
      ELSE
        WTP = 0.0
      ENDIF
      IF(DVMINU .GT. 0.0) THEN
        WTM = 1.0/(DVMINU**2)
      ELSE
        WTM = 0.0
      ENDIF

      IF((WTP+WTM) .GT. 0.0) THEN
       VMEAN  = ( VPLUS*WTP + VMINU*WTM ) / (WTP + WTM)
       DVMEAN = SQRT(1.0/(WTP+WTM))
      ELSE
       VMEAN  = 0.0
       DVMEAN = 0.0
      ENDIF

      IF(DAPLUS .GT. 0.0) THEN
        WTP = 1.0/(DAPLUS**2)
      ELSE
        WTP = 0.0
      ENDIF
      IF(DAMINU .GT. 0.0) THEN
        WTM = 1.0/(DAMINU**2)
      ELSE
        WTM = 0.0
      ENDIF

      IF((WTP+WTM) .GT. 0.0) THEN
       ALMEAN  = ( ABS(ALPLUS)*WTP + ABS(ALMINU)*WTM ) / (WTP + WTM)
       DAMEAN = SQRT(1.0/(WTP+WTM))
      ELSE
       ALMEAN  = 0.0
       DAMEAN = 0.0
      ENDIF

      VF0R8  = VMEAN  * 0.211475
*     ( entry in f0r8 bank is 10**-4 times this)
      DVF0R8 = DVMEAN * 0.211475

                      ELSE
       SLPLUS  = 0.
       DSPLUS  = 0.
       ALPLUS  = 0.
       DAPLUS  = 0.
       VPLUS   = 0.
       DVPLUS  = 0.
       NPPLUS  = 0.
       CHPLUS  = 0.

       SLMINU  = 0.
       DSMINU  = 0.
       ALMINU  = 0.
       DAMINU  = 0.
       VMINU   = 0.
       DVMINU  = 0.
       NPMINU  = 0.
       CHMINU  = 0.

       VMEAN   = 0.
       DVMEAN  = 0.
       ALMEAN  = 0.
       DAMEAN  = 0.

       DVF0R8  = 0.
                      ENDIF
                      IF(NPEAKL.GE.4) THEN

*     Fit the Lorentz Angle data...
*
*     Set x-ranges...
      XMI = -3.5
      XMA =  3.5

      PAR(1)  = 0.0
      PMIN(1)= -2.0
      PMAX(1)=  2.0

      PAR(2)  = -1.0
      PMIN(2)=  -1.5
      PMAX(2)=  -0.2

      CALL LKFPAR (2,PAR,PMIN,PMAX,IERR)
      CALL LKFITY(7500, 0, 1, XMI, XMA, 'P1', IERRL)
      CALL LKFGET(IFLAG,CHIS,NPT,NPAR,PAR,EPAR,COV)

      IF(IERRL .EQ. 0) THEN
       TLORR   = PAR(2)
       ERSLP   = EPAR(2)
       BLOR    = PAR(1)
       DBLOR   = EPAR(1)
       NPLOR   = NPT
       CHLOR   = CHIS

       ANGLOR  = ATAN(TLORR)
       DANG    = ANGLOR*RADEG
       DANGL   = ERSLP / (1. + TLORR**2)
       DDANG   = DANGL*RADEG
      ELSE
       TLORR   = 0.0
       ERSLP   = 0.0
       BLOR    = 0.0
       DBLOR   = 0.0
       NPLOR   = 0.0
       CHLOR   = 0.0

       ANGLOR  = 0.0
       DANG    = 0.0
       DANGL   = 0.0
       DDANG   = 0.0
      ENDIF


*     Set some attributes...
*     CALL SATTR('VEC',7500,0,'full curv')

                      ELSE
       TLORR   = 0.0
       ERSLP   = 0.0
       BLOR    = 0.0
       DBLOR   = 0.0
       NPLOR   = 0.0
       CHLOR   = 0.0

       ANGLOR  = 0.0
       DANG    = 0.0
       DANGL   = 0.0
       DDANG   = 0.0

                      ENDIF



*     Output to history n-tuple.
        CALL SAREA('FPOKER',0)

*     Fill Ntuples...
      AVEC(1) = FLOAT(NRUN0)
      AVEC(2) = FLOAT(ITOTAN)
      AVEC(3) = VMEAN
      AVEC(4) = DVMEAN
      AVEC(5) = VF0R8
      AVEC(6) = DVF0R8
      AVEC(7) = ALMEAN
      AVEC(8) = DAMEAN
      CALL SVEC(1, 0, AVEC)

      AVEC(1) = VPLUS
      AVEC(2) = DVPLUS
      AVEC(3) = SLPLUS
      AVEC(4) = DSPLUS
      AVEC(5) = ALPLUS
      AVEC(6) = DAPLUS
      AVEC(7) = FLOAT(NPPLUS)
      AVEC(8) = CHPLUS
      CALL SVEC(2, 0, AVEC)

      AVEC(1) = VMINU
      AVEC(2) = DVMINU
      AVEC(3) = SLMINU
      AVEC(4) = DSMINU
      AVEC(5) = ALMINU
      AVEC(6) = DAMINU
      AVEC(7) = FLOAT(NPMINU)
      AVEC(8) = CHMINU
      CALL SVEC(3, 0, AVEC)

      AVEC(1) = TLORR
      AVEC(2) = ERSLP
      AVEC(3) = BLOR
      AVEC(4) = DBLOR
      AVEC(5) = DANG
      AVEC(6) = DANGL
      AVEC(7) = FLOAT(NPLOR)
      AVEC(8) = CHLOR
      CALL SVEC(4, 0, AVEC)

*-------------------------------------------------------------
999   RETURN
      END
*CMZ :  8.04/00 27/06/96  20.28.30  by  Stephen Burke
*CMZU:  7.00/12 07/06/95  16.21.03  by  Girish D. Patel
*-- Author :    Girish D. Patel   01/05/95
*
* The descriptions inserted below will appear asis with the
* initial asterisk removed in the WWW writeup. HTML commands
* (links etc.) may be included in the description if desired.
* The regions can be expanded to as many comment lines as
* required up to a maximum of 100 from *HTMLP to *HTMLE inclusive.
*
*HTMLP     : Describe the Purpose of the routine
*
*
*
*HTMLI     : Describe the Input variables to the routine
*
*
*
*HTMLO     : Describe the Output of the routine
*
*
*
*HTMLE     : Terminates the HTML documentation
*
      Function Fwiebl(x)

      Common/PawPar/ P(4)

* Normalised Wiebull Function
* P(1) = area
* P(2) = x-position of the maximum [1050.0]
* P(3) = decay parameter [2.5]
* P(4) = x-threshold [1000.0]
* The values in [square] brackets are for typical Planar back-edge DOS.
* JVM 24/4/95

      Fwiebl = 0.0
      z = x-P(4)
      z0 = P(2)-P(4)

      if (z.gt.0.) then
        if (z0.ge.0.) then
          if (P(3).ge.1.) then

            v = (P(3)-1.)/(P(3)* z0**P(3))
            y = v*P(1)*P(3)
            y = y* z**(P(3)-1.)
            Fwiebl = y*exp( -v* z**P(3) )

          endif
        endif
      endif

      RETURN
      END
*CMZU:  8.04/00 07/07/96  12.31.09  by  Girish D. Patel
*-- Author :    Girish D. Patel   07/07/96
      SUBROUTINE FMEANT
*
*  Peakparm the FTDMON histograms 19527/19528 to obtain the mean of
*  the mean event times for planars and radials. Store the results
*  in ntuples 7/8 in sarea 'FTDMON' 0
*
      DIMENSION RP(5,5),XSTAT(4),YSTAT(4)
      DIMENSION PVEC(8),RVEC(8)
*
      ID = 19527
      CALL GHSTAT('HS',ID,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
      CALL HPEAK('HS',ID,0,NP,RP)
      PVEC(1) = FLOAT(NP)
      PVEC(7) = XSTAT(3)
      PVEC(8) = XSTAT(4)
      IF(NP.GE.1) THEN
        PVEC(2) = RP(1,1)
        PVEC(3) = RP(2,1)
        PVEC(4) = RP(3,1)
        PVEC(5) = RP(4,1)
        PVEC(6) = RP(5,1)
      ELSE
        PVEC(2) = 0.
        PVEC(3) = 0.
        PVEC(4) = 0.
        PVEC(5) = 0.
        PVEC(6) = 0.
      ENDIF
*
      ID = 19528
      CALL GHSTAT('HS',ID,0,NENT,SUMW,RNEFF,XSTAT,YSTAT)
      CALL HPEAK('HS',ID,0,NP,RP)
      RVEC(1) = FLOAT(NP)
      RVEC(7) = XSTAT(3)
      RVEC(8) = XSTAT(4)
      IF(NP.GE.1) THEN
        RVEC(2) = RP(1,1)
        RVEC(3) = RP(2,1)
        RVEC(4) = RP(3,1)
        RVEC(5) = RP(4,1)
        RVEC(6) = RP(5,1)
      ELSE
        RVEC(2) = 0.
        RVEC(3) = 0.
        RVEC(4) = 0.
        RVEC(5) = 0.
        RVEC(6) = 0.
      ENDIF

      CALL SAREA('FTDMON',0)
      CALL SVEC(7,0,PVEC)
      CALL SVEC(8,0,RVEC)

      RETURN
      END