SUBROUTINE DROPB C C This routine drops all the banks except the UTC TDC banks. C C The parameters are: C PARAM(1): If .eq.1, then remake the UTRT bank, dropping all foil C hits. C PARAM(2): If .eq.1, then remake the UTRT bank, keeping only C the first hit on a wire or strip C PARAM(3): If .eq.1, then remake the UTRT bank, dropping all C trailing edge information C PARAM(4): If the number of hit wires is more than this number, C drop the event C PARAM(5): If .eq.1, fit the tracks and do multi-skimming based C on the dip angle of the track. C C History: C 20-May-1994 (GR) Birth of code C 31-May-1994 (GR) Added PARAMs 1,2 and 3. C 10-Jun-1994 (GR) Added PARAM(4) C 09-Jan-1995 (GR) Updated for 15-Jun-94 modification to read_utc_tdcmap C 09-Dec-1997 (GR) Implemented multiskimming based on dip angle. C 14-Jan-1999 (GR) Fixed a bug with the pointers that showed up C in 1998 data because we had a TDC in slot5 C which did not contain UTC data. C-- Global declarations $$IMPLICIT $$INCLUDE 'KOFIA$INCLUDE:FAIL.PAR' $$INCLUDE 'KOFIA$INCLUDE:DC_TRACK.PAR' $$INCLUDE 'KOFIA$INCLUDE:BCS.INC' $$INCLUDE 'KOFIA$INCLUDE:INFO.CMN' $$INCLUDE 'KOFIA$INCLUDE:LUNS.CMN' $$INCLUDE 'KOFIA$INCLUDE:HCUTS.CMN' $$INCLUDE 'KOFIA$INCLUDE:CFAIL.CMN' $$INCLUDE 'KOFIA$INCLUDE:TDCMAP.PAR' $$INCLUDE 'YBOS$LIBRARY:ERRCOD.INC' $$INCLUDE 'YBOS$LIBRARY:BNKTYP.INC' $$INCLUDE 'KOFIA$INCLUDE:TDCMAP.CMN' $$INCLUDE 'KOFIA$INCLUDE:UTC_GEOM.CMN' $$INCLUDE 'KOFIA$INCLUDE:UTC_WIRES.CMN' $$INCLUDE 'KOFIA$INCLUDE:UTC_STRIPS.CMN' $$INCLUDE 'KOFIA$INCLUDE:SS_INDEX.CMN' $$INCLUDE 'KOFIA$INCLUDE:DC_TRACK.CMN' C-- Other local declarations LOGICAL*4 NOFOIL LOGICAL*4 FIRSTHIT LOGICAL*4 NOTRAIL LOGICAL*4 LEADEDGE LOGICAL*4 LFOIL,LWIRE LOGICAL*4 LGOOD INTEGER*4 IND INTEGER*4 ICRAP,IUTRT INTEGER*4 STATUS INTEGER*4 NHITPW(NWIRES_TOT),NHITPS(NSTRIP_TOT) INTEGER*4 LEN1,LEN2 INTEGER*4 I1,I2 INTEGER*4 IEND INTEGER*4 ISLOT INTEGER*4 NWORDS1,NWORDS2 INTEGER*4 INWORDS2 INTEGER*4 K INTEGER*4 DATA INTEGER*4 NUMSLOT,NUMCHAN,NADDRESS,NUMSLAY,NUMLAY,NUMCELL INTEGER*4 ISLAY,ILAY,ICELL,IFOIL INTEGER*4 ISTRIP,IWIRE INTEGER*4 INSLOT2 INTEGER*4 NHMAX,NWHPE INTEGER*4 ISKIM,ERROR REAL*4 COS3D LOGICAL*1 ERR LOGICAL*4 MULTI CHARACTER*80 MSG,MAP_FN C-- Functions INTEGER*4 BLOCAT,BDLEN,BMAKE,MDROP,BRENAM C-- Data statements SAVE C *********************************************** C Histogram definition and global initialization C *********************************************** ENTRY DEFINE IF(PARAM(1).EQ.1.0) THEN NOFOIL = .TRUE. ELSE NOFOIL = .FALSE. ENDIF IF(PARAM(2).EQ.1.0) THEN FIRSTHIT = .TRUE. ELSE FIRSTHIT = .FALSE. ENDIF IF(PARAM(3).EQ.1.0) THEN NOTRAIL = .TRUE. ELSE NOTRAIL = .FALSE. ENDIF IF(PARAM(4).NE.0.) THEN NHMAX = INT(PARAM(4)) ENDIF IF(PARAM(5).NE.0.) THEN MULTI = .TRUE. ELSE MULTI = .FALSE. ENDIF CALL UTC_SETUP RETURN C *************************************** C Event analysis C *************************************** ENTRY DPLOT C WRITE(*,*) 'Now analyzing event ',NEVT CALL BATCH_LOG C-- Initialize CALL VZERO(NHITPW,NWIRES_TOT) CALL VZERO(NHITPS,NSTRIP_TOT) ICFAIL = 0 C-- Do track fitting, if needed IF(MULTI) THEN CALL UTC_TRACK(.TRUE.,.TRUE.) ISKIM = 0 IF(NTRACK_D.EQ.1.AND.PZ_D(1).NE.0.) THEN COS3D = ABS(COS3_D(1)) ISKIM = INT(COS3D/0.1) + 1 ENDIF ENDIF C-- See if we want to remake the UTRT bank IF((.NOT.NOFOIL).AND.(.NOT.FIRSTHIT).AND. & (.NOT.NOTRAIL)) GO TO 666 STATUS = BLOCAT(IBANK,'UTRT',1,IND,IUTRT) IF(STATUS.NE.YESUCC) GO TO 666 STATUS = BDLEN(IBANK,IND,LEN1) IF(STATUS.NE.YESUCC) THEN CALL KERROR(-2,0,'DPLOT','Unable to get UTRT bank length') GO TO 666 ENDIF C-- Make a temporary bank for the shrunk version of UTRT STATUS = BMAKE(IBANK,'CRAP',1,LEN1,BNKTI4,IND,ICRAP) IF(STATUS.NE.YESUCC) THEN CALL KERROR(-2,0,'DPLOT','Error creating temporary bank') GO TO 666 ENDIF C-- Read TDC map file IF(.NOT.MULTI) THEN CALL READ_UTC_TDCMAP(I_UT,TDCMAP1,TDCOWN1,3,MAP_FN,ERR) IF(ERR) THEN CALL KERROR(-2,0,'DPLOT','Error reading TDC map file') GO TO 666 ENDIF ENDIF C-- Fill the temporary bank LEADEDGE = .FALSE. I1 = IUTRT IEND = IUTRT+LEN1-1 ! Pointer to the last data word I2 = ICRAP LEN2 = 0 IBANK(I2) = IBANK(I1) ! Event number DO WHILE (I1.LT.IEND) LEADEDGE = .NOT.LEADEDGE IF(LEADEDGE) THEN I1 = I1 + 1 ISLOT = IBANK(I1) INSLOT2 = I2+1 ! Pointer to slot number in new bank INWORDS2 = I2+2 ! Pointer to # words LGOOD = .FALSE. ELSE INWORDS2 = I2+1 IF(LGOOD) I2=I2+1 ENDIF I1 = I1 + 1 NWORDS1 = IBANK(I1) NWORDS2 = 0 C-- Check for consistency between NWORDS1 and the bank length IF(I1+NWORDS1.GT.IEND) THEN CALL KERROR(-2,0,'DPLOT', & 'Mismatch between UTRT bank length and contents') GO TO 666 ENDIF DO 2000 K=1,NWORDS1 I1 = I1+1 DATA = IBANK(I1) C-- Bits 27-31 = TDC slot number NUMSLOT = ISHFT(DATA,-27).AND.31 C-- Check for consistency between the slot number in bits 27-31 and C-- the slot number packed in the word before all the leading and C-- trailing edges IF(ISLOT.NE.NUMSLOT) THEN CALL KERROR(-3,0,'DPLOT', & ' Inconsistent slot numbering in UTRT bank') GO TO 666 ENDIF C-- Check that the slot number is within bounds IF(NUMSLOT.LT.1.OR.NUMSLOT.GT.NSLOT) THEN WRITE(MSG,400) NUMSLOT 400 FORMAT('TDC slot number ',I5,' is out of bounds') CALL KERROR(-3,0,'DPLOT',MSG) GO TO 666 ENDIF C-- Bits 16-22 = channel number NUMCHAN = ISHFT(DATA,-16).AND.127 C-- Check that the channel number is within bounds IF(NUMCHAN.GT.NCHANNEL-1) THEN WRITE(MSG,410) NUMCHAN,NUMSLOT 410 FORMAT('TDC channel ',I5,' out of bounds in slot ',I5) CALL KERROR(-3,0,'DPLOT',MSG) GO TO 666 ENDIF C-- Check that this channel is a UTC TDC NADDRESS = NUMSLOT*NCHANNEL + NUMCHAN + 1 IF(TDCOWN1(NADDRESS).NE.I_UT) GO TO 2000 C-- Convert to superlayer (1-2-3), layer (1-6) and cell NUMSLAY = TDCMAP1(NADDRESS,1) NUMLAY = TDCMAP1(NADDRESS,2) NUMCELL = TDCMAP1(NADDRESS,3) C-- "Offline" convention LFOIL = .FALSE. LWIRE = .FALSE. ISLAY = 2*NUMSLAY-1 IF(NUMLAY.EQ.1.OR.NUMLAY.EQ.6) THEN LFOIL = .TRUE. IFOIL = ISLAY IF(NUMLAY.EQ.6) IFOIL=IFOIL+1 ICELL = NUMCELL ELSE LWIRE = .TRUE. ILAY = NUMLAY-1 ICELL = NUMCELL ENDIF IF(LEADEDGE) THEN IF(LFOIL) THEN ISTRIP = ISTRIP_NUM(ICELL,IFOIL) NHITPS(ISTRIP) = NHITPS(ISTRIP)+1 ELSE IWIRE = IWIRE_NUM(ICELL,ILAY,ISLAY) NHITPW(IWIRE) = NHITPW(IWIRE)+1 ENDIF ENDIF C-- See if we want to keep this data word IF(NOFOIL.AND.LFOIL) GO TO 2000 IF(FIRSTHIT) THEN IF(LFOIL.AND.NHITPS(ISTRIP).GT.1) GO TO 2000 IF(LWIRE.AND.NHITPW(IWIRE).GT.1) GO TO 2000 ENDIF IF(NOTRAIL.AND.(.NOT.LEADEDGE)) GO TO 2000 IF((.NOT.LEADEDGE).AND.(.NOT.LGOOD)) GO TO 2000 C-- If we get here, then we keep the word. NWORDS2 = NWORDS2+1 C-- Copy the slot number now that we know there is some data that we C-- wish to keep from this module IF(NWORDS2.EQ.1) THEN IF(LEADEDGE) THEN IBANK(INSLOT2) = ISLOT LGOOD = .TRUE. ENDIF I2 = INWORDS2 ENDIF C-- Copy the data word I2 = I2+1 IBANK(I2) = DATA 2000 CONTINUE C-- Update number of kept data words from this module (but only if C-- we copied at least one leading edge time) IF(LGOOD) THEN IBANK(INWORDS2) = NWORDS2 ENDIF END DO C-- Reset the length of the temporary bank LEN2 = I2-ICRAP+1 STATUS = BMAKE(IBANK,'CRAP',1,LEN2,0,IND,ICRAP) IF(STATUS.NE.YESUCC) THEN CALL KERROR(-2,0,'DPLOT','Error resetting bank length') GO TO 666 ENDIF C-- Drop the old UTRT bank and rename the temporary bank STATUS = MDROP(IBANK,'UTRT',1) STATUS = BRENAM(IBANK,'CRAP',1,'UTRT',1) C-- Drop everything except the LRID, EVCL, trigger and UTC TDC banks 666 CONTINUE CALL BLIST(IBANK,'C=','LRIDEVCLTRIGTRI2UTRT') C-- Decide whether or not we keep this event NWHPE = 0 DO IWIRE=1,NWIRES_TOT IF(NHITPW(IWIRE).GE.1) NWHPE=NWHPE+1 END DO IF(NWHPE.GT.NHMAX) ICFAIL = 1 IF(MULTI) THEN CALL KMSKIM_BAR(0,ERROR) IF(ISKIM.NE.0) THEN CALL KMSKIM_OUT(ISKIM,ERROR) ELSE ICFAIL = 1 ENDIF ENDIF RETURN END