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