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