*-- Author : Stephen Burke
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
*