*CMZ : 2.00/00 17/12/90 15.55.42 by Girish D. Patel *-- Author : S.J. Maxfield *HTMLP * * 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 * * RADIUS : uncorrected radial coordinate, * DRIFT : drift coordinate and * DRFSGN : sign of the drift (+1.0 or -1.0) * *HTMLO * * Usage: * ----- * Rcorrected = RADIUS + FLOREN(RADIUS,DRIFT,DRFSGN) * *HTMLE 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: 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 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,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 )> 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: 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 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 * 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 CALL SHS(320, 0, FLOAT(IHITS)) CALL SHS(320+ISM, 0, FLOAT(IHITS)) IFPSG = IADROW('FPSG',NBNN,NCFPSG,BAR) 2 CONTINUE 1 CONTINUE * Close banks... IF(NUMSEG.GT. 0) THEN IFPSG = IADFIN('FPSG',NBNN) ELSE * make empty banks IFPSG = NBANK('FPSG',NBNN,2) IW(IFPSG+1) = NCFPSG IW(IFPSG+2) = 0 ENDIF CALL BLIST(IW,'R+','FPSG') IF(IDOHIS.GE.2)CALL FPSGST RETURN END *CMZU: 3.09/01 06/04/93 15.03.55 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 17/02/92 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 *CMZU: 3.09/07 26/07/93 10.00.25 by Stephen Burke *-- Author : Stephen J. Maxfield 30/03/92 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) 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 CALL SHS(200, 0, FLOAT(IHITS)) CALL SHS(200+ISM, 0, FLOAT(IHITS)) * 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: 3.09/07 26/07/93 10.00.25 by Stephen Burke *-- Author : Stephen J. Maxfield 30/03/92 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: 3.04/01 02/06/92 17.12.30 by Stephen Burke *-- Author : Stephen Burke 07/05/92 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: 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 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: 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 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: 3.06/06 01/12/92 14.13.02 by Stephen Burke *-- Author : Stephen Burke 07/05/92 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: 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 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 *CMZU: 3.05/07 20/08/92 11.33.37 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 18/06/92 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 *CMZU: 3.06/06 28/10/92 08.58.45 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 22/07/92 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 *CMZU: 3.05/07 19/08/92 18.34.08 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 19/08/92 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 *CMZU: 3.06/02 05/09/92 12.07.09 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 04/09/92 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 *CMZU: 3.09/01 05/05/93 09.53.05 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 10/09/92 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 *CMZU: 3.06/02 21/09/92 11.41.20 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 21/09/92 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 *CMZU: 3.09/01 25/04/93 18.56.10 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 02/03/93 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 *CMZU: 3.09/01 22/04/93 19.02.18 by Stephen J. Maxfield *-- Author : J. V. Morris 17/04/93 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 : 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 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 *CMZU: 3.09/01 18/05/93 19.47.09 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 18/05/93 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 *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 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,(2I)') 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 * 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 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 * 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) 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... CALL SHS(109,0,DRIFT) CALL SHS(612,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) ELSE CALL SHS(657,0,TAVG-CJCT0) ENDIF ENDIF C IFPLC = IADFIN('FPLC',NBN) CALL WDROP(IW,INFRPE) 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 : 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 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 *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 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 : 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 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 : 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 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 *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 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... 00000000 * 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... CALL SHS(108,0,DRIFTS) CALL SHS(610,0,TT) 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 : 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 SUBROUTINE FTREC *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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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. * 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 DATA JEVENT / 0 / *KEEP,VERSQQ. VERSQQ = ' 7.02/06' IVERSQ = 70206 *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(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) THEN IF(JEVENT.LT. 1) THEN WRITE(6,'('' '')') WRITE(6,'(10X,''F T R E C Initialising...'')') WRITE(6,'(10X,'' ...Production Version'')') WRITE(6,'('' '')') ENDIF * rebook b16 input bank formats for the farm CALL BKFMT('FRRE','B16') CALL BKFMT('FRPE','B16') CALL SETREC CALL FPTINT CALL FPTHIS END IF * * IF(REVENT) THEN 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 *------------------------------------------------------ * Find planar segments and make FPSG etc. banls. * CALL FPLSG * *------------------------------------------------------ * 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 IF(JSTAT.GT.0)THEN CALL SAREA('FTDSGI', 0) CALL FTDSGI CALL SAREA('FTREC',0) 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 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 * * 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 *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 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 *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 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 *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. DATA LPRIM/.TRUE./ ********************************************************************** 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) ELSE INBEAZ = IABS(MDB('BEAZ')) ENDIF ZNOM = 0. IF (INOSVX.GT.0) THEN IF(IW(INOSVX).GE.22) ZNOM = RW(INOSVX+21)+RW(INOSVX+22) ELSEIF (INBEAZ.GT.0) THEN ZNOM = RW(INBEAZ +2 +2) 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 *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 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 *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 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 : 4.00/00 07/09/93 17.57.52 by Stephen Burke *-- Author : Stephen Burke 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 = ' 7.02/06' IVERSQ = 70206 *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 *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 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 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 *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 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 *CMZU: 5.03/00 22/04/94 16.07.46 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 22/04/94 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 *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 : Stephen J. Maxfield 16/11/92 * * Two versions of this routine. One for COSMICS. * SELect cosmic version by SEL FCOSMIC * * * SUBROUTINE FPKPKR( K) *D: FPLPKR.......SM. Fix small bug. **: FPKPKR 30907 RP. Farm changes. **---------------------------------------------------------------------- C IOS MOD PICK UP RADIALS FROM PLANARS C ADD PLOT OF RESIDUALS TO PLANAR PREDICTION **: **: Stop same radial segment being attached to more than one **: planar track! **: **: FPLPKR 30907 SM. Fix small bug. * * ROUTINE TO PICK UP RADIAL 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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) * ESTABLISH CUT VALUES C ALLOW A 1 CM ROAD IN DRIFT DRPCUT=1.0 C VERY GENEROUS RADIUS CUT 20.0 DRCUT=20.0 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 C WRITE(*,*)' IP1 IP2 IP3 ',IP1,IP2,IP3 C C C--- Loop over supermodules C DO 10 ISM = 1,3 LRR(ISM,K)=0 C C--- CALCULATE PLANAR PREDICTION FOR SEGMENT IN THIS SUPERMODUAL C Z = ZP( 4 + (ISM -1)*12 ) ZMM=Z 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) CIOS PHI = AMOD(PHI,PI2) IF(PHI.LT.0.0) PHI = PHI + PI2 C WRITE(*,*)' PRED PHI,R ',PHI,RR C ISMIN = 0 DRMIN = 1000000.0 DRM = 1000000.0 * *---- Loop over the Radial Segments.. * DO 20 IP = 1,NTRAKS(ISM) * * 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. DO 21 IPL=1,12 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)) 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. ENDIF 21 CONTINUE C REPLACE DRPHI IF(FNN.NE.0.)DRPHI=ABS(DDIST/FNN) IF(DRPHI .LT. DRMIN) THEN CALL SHS(701 , 0, DR ) IF(DR .LT. DRCUT) THEN C END ADDITION DRMIN = DRPHI ISMIN = IP 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 * 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 IFR = 1+(ISM-1)*12 ILS = 11+IFR DO 60 IWIR= IFR, ILS IRR(IWIR, K) = 0 60 CONTINUE * Diagnostics C RADIAL EFFICIENCY - COUNT POTENTIAL SEGMENTS IF(IP1.EQ.1.AND.IP2.EQ.1.AND.ISM.EQ.1)THEN CALL SHS(710,0,1.01) ENDIF IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.2)THEN CALL SHS(710,0,5.01) ENDIF IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.3)THEN CALL SHS(710,0,9.01) ENDIF IF(IP1.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.1)THEN CALL SHS(710,0,14.01) ENDIF IF(IP1.EQ.1.AND.IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.3)THEN CALL SHS(710,0,16.01) ENDIF C Diagnostic end IF(ISMIN .NE. 0) THEN IF(DRMIN .LT. DRPCUT) THEN IP=ISMIN 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) C CHECK SLOPE OF SEGMENT : HISTOGRAM SUGGESTS 0.06 CALL SHS(708,0,AT) CALL SHS(699,0,AD-DDDZ) ********************************************************** * This is a relative slope cut.... IF(ABS(AT).GT.0.10)ISMIN=0 * Diagnostics... IF(SSS.GT.4.AND.ISMIN.NE.0)THEN C CALCULATE VELOCITY CORRECTION VFAC=SME/SEE CALL SHS(750+ISM,0,VFAC) ENDIF C END ADDITION C WRITE(*,*)' ISM ISMIN ',ISM,ISMIN C RADIAL EFFICIENCY - FOUND SEGMENTS IF(IP1.EQ.1.AND.IP2.EQ.1.AND.ISM.EQ.1)THEN IF(ISMIN.NE.0)CALL SHS(710,0,2.01) ENDIF IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.2)THEN IF(ISMIN.NE.0)CALL SHS(710,0,6.01) ENDIF IF(IP2.EQ.1.AND.IP3.EQ.1.AND.ISM.EQ.3)THEN IF(ISMIN.NE.0)CALL SHS(710,0,10.01) 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) 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 ENDIF ENDIF ENDIF ENDIF 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: 3.09/07 26/07/93 10.00.26 by Stephen Burke *-- Author : Stephen J. Maxfield 16/11/92 * * Two versions of this routine - one for COSMICs * SELect COSMIC version by SEL FCOSMIC * * 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 * * * * *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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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. 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(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 CALL SHS(1632,0,DIFF) ENDIF 22 CONTINUE CALL FTLFT(XX,YY,LL,0,AT,BT,EE) CALL SHS(1633,0,AT) DC=AT*XX(LL/2)+BT C CHECK SLOPE OF SEGMENT : HISTGRAM SUGGESTS 0.1 IF(ABS(AT).GT.0.15)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 *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 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 *CMZU: 3.08/03 17/11/92 17.01.03 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 17/11/92 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 *CMZU: 3.08/03 18/11/92 10.38.33 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 17/11/92 SUBROUTINE FRAPKR * Link helices...2,3-module fits... CALL FTLINK * Pick up planar segments... CALL FRPKPL RETURN END *CMZU: 3.08/03 28/11/92 16.21.28 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 17/11/92 * * 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 *CMZU: 3.09/07 26/07/93 10.00.28 by Stephen Burke *-- Author : Stephen J. Maxfield 18/11/92 SUBROUTINE FRPKPL **: FRPKPL 30907 RP. Farm changes. **---------------------------------------------------------------------- * * Pick up planar segments on radial-based tracks * - historically, bits of FTTRAC. * Calls new FTFHPL - Uses planars to improve R-Z , hence * Phi-Z. * 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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) ******************************************* * 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 *-----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) * Make fit using radial points... * Take current 'best' parameters. These are INPUT to fit... * Initially from link step. SLPHI =RPCOSG(K) SLPR =RPSING(K) PHZER =PHZG(K) RZER =ZIG(K) * Make new fit... CALL FTFHPL(36,IRN(1,K),SDN(1,K),IRP(1,K),SDP(1,K), 1 SLPHI, PHZER, DSLPHI, DPHZER, COVP, 1 SLPR, RZER, DSLPR, DRZER, COVR, CH, CHR, CHIQ, NDF) * ...and update the track parameters... RPCOSG(K) =SLPHI RPSING(K) =SLPR PHZG(K) =PHZER ZIG(K) =RZER * ******************************************************* * Iterate to pick up planar points, improve road... IF(IPLAR.NE.0) THEN DO 900 IT = 1, NIT CALL FPLPKS(IT, K, IUSEDP, IUSEG) * * Take current 'best' parameters. These are INPUT to fit... * Initially from link step. SLPHI =RPCOSG(K) SLPR =RPSING(K) PHZER =PHZG(K) RZER =ZIG(K) * Make new fit with planars... CALL FTFHPL(36,IRN(1,K),SDN(1,K),IRP(1,K),SDP(1,K), 1 SLPHI, PHZER, DSLPHI, DPHZER, COVP, 1 SLPR, RZER, DSLPR, DRZER, COVR, CH, CHR, CHIQ, NDF) * ...and update the track parameters... RPCOSG(K) =SLPHI RPSING(K) =SLPR PHZG(K) =PHZER ZIG(K) =RZER * 900 CONTINUE * Next iteration. ENDIF *-----Debug--------------------------------------------------- * WRITE(*,*)' ***FRPKPLB** ' * 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) * * This track done. Make residual plots if requested... IF(IREZ.EQ.1)THEN CALL FPTREZ(K) ENDIF * 100 CONTINUE * End Main loop over linked tracks. ******************************************* RETURN END *CMZU: 3.08/03 27/11/92 14.30.17 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 18/11/92 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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: 3.09/07 26/07/93 10.00.28 by Stephen Burke *-- Author : Stephen J. Maxfield 18/11/92 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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: 3.09/07 26/07/93 10.00.28 by Stephen Burke *-- Author : Stephen J. Maxfield 20/11/92 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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) 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 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... NRSG=0 DO 780 I=1,3 IF(LNK3(ITRK,I) .NE. 0) THEN NRSG = NRSG + 1 * Calculate row number in segment bank FRSG... ISGMOD = LNK3(ITRK,I) IF(I.GT.1) ISGMOD = ISGMOD + NTRAKS(1) IF(I.GT.2) ISGMOD = ISGMOD + NTRAKS(2) 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 DO 785 I=1,3 IF(LRR(I,ITRK) .NE. 0) THEN NRSG = NRSG + 1 * Calculate row number in segment bank FRSG... ISGMOD = LRR(I,ITRK) IF(I.GT.1) ISGMOD = ISGMOD + NTRAKS(1) IF(I.GT.2) ISGMOD = ISGMOD + NTRAKS(2) 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 *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 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 *CMZU: 3.08/03 22/11/92 14.35.43 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 21/11/92 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: 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 : Stephen J. Maxfield 29/11/92 CC 23/11/92 211230938 MEMBER NAME FTVDET (FILE46) FVS -- 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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: 3.08/03 29/11/92 16.36.58 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 24/04/92 C 01/04/92 204241447 MEMBER NAME EDITFILE (FTREC) M FVS 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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: 3.08/03 29/11/92 16.40.36 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 29/11/92 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: 3.08/03 29/11/92 16.41.48 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 29/11/92 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: 3.08/03 29/11/92 18.34.51 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 24/04/92 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: 3.08/03 29/11/92 18.35.12 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 24/04/92 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 *CMZU: 3.09/07 26/07/93 10.00.29 by Stephen Burke *-- Author : Stephen J. Maxfield 28/02/93 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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 * 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 * 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 11 CONTINUE 10 CONTINUE RETURN END *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 SUBROUTINE FPLPKP **: FPLPKP 40000 RP. New debug histos kicked out on the farm! **: FPLPKP 40000 SM. New debug histos. **---------------------------------------------------------------------- **: FPLPKP 30907 RP. Farm changes. **---------------------------------------------------------------------- **: FPLPKP WAS FPLPKS * * Routine to pick up planar 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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) 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) CDEB WRITE(*,*)' ISM NS ',ISM,NS(ISM) C C--- End of loop over supermodules C 10 CONTINUE C CALL ROUTINES TO LINK SEGMENTS C (ROUTINES IN COSPLA2 ARE NOW OBSOLETE) CALL FPPJN3 CDEB WRITE(*,*)' 3 NPP ',NPP CALL FPPJ12 CDEB WRITE(*,*)' 12 3 NPP ',NPP CALL FPPJ23 CDEB WRITE(*,*)' 23 12 3 NPP ',NPP CALL FPPJ13 CDEB WRITE(*,*)' 13 23 12 3 NPP ',NPP C LIST LINKS CALL SHS(560,0,FLOAT(NPP)+0.01) IF(NPP.NE.0)THEN C WRITE(*,*)' ' C WRITE(*,*)' ' C WRITE(*,*)' ' CC WRITE(*,*)'PLANAR TRACKS ' C PRINT POINT LIST OF LINKED SEGMENTS,CHI,POINTERS TO SEGMENTS DO 200 I=1,NPP SLPR=RSSS(I) SLPHI=PSSS(I) FN=COS(ATAN(SLPR)) CONS=-2./(11.7*0.0002998) PP=1./(CONS*SLPHI*FN) CC WRITE(*,*)' P,THETA,CHI ',I,PP,SLPR,CHPP(I) 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 PICK UP RADIALS LRR(1,I)=0 LRR(2,I)=0 LRR(3,I)=0 CALL FPKPKR(I) 200 CONTINUE ENDIF C END OF LINK SECTION *-----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: 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 SUBROUTINE FPPJN3 **: 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 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 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 *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 SUBROUTINE FPPJ12 **: 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 IC=0 DO 400 L=1,2 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) 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 *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 SUBROUTINE FPPJ23 **: 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 IC=0 DO 400 L=2,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) 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: 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 SUBROUTINE FPPJ13 **: 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 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 *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 : Stephen J. Maxfield 28/11/92 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 *CMZ : 4.00/00 07/09/93 17.57.55 by Stephen Burke *-- Author : I. O. Skillicorn 31/08/93 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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: 4.00/08 18/11/93 08.59.35 by Stephen J. Maxfield *-- Author : I. O. Skillicorn 18/11/93 C 15/10/93 310151326 MEMBER NAME FPRFIT (FILE46) FVS C 15/10/93 310150934 MEMBER NAME FPRFIT (GRAPHICS) FVS *-- AUTHOR : I.O.SKILLICORN 15/10/93 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 *CMZU: 7.00/04 24/04/95 17.02.17 by Stephen Burke *-- Author : "I. O. Skillicorn" 24/04/95 * * * SUBROUTINE FPCXTD * * 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 c call stext(3000,4,' conn set rphi pl ') c call bhs(3000,0,40,0.,40.) c call stext(3001,4,' conn set r pl') c call bhs(3001,0,40,0.,40.) c call stext(3002,4,' conn set rad drphi all min') c call bhs(3002,0,40,0.,40.) c call stext(3003,4,' conn set r rad') c call bhs(3003,0,40,0.,200.) c call stext(3004,4,' conn set p/r mod ') c call bhs(3004,0,20,0., 20.) c call stext(3005,4,' conn set r pl rphi sel') c call bhs(3005,0,40,0.,40.) c call stext(3006,4,' conn set r rad rphi sel') c call bhs(3006,0,40,0.,200.) c call stext(3007,4,' conn set pl dx/dz diff') c call bhs(3007,0,40,-0.20,0.20) c call stext(3008,4,' conn set pl dy/dz diff') c call bhs(3008,0,40,-0.20,0.20) c call stext(3009,4,' conn set r dx/dz diff') c call bhs(3009,0,40,-0.20,0.20) c call stext(3010,4,' conn set r dy/dz diff') c call bhs(3010,0,40,-0.20,0.20) c call stext(3011,4,' conn set pl drift m-ex sel') c call bhs(3011,0,40,-2.00,2.00) c call stext(3012,4,' conn set pl dd cms**2 min') c call bhs(3012,0,40,.0,20.0) c call stext(3013,4,' conn set pl dd cms**2 all') c call bhs(3013,0,40,.0,20.0) call stext(3015,4,' r based tr. pl mods in /out') call bhs(3015,0,40,.0,20.0) call stext(3016,4,' p based tr. pl mods in /out') call bhs(3016,0,40,.0,20.0) call stext(3017,4,' conn set rad dd cms**2 min') call bhs(3017,0,40,.0,20.0) call stext(3018,4,' conn set rad dd drphi cut, all') call bhs(3018,0,40,.0,20.0) call stext(3019,4,' conn set rad dd drphi cut,same ') call bhs(3019,0,40,.0,20.0) call stext(3020,4,' conn set rad dd drphi cut,diff ') call bhs(3020,0,40,.0,20.0) call stext(3021,4,' conn set pla sep**2 model-seg ') call bhs(3021,0,40,.0,20.0) call stext(3022,4,' conn set pla dd (sep**2 cut) ') call bhs(3022,0,40,.0,20.0) call stext(3023,4,' conn set rad (with pla) drphi min') call bhs(3023,0,40,0.,40.) call stext(3024,4,' conn set rad (no pla) drphi min') call bhs(3024,0,40,0.,40.) call stext(3025,4,' conn set rad drphi all min') call bhs(3025,0,40,0.,40.) call stext(3026,4,' conn set pla sep**2 model-seg ') call bhs(3026,0,50,.0,10.0) call stext(3030,0,' drphi vs dd Radial') call bhd(3030,0,40,0.,40.,40,0.,20.) call stext(3031,0,' sep**2 vs dd Planar ') call bhd(3031,0,40,0.,20.,40,0.,20.) 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 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) if(isgg(1,k)*isgg(2,k)*isgg(3,k).ne.0)callshs(3015,0,1.01) if(isgg(1,k)+isgg(2,k)+isgg(3,k).ne.0)callshs(3015,0,7.01) if(isgg(1,k)*isgg(2,k).ne.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,2.01) if(isgg(3,k)*isgg(2,k).ne.0.and.isgg(1,k).eq.0) 1 call shs(3015,0,3.01) if(isgg(3,k)*isgg(1,k).ne.0.and.isgg(2,k).eq.0) 1 call shs(3015,0,4.01) if(isgg(1,k).ne.0.and.isgg(2,k).eq.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,5.01) if(isgg(1,k).eq.0.and.isgg(2,k).ne.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,5.01) if(isgg(1,k).eq.0.and.isgg(2,k).eq.0.and.isgg(3,k).ne.0) 1 call shs(3015,0,5.01) if(isgg(1,k).eq.0.and.isgg(2,k).eq.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,6.01) 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 if(ity.eq.1)then if(lpp(1,k)*lpp(2,k)*lpp(3,k).ne.0)callshs(3016,0,1.01) if(lpp(1,k)*lpp(2,k).ne.0.and.lpp(3,k).eq.0) 1 call shs(3016,0,2.01) if(lpp(3,k)*lpp(2,k).ne.0.and.lpp(1,k).eq.0) 1 call shs(3016,0,3.01) if(lpp(3,k)*lpp(1,k).ne.0.and.lpp(2,k).eq.0) 1 call shs(3016,0,4.01) if(lpp(1,k).ne.0.and.lpp(2,k).eq.0.and.lpp(3,k).eq.0) 1 call shs(3016,0,5.01) if(lpp(1,k).eq.0.and.lpp(2,k).ne.0.and.lpp(3,k).eq.0) 1 call shs(3016,0,5.01) if(lpp(1,k).eq.0.and.lpp(2,k).eq.0.and.lpp(3,k).ne.0) 1 call shs(3016,0,5.01) * PRINT 1004,k,(IRR(n,k),n=1,36),LRR(1,k),LRR(2,k),LRR(3,k) c PRINT 1003,k,(IPP(n,k),n=1,36),LPP(1,k),LPP(2,k),LPP(3,k) 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 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 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 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 if(ity.eq.2)then if(isminr.ne.0.and.fnd.ne.0.)then call shs(3017,0,ddmin) endif if(ismin.ne.0)then call shs(3025,0,drmin) if(iplaa.eq.1)then call shs(3023,0,drmin) endif if(iplaa.eq.0)then call shs(3024,0,drmin) endif 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(ity.eq.2)then c radial based tracks IF(ISMIN .NE. 0.and.isminr.eq.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 ENDIF ENDIF IF(isminr.ne.0.and.ISMIN .NE. 0) THEN call shd(3030,0,drmin,ddmin) IF(DRMIN .LT. DRPCUT) THEN c planar segment close to radial based track model c and linked via a previously associated planar c segment call shs(3018,0,ddmin) if(ismin.eq.isminr)then c planar linkage plots for planars c linked by radial-based track model call shs(3019,0,ddmin) endif if(ismin.ne.isminr)then call shs(3020,0,ddmin) endif c hard wired 5 cm**2 cut *************************************** if(ddmin.lt.5.)then IUSEG(ISMINr, ISM) = 1 ISGG(ISM,K) = ISMINr II=0 DO 51 IWIR= IFR, ILS II = II+1 IOSP = IDGISG(II,ISMINr,ISM) IF (IOSP.EQ.0) GOTO 51 IRP(IWIR, K) = IABS(IOSP) SDP(IWIR, K) = SIGN(1.0, FLOAT(IOSP)) Ipuze(IABS(IOSP), IWIR)=1 51 CONTINUE endif 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 call shd(3031,0,sep,ddmin) c hard wired 3 cm**2 cut ************************************************ if(sep.gt.3.0)ibad=1 call shs(3021,0,sep) call shs(3026,0,sep) c plot ddmin after planar segment identified as close c to overall track model if(ibad.eq.0)then call shs(3022,0,ddmin) endif 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 ENDIF ENDIF endif C C C--- End of loop over supermodules C 10 CONTINUE c debug ********************************************* if(ity.eq.2)then * PRINT 1002,k,(IRP(n,k),n=1,36),ISGG(1,k),ISGG(2,k),ISGG(3,k) if(isgg(1,k)*isgg(2,k)*isgg(3,k).ne.0)callshs(3015,0,11.01) if(isgg(1,k)+isgg(2,k)+isgg(3,k).ne.0)callshs(3015,0,17.01) if(isgg(1,k)*isgg(2,k).ne.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,12.01) if(isgg(3,k)*isgg(2,k).ne.0.and.isgg(1,k).eq.0) 1 call shs(3015,0,13.01) if(isgg(3,k)*isgg(1,k).ne.0.and.isgg(2,k).eq.0) 1 call shs(3015,0,14.01) if(isgg(1,k).ne.0.and.isgg(2,k).eq.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,15.01) if(isgg(1,k).eq.0.and.isgg(2,k).ne.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,15.01) if(isgg(1,k).eq.0.and.isgg(2,k).eq.0.and.isgg(3,k).ne.0) 1 call shs(3015,0,15.01) if(isgg(1,k).eq.0.and.isgg(2,k).eq.0.and.isgg(3,k).eq.0) 1 call shs(3015,0,16.01) endif if(ity.eq.1)then * PRINT 1003,k,(IPP(n,k),n=1,36),LPP(1,k),LPP(2,k),LPP(3,k) if(lpp(1,k)*lpp(2,k)*lpp(3,k).ne.0)callshs(3016,0,11.01) if(lpp(1,k)*lpp(2,k).ne.0.and.lpp(3,k).eq.0) 1 call shs(3016,0,12.01) if(lpp(3,k)*lpp(2,k).ne.0.and.lpp(1,k).eq.0) 1 call shs(3016,0,13.01) if(lpp(3,k)*lpp(1,k).ne.0.and.lpp(2,k).eq.0) 1 call shs(3016,0,14.01) if(lpp(1,k).ne.0.and.lpp(2,k).eq.0.and.lpp(3,k).eq.0) 1 call shs(3016,0,15.01) if(lpp(1,k).eq.0.and.lpp(2,k).ne.0.and.lpp(3,k).eq.0) 1 call shs(3016,0,15.01) if(lpp(1,k).eq.0.and.lpp(2,k).eq.0.and.lpp(3,k).ne.0) 1 call shs(3016,0,15.01) endif c end debug *********************************************** 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: 7.00/04 24/04/95 17.03.31 by Stephen Burke *-- Author : I. O. Skillicorn 24/04/95 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 *CMZ : 2.00/00 12/12/90 17.35.42 by Girish D. Patel *-- Author : I.O. Skillicorn 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: 3.05/04 14/08/92 17.06.57 by Stephen J. Maxfield *-- Author : I.O. Skillicorn 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: 3.03/03 15/05/92 19.18.43 by Stephen J. Maxfield *-- Author : I.O. Skillicorn * SUBROUTINE FTFIT C FIND LINE SEGMENTS WITH FULL FIT C USE FOR ACCURACY C WITH MODS FOR STR LINE FIT IN R-Z 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) * 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 1001 CONTINUE RETURN END *CMZU: 3.02/01 25/02/92 18.44.50 by Stephen J. Maxfield *-- Author : I.O. Skillicorn * * * 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 *CMZ : 3.01/10 25/02/92 10.46.33 by Gregorio Bernardi *-- Author : I.O. Skillicorn * * * 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: 3.08/03 23/02/93 09.40.05 by Stephen J. Maxfield *-- Author : I.O. Skillicorn * 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: 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 17/02/92 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 *CMZU: 3.09/01 25/04/93 17.18.20 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 17/02/92 SUBROUTINE FPLPKS(IT, K, IUSEDP, IUSEG) **: FPLPKS.......SM. Fix small bug. * * 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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) * Local arrays... DIMENSION IUSEDP(MAXTRK,36), IUSEG( MAXSEG, 3) DIMENSION RSEG(4),PSEG(4) PARAMETER(PI2=6.2831853) * Establish cut values for this iteration... 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 C--- Loop over supermodules C DO 10 ISM = 1,3 C C--- Calculate radial prediction for segment in this supermodual C Z = ZPP( 6 + (ISM -1)*12 ) 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) C C--- Form radial 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 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--- 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 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. DRMIN) THEN IF(DR .LT. DRCUT) THEN DRMIN = DRPHI ISMIN = IP DRM = DR ENDIF ENDIF C C--- End of loop over planars segments for supermodule C 20 CONTINUE IF(IDOHIS .GE. 2) THEN CALL SHS(214+IT, 0, DRMIN) CALL SHS(217+IT, 0, DRM) ENDIF C C--- Build list of planar hits and mark segment and hits used C IFR = 1+(ISM-1)*12 ILS = 11+IFR DO 60 IWIR= IFR, ILS IRP(IWIR, K) = 0 60 CONTINUE ISGG(ISM,K) = 0 IF(ISMIN .NE. 0) THEN IF(DRMIN .LT. DRPCUT) THEN IF(IT.EQ.NIT) THEN IUSEG(ISMIN, ISM) = 1 ISGG(ISM,K) = ISMIN 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, K) = IABS(IOSP) SDP(IWIR, K) = SIGN(1.0, FLOAT(IOSP)) IF(IT.EQ.NIT) THEN IF(IUSEDP(IABS(IOSP), IWIR).NE.0) THEN DO 51 ITRK = 1, IG IF(ITRK .EQ. K) GOTO 51 IF(IRP(IWIR, ITRK) .EQ. IABS(IOSP)) THEN IRP(IWIR, ITRK) = 0 ENDIF 51 CONTINUE ENDIF IUSEDP(IABS(IOSP), IWIR)=1 ENDIF 50 CONTINUE ENDIF ENDIF C C--- End of loop over supermodules C 10 CONTINUE RETURN END *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 * * C 13/06/93 306141018 MEMBER NAME FTFHQQ1 (FILE46) FVS C 13/06/93 306131030 MEMBER NAME FTFHQQ (FILE46) FVS 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: 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 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: 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 * * 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: 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 * 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 *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 * * * 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(2000,4,' PHI CONT - M12 COMMON R PSCUT 2M') CALL BHS(2000,0,40,-.10,.10) CALL STEXT(2001,4,' PHI CONT - M23 COMMON R PSCUT 2M') CALL BHS(2001,0,40,-.10,.10) CALL STEXT(2002,4,' PHI CONT - M13 COMMON R PSCUT 2M') CALL BHS(2002,0,40,-.10,.10) CALL STEXT(2003,4,' DPHI/DZ CONTINUITY - MODULES 12 ') CALL BHS(2003,0,50,-.010,.010) CALL STEXT(2004,4,' DPHI/DZ CONTINUITY - MODULES 23 ') CALL BHS(2004,0,50,-.010,.010) CALL STEXT(2005,4,' DPHI/DZ CONTINUITY - MODULES 13 ') CALL BHS(2005,0,50,-.010,.010) CALL STEXT(2006,4,' PHI CONT - M12 COMMON R REFIT ALL') CALL BHS(2006,0,50,-.25,.25) CALL STEXT(2007,4,' PHI CONT - M23 COMMON R REFIT 3M') CALL BHS(2007,0,50,-.25,.25) CALL STEXT(2008,4,' PHI CONT - M13 COMMON R REFIT') CALL BHS(2008,0,50,-.25,.25) CALL STEXT(2013,4,' DPHI/DZ R - MODULES 12 ALL') CALL BHS(2013,0,50,-.010,.010) CALL STEXT(2014,4,' DPHI/DZ R - MODULES 23 ') CALL BHS(2014,0,50,-.010,.010) CALL STEXT(2015,4,' DPHI/DZ R - MODULES 13 ') CALL BHS(2015,0,50,-.010,.010) 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) CALL STEXT(2018,4,' PHI CONT - M13 COMMON R PSCUT ') CALL BHS(2018,0,40,-.10,.10) CALL STEXT(2019,4,' PHI VS PHIPRIME M12 ALL ') CALL BHD(2019,0,40,-.10,.10,50,-.01,.01) CALL STEXT(2020,4,' RTEST 12 AFTER PCUT,PSCUT ALL') CALL BHS(2020,0,50,-50.,50.) CALL STEXT(2021,4,' RTEST 23 AFTER PCUT,PSCUT 3M') CALL BHS(2021,0,50,-50.,50.) CALL STEXT(2022,4,' RTEST 13 AFTER PCUT,PSCUT ') CALL BHS(2022,0,50,-50.,50.) CALL STEXT(2023,4,' PHI CONT AT M2 3M R123 PSCUT ') CALL BHS(2023,0,40,-.10,.10) CALL STEXT(2030,4,' R*PHI CONT - M12 COMMON R PSCUT 2M') CALL BHS(2030,0,40,-10.,10.) CALL STEXT(2031,4,' R*PHI CONT - M23 COMMON R PSCUT 2M') CALL BHS(2031,0,40,-10.,10.) CALL STEXT(2032,4,' R*PHI CONT - M13 COMMON R PSCUT 2M') CALL BHS(2032,0,40,-10.,10.) CALL STEXT(2036,4,' R*PHI CONT - M12 R12 PSCUT ALL') CALL BHS(2036,0,50,-5.,5.) CALL STEXT(2037,4,' R*PHI CONT-M23 R23 PSCUT 3M AFTER M12 SEL ') CALL BHS(2037,0,50,-5.,5.) CALL STEXT(2033,4,' R*PHI CONT AT M2 3M R123 PSCUT ') CALL BHS(2033,0,40,-10.,10.) CALL STEXT(2040,4,' LINKS 123, 12 23 13 TOT EVTS ') CALL BHS(2040,0,40,0.,20.) CALL STEXT(2041,4,' INITIAL/FINAL LINKS 123 ') CALL BHS(2041,0,40,0.,4.) CALL STEXT(2042,4,' INITIAL/FINAL LINKS 12 ') CALL BHS(2042,0,40,0.,4.) CALL STEXT(2043,4,' INITIAL/FINAL LINKS 23 ') CALL BHS(2043,0,40,0.,4.) CALL STEXT(2044,4,' INITIAL/FINAL LINKS 13 ') CALL BHS(2044,0,40,0.,4.) CALL STEXT(2045,4,' FTJN : CHI DRIFT RAD 123 SEL' ) CALL BHS(2045,0,50, 0.00,25.0) CALL STEXT(2046,4,' FTJN : CHI DRIFT RAD 12 SEL' ) CALL BHS(2046,0,50, 0.00,25.0) CALL STEXT(2047,4,' FTJN : CHI DRIFT RAD 23 SEL' ) CALL BHS(2047,0,50, 0.00,25.0) ENDIF * CALL SHS(2040,0,15.) 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 CALL SHS(2006,0,PP1-PP2) CALL SHD(2019,0,PP1-PP2,PS1-PS2) IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2016,0,PP1-PP2) IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2036,0,(PP1-PP2)*RRS*ZM12) IF(ABS(PP1-PP2).LT.PCUT) THEN CALL SHS(2013,0,PS1-PS2) IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2020,0,RTEST) ENDIF * 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 CALL SHS(2007,0,PP1-PP2) IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2017,0,PP1-PP2) IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2037,0,(PP1-PP2)*RRS*ZM23) IF(ABS(PP1-PP2).LT.PCUT) THEN CALL SHS(2014,0,PS1-PS2) IF(ABS(PS1-PS2).LT.PSCUT)CALL SHS(2021,0,RTEST) ENDIF 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 CALL SHS(2023,0,(0.5*(P1+P3)-P2)) CALL SHS(2033,0,(0.5*(P1+P3)-P2)*RRS*Z2) 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 CALL SHS(2040,0,2.) CALL SHS(2040,0,10.) CALL SHS(2045,0,CH(I)) *------------------------------------------ C PRINT1000,LL(I,1),LL(I,2),LL(I,3) 1000 FORMAT(' T1,T2,T3 ',5I3) *------------------------------------------ 500 CONTINUE IF(NLLL.NE.0)CALL SHS(2041,0,FLOAT(LLL)/FLOAT(NLLL)) RETURN END *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 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... CALL SHS(140,0,TZ) CALL SHS(141,0,TZ) 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... CALL SHS(140,0,TZ) CALL SHS(141,0,TZ) 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)) CALL SHS(145,0,TZV) * Resolution... TZV=0.5*( (YT(K+4)+YT(K+1))-(YT(K+3)+YT(K+2)) ) CALL SHS(148,0,TZV) 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 IF(ABS(RESS).LT.0.25)CALL SHS(4099+IM,0,RESS) 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: 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 * * 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: 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 SUBROUTINE FTCHKH(PS,PI,RS,RI,II,JJ,KK,CHID) **: FTCHKH 40000 IS. New linking routine. **---------------------------------------------------------------------- * * Small mods to control Histogram filling. * >>NOTE: LINCHK=0 moved to top of 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 : 3.03/01 01/05/92 11.52.43 by Gregorio Bernardi *-- Author : R. Henderson 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 : 3.03/01 01/05/92 11.52.43 by Gregorio Bernardi *-- Author : R. Henderson 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 : 3.03/01 01/05/92 12.02.39 by Gregorio Bernardi *-- Author : R. Henderson 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 : 3.03/01 01/05/92 11.52.46 by Gregorio Bernardi *-- Author : R. Henderson 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 *CMZU: 3.03/01 27/04/92 15.10.44 by Stephen J. Maxfield *-- Author : R. Henderson 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 *CMZU: 2.01/03 18/02/91 10.49.48 by Girish D. Patel *-- Author : R. Henderson 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 *CMZU: 3.09/01 20/05/93 17.59.06 by Stephen J. Maxfield *-- Author : R. Henderson 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *CMZU: 3.06/02 21/09/92 09.59.32 by Stephen J. Maxfield *-- Author : R. Henderson 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 : 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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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) 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) * Drift in W, Error, flag... DRIW( NDPW(KWIR), KWIR) = DRIFT 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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) 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 111 ENDIF DRSTO(NDRSTO(IWR),IWR) = (DRIFP*(-1.)**(I-1) + DW(IND,IPO))*10.0 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 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 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *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 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 *CMZU: 5.03/00 24/10/94 15.17.56 by Stephen Burke *-- Author : R. Henderson 24/10/94 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 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--- 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 *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 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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), 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 *CMZU: 7.00/04 27/04/95 21.19.24 by Stephen Burke *-- Author : R. Henderson 24/10/94 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 *CMZU: 7.00/04 05/05/95 00.57.39 by Stephen Burke *-- Author : Stephen Burke 05/05/95 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 *CMZU: 7.00/04 08/05/95 16.14.12 by Stephen Burke *-- Author : Stephen Burke 05/05/95 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 : 3.01/08 13/02/92 18.25.30 by Gregorio Bernardi *-- Author : 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 *CMZU: 2.05/07 18/07/91 00.01.58 by Girish D. Patel *-- Author : S.J. Maxfield 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 = 600) PARAMETER (MAXCON = 100) PARAMETER (LIMSTO = 5000) PARAMETER (MSEGLM = 250) 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 *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 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=2) * 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) * * 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 *CMZ : 3.01/08 13/02/92 18.25.30 by Gregorio Bernardi *-- Author : Girish D. Patel 25/04/91 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: 3.09/07 26/07/93 10.00.34 by Stephen Burke *-- Author : Girish D. Patel 16/04/91 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 *CMZ : 2.05/07 18/07/91 13.19.16 by Gregorio Bernardi *-- Author : S.J. Maxfield 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 *CMZ : 2.05/07 18/07/91 13.19.16 by Gregorio Bernardi *-- Author : S.J. Maxfield 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: 2.05/01 21/06/91 14.44.46 by Girish D. Patel *-- Author : Girish D. Patel 25/04/91 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: 3.09/07 26/07/93 10.00.34 by Stephen Burke *-- Author : S.J. Maxfield 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 *CMZ : 2.05/07 18/07/91 13.19.16 by Gregorio Bernardi *-- Author : S.J. Maxfield 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: 2.05/01 21/06/91 14.50.52 by Girish D. Patel *-- Author : S.J. Maxfield 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 : 2.00/00 12/12/90 17.35.45 by Girish D. Patel *-- Author : S.J. Maxfield SUBROUTINE FPFTVR *-----------------------------------------------------------* * 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,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. * FTVR bank... NBN = 0 IND = NLINK('FTVR',NBN) IF(IND.EQ.0) THEN WRITE(6,*) ' FPFTVR>> FTVR Bank not found in event ',KEVENT RETURN ENDIF NROW = IW(IND+2) WRITE(6,'('' '')') WRITE(6,'(/,8X,'' ------- FTVR BANK: Event'',I4, + 2X,I4,'' tracks -------'')') + KEVENT,NROW WRITE(6,'(10X,''Constrained track fits'')') WRITE(6,'( + ''Trk Cu Phi Theta'', + '' x y z'', + '' Nht Chsq FRUX FPUX'')') DO 1 J= 1,NROW WRITE(6,'(I3,6(1X,F7.3),I4,F6.3,2I5)') + J,(RBTAB(IND,K,J), K=1,6),IBTAB(IND,17,J), + RBTAB(IND,18,J),(IBTAB(IND,L,J), L=19,20) 1 CONTINUE IF(IDIAG.GE.2) THEN DO 2 J=1,NROW * 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 *CMZU: 3.09/01 06/04/93 14.55.02 by Stephen J. Maxfield *-- Author : Stephen J. Maxfield 27/02/93 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 *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 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( 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 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') 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') * FTLSEG Histograms... CALL BHS(140,0,50,-0.2,0.20) CALL STEXT(140,4,' R Checksum: T-Zero 4 Wires') CALL BHS(141,0,50,-0.5,0.50) CALL STEXT(141,4,' R Checksum: T-Zero 4 Wires') CALL BHS(145,0,50,-0.25,0.250) CALL STEXT(145,4,' R Checksum: +- 2s/v ') CALL BHS(148,0,50,-0.25,0.250) CALL STEXT(148,4,' R Checksum: Resolution ') CALL BHS( 4100, 0, 50, -0.25, 0.25) CALL STEXT(4100, 4,'Radial segment Drift Residuals SM0') CALL BHS( 4101, 0, 50, -0.25, 0.25) CALL STEXT(4101, 4,'Radial segment Drift Residuals SM1') CALL BHS( 4102, 0, 50, -0.25, 0.25) CALL STEXT(4102, 4,'Radial segment Drift Residuals 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 *CMZU: 2.01/03 13/02/91 16.06.26 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.28 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 3.09/07 26/07/93 10.00.35 by Stephen Burke *-- Author : S.Burke 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 *CMZU: 2.01/03 13/02/91 16.06.24 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 3.02/07 27/03/92 10.45.08 by Curtis A. Meyer *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.52 by Girish D. Patel *-- Author : S.Burke 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 *CMZU: 2.01/03 13/02/91 16.06.26 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.26 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *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 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 *CMZU: 3.02/07 27/03/92 10.45.09 by Curtis A. Meyer *-- Author : S.Burke / J.V. Morris 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 *CMZU: 3.01/08 24/01/92 12.19.11 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.51 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 * * * ********************************************************************** DOUBLE PRECISION PCT,PMAX 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 *CMZU: 2.01/03 18/02/91 10.52.11 by Stephen Burke *-- Author : S.Burke 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 : 2.00/00 12/12/90 17.35.48 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 18/02/91 10.43.48 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.23 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.07/01 18/07/91 00.17.48 by Stephen Burke *-- Author : S Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.30 by Stephen Burke *-- Author : S.Burke 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 *CMZU: 3.02/07 27/03/92 10.45.11 by Curtis A. Meyer *-- Author : S.Burke / J.V. Morris 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 *CMZU: 3.03/01 27/04/92 16.17.41 by Stephen Burke *-- Author : Stephen Burke 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 : 2.00/00 12/12/90 17.35.50 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 18/02/91 10.45.16 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.49 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.28 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 3.02/07 27/03/92 10.45.12 by Curtis A. Meyer *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 18/02/91 10.50.39 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.52 by Girish D. Patel *-- Author : S.Burke 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 *CMZU: 3.02/07 27/03/92 10.45.13 by Curtis A. Meyer *-- Author : Stephen Burke 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 *CMZU: 2.01/03 13/02/91 16.06.19 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *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 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 : 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 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 : 2.00/00 12/12/90 17.35.48 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.49 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 *CMZU: 3.02/07 27/03/92 10.45.13 by Curtis A. Meyer *-- Author : S.Burke / J.V. Morris 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 *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 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 : 2.00/00 12/12/90 17.35.46 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.22 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.23 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.50 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.46 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.03/03 28/03/91 15.14.10 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 3.02/07 27/03/92 10.45.14 by Curtis A. Meyer *-- Author : S.Burke / J.V. Morris 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 *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 *-----------------------------------------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 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 *CMZU: 3.02/07 27/03/92 10.46.09 by Curtis A. Meyer *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.35 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.35 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.36 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 : 2.00/00 12/12/90 17.35.53 by Girish D. Patel *-- Author : S.Burke / J.V. Morris 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 *CMZU: 2.01/03 13/02/91 16.06.35 by Stephen Burke *-- Author : S.Burke / J.V. Morris 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 : 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 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 *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 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 *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 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 *CMZU: 3.02/07 27/03/92 10.48.18 by Curtis A. Meyer *-- Author : Stephen Burke 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 *CMZU: 3.08/03 04/03/93 13.48.04 by Stephen J. Maxfield *-- Author : S.Burke 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 *CMZU: 3.04/01 02/06/92 17.12.31 by Stephen Burke *-- Author : Stephen Burke 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 *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 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 *CMZU: 2.02/03 28/02/91 15.55.36 by Stephen Burke *-- Author : S.Burke 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 *CMZU: 3.03/02 04/05/92 18.30.12 by Stephen J. Maxfield *-- Author : Stephen Burke 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 : 2.00/00 12/12/90 17.35.56 by Girish D. Patel *-- Author : S.Burke 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 *CMZU: 2.03/03 17/04/91 12.10.11 by Stephen Burke *-- Author : S.Burke 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 *CMZU: 3.04/01 02/06/92 17.12.31 by Stephen Burke *-- Author : Stephen Burke 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 *CMZU: 3.06/06 14/10/92 19.40.06 by Stephen Burke *-- Author : Stephen Burke 14/10/92 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 *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 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 : 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 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 : 7.00/00 10/04/95 11.07.25 by G. Raedel *-- Author : *-- 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 *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 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,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 IF(REVENT) 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 : 4.01/00 07/12/93 19.55.23 by Girish D. Patel *-- Author : Girish D. Patel 07/12/93 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 *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 SUBROUTINE FQBOOK ************************************************************************ * HBOOKing of histograms for PLANAR and RADIAL monitoring * ************************************************************************ *KEEP,FMOBIN. PARAMETER( NBINR=40 ) *KEEP,FMOHIS. INTEGER IHS(26) 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,50,0.,2500.,40,3.,11.) !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,40,3.,11. ,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,40,3.,11.,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,50,-75.,75.,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,60,690.,1290.,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,60,80.,380.,13,0.,13.) !SGI CALL STEXT(IHX + 10 ,4,'FT Planar') !SGI CALL STEXT(IHX + 10 ,1,'Raw D-Time DOS/Front') !SGI 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,50,-0.5,49.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.,40,3.,11.) !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,40,3.,11. ,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,50,-75.,75.,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,27,300.,1920.,NBINR,0.,GMAX) !SGI CALL STEXT(IHX + 25 ,4,'FT Radial') !SGI CALL STEXT(IHX + 25 ,1,'RawD-Time DOS/Back Rbin') !SGI 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 *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 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(26) 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 *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 SUBROUTINE FQMONP *KEEP,FMOHIS. INTEGER IHS(26) 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 ) 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) CALL FILLQP(IWIRE,FDT,FQ,0) ! fill T and Q arrays INDX = INDX+6 137 CONTINUE ENDIF CALL FCHKQP ENDIF 100 RETURN END *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 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(26) 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 *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 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(26) 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 *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 SUBROUTINE FQMONR **: FQMONR.......SM. Modifications for farm. **: FQMONR.......SM. Addition of alpha and T0 corrections. *KEEP,FMOHIS. INTEGER IHS(26) 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 ) 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 CALL FILLQR(IWIRE,FDT,FQ,RADIUS,ISGNW,IFLG2) INDX = INDX+6 137 CONTINUE ENDIF CALL FCHKQR ENDIF * * END OF LOOP OVER EVENTS - COLLECT STATISTICS * 100 RETURN END *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 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(26) 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 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 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 *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 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(26) 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 *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 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 BHS(IHX+5,0,60,-RANGE,RANGE) CALL STEXT(IHX+5,4,'Drift residuals (radials)') CALL BHS(IHX+6,0,60,-12.0,12.0) CALL STEXT(IHX+6,4,'Radius residuals (radials)') 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 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 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 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 BHS(IHX+76,0,60,-RANGE,RANGE) CALL STEXT(IHX+76,4,'Drift residuals (radials) (>1 seg)') CALL BHS(IHX+77,0,60,-3.0,3.0) CALL STEXT(IHX+77,4,'Planar drift distance') CALL BHS(IHX+78,0,60,-6.0,6.0) CALL STEXT(IHX+78,4,'Radial drift distance') CALL BHS(IHX+79,0,60,-0.15,0.15) CALL STEXT(IHX+79,4,'Planar C1 checksum') CALL BHS(IHX+80,0,60,-0.15,0.15) CALL STEXT(IHX+80,4,'Planar C2 checksum') CALL BHS(IHX+81,0,60,-0.15,0.15) CALL STEXT(IHX+81,4,'Radial C1 checksum') CALL BHS(IHX+82,0,60,-0.15,0.15) CALL STEXT(IHX+82,4,'Radial C2 checksum') CALL BHS(IHX+83,0,60,-RANGE,RANGE) CALL STEXT(IHX+83,4,'Drift residuals (planars) (<5 mm)') CALL BHS(IHX+84,0,60,-RANGE,RANGE) CALL STEXT(IHX+84,4,'Drift residuals (radials) (<5 mm)') 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') 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') 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') RETURN END *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 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) *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 CALL FFKLMN(INFTUR,JTR) 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 *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 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,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) DO 100 JPL=1,JPLMAX IF (.NOT.LMES(JPL)) GOTO 100 DZ = ZPL(JPL) - ZSTART CALL FKTRAN(DZ,ZSTART,SSTART,STRAN,DTRAN) * Track angle, time-of-flight, propagation time CALL FFCORR(JPL,STRAN,ZNOM,VXYZ,DEVT0,DCORR) IF (IDIGI(JPL).LT.0) DCORR = -DCORR WMES(1,JPL) = WMES(1,JPL) + DCORR 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 *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 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 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) 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 *CMZU: 3.04/04 06/08/92 15.47.27 by Stephen Burke *-- Author : Stephen Burke 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 *CMZU: 3.09/07 26/07/93 10.00.37 by Stephen Burke *-- Author : Stephen Burke 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 *CMZU: 3.09/07 26/07/93 10.00.37 by Stephen Burke *-- Author : Stephen Burke 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 *CMZU: 3.04/04 06/08/92 15.47.27 by Stephen Burke *-- Author : Stephen Burke 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 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 *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 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 *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 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) 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) * Track angle, time-of-flight and propagation time CALL FFCORR(JPL,S,ZNOM,VXYZ,DEVT0,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 *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 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 *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 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 *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 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 *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 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 *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 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 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 IF (NHIT.GE.NRHIT) NMODR = NMODR + 1 200 CONTINUE 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 *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 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 *CMZU: 5.03/00 28/10/94 12.08.52 by Stephen Burke *-- Author : Stephen Burke 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 *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 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) *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,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. ********************************************************************** * Get the nominal z-vertex if available ZNOM = 0. INBEAZ = IABS(MDB('BEAZ')) IF (INBEAZ.GT.0) ZNOM = RBTAB(INBEAZ,2,1) * 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 *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 SUBROUTINE FFCORR(JPL,SVEC,ZNOM,VXYZ,DEVT0,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 * * * * OUTPUT: * * DCORR is the correction to the drift distance * * * ********************************************************************** DOUBLE PRECISION SVEC(5) DIMENSION VXYZ(3),R(3),B(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 DEVT0 = VDRFTP*DEVT0 ELSE ZMID = ZRNOM - ZNOM DTOF = VDRFTR*(ZMID - VDIST(R,VXYZ,3))/VTOF DEVT0 = 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 * CALL GUFLD(R,B) IF (IRP(JPL).EQ.1) THEN BMID = BPNOM - B(3) BRAT = BMID*S2LORP/BPNOM ELSE BMID = BRNOM - B(3) BRAT = BMID*S2LORR/BRNOM ENDIF DDBF = DRIFT*BRAT DCORR = DEVT0 + 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,DEVT0,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 *CMZU: 5.03/00 28/10/94 12.08.52 by Stephen Burke *-- Author : Stephen Burke 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 *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 : *-- Author : Stephen Burke 13/03/95 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) *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 DO 100 JPL=J1,J2 IF (LMES(JPL)) THEN IPREV = IPREV + 1 II = IRP(JPL) * 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 * Unpack drift sign and hit number ISGN = 0 IF (IDIGI(JPL).LT.0) ISGN = 1 JDIG = ABS(IDIGI(JPL)) 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 ICELL = IC * Corrected drift distance DD(IWR) = RBTAB(INDLC(II),3+ISGN+3*II,JDIG) CALL SHS(76+II,0,DD(IWR)*(-1)**ISGN) DUNC = RBTAB(INDLC(II),2,JDIG) IF (DUNC.LT.0.5) CALL SHS(82+II,0,SNGL(RSMT(1,JPL))) * Checksums (4 wire groups) IF (IWR.EQ.4 .AND. 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) 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)) * 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) IF (MES(JPL).EQ.2) CALL SHD(70,0,SNGL(RSMT(2,JPL)),Q) ENDIF ENDIF ENDIF IF (MOD(JPL,4).EQ.0) IPREV = 0 100 CONTINUE RETURN END