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