*-- Author : R. Henderson
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 RCW
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 wi
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
*