*-- 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),WW(4)
* sin and cos of the wedge angle
DATA SPHIW/0.1305261922201/,CPHIW/0.9914448613738/
SAVE SPHIW,CPHIW
*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
MASK = 0
MASK2 = 0
ISLAST = 0
DO 100 JPL=J1,J2
IF (LMES(JPL)) THEN
IPREV = IPREV + 1
II = IRP(JPL)
JDIG = ABS(IDIGI(JPL))
IF (MOD(NEVENT,10).EQ.0) THEN
* 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
* 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)
C IF (MES(JPL).EQ.2) CALL SHD(70,0,SNGL(RSMT(2,JPL)),Q)
CALL SHD(70,0,RRES,Q)
ENDIF
ENDIF
* Unpack drift sign and hit number
ISGN = 0
IF (IDIGI(JPL).LT.0) ISGN = 1
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
IF (IWR.EQ.1) THEN
CALL SBIT1(MASK,IWR)
ELSEIF (IWR.EQ.3 .AND. IC.NE.ICELL+1) THEN
CALL SBIT1(MASK,IWR)
ELSEIF (IWR.NE.3 .AND. IC.EQ.ICELL+1) THEN
CALL SBIT1(MASK,IWR)
ENDIF
IF (IWR.EQ.1) THEN
CALL SBIT1(MASK2,IWR)
ELSEIF (IWR.EQ.3 .AND. ISGN.NE.ISLAST) THEN
CALL SBIT1(MASK2,IWR)
ELSEIF (IWR.NE.3 .AND. ISGN.EQ.ISLAST) THEN
CALL SBIT1(MASK2,IWR)
ENDIF
ICELL = IC
ISLAST = ISGN
* Corrected drift distance
DD(IWR) = RBTAB(INDLC(II),3+ISGN+3*II,JDIG)
IF (MOD(NEVENT,10).EQ.0) THEN
IF (II.EQ.1) THEN
CALL SHS(77,0,DD(IWR)*(-1)**ISGN)
ELSEIF (WMES(2,JPL).GT.30. .AND. WMES(2,JPL).LT.40.) THEN
CALL SHS(78,0,DD(IWR)*(-1)**ISGN)
ENDIF
DUNC = RBTAB(INDLC(II),2,JDIG)
IF (DUNC.LT.0.5) CALL SHS(82+II,0,SNGL(RSMT(1,JPL)))
ENDIF
* Absolute drift coordinate
WW(IWR) = WMES(1,JPL)
* Checksums (4 wire groups)
IF (IWR.EQ.4) THEN
C2W = 0.75*(WW(3) - WW(2)) - 0.25*(WW(4) - WW(1))
IF (WW(4).LT.WW(1)) C2W = -C2W
IF (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)
IF (MASK2.EQ.15) CALL SHS(86+II,0,C2W)
ENDIF
IF (MASK.EQ.15) THEN
IF (II.EQ.2) THEN
RR = SQRT(SSMT(1,JPL)**2 + SSMT(2,JPL)**2)
WW(3) = SIGN((RR - WW(3)**2/RR)*SPHIW -
& ABS(WW(3))*CPHIW,-WW(3))
RR = SQRT(SSMT(1,JPL-1)**2 + SSMT(2,JPL-1)**2)
WW(4) = SIGN((RR - WW(4)**2/RR)*SPHIW -
& ABS(WW(4))*CPHIW,-WW(4))
C2W = 0.75*(WW(3) - WW(2)) - 0.25*(WW(4) - WW(1))
IF (WW(4).LT.WW(1)) C2W = -C2W
ENDIF
CALL SHS(88+II,0,C2W)
ENDIF
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))
ENDIF
ENDIF
IF (MOD(JPL,4).EQ.0) THEN
IPREV = 0
MASK = 0
MASK2 = 0
ENDIF
100 CONTINUE
RETURN
END
*