*FILE MEMBER=NEWMUR LIBRARY=PRIVATE LANGUAGE=FORTRAN77 DATE=04-APR-1991 PROGRAM BINGO CALL SOUDAN STOP END *ENDFILE MEMBER=NEWMUR *FILE MEMBER=USER LIBRARY=PROCESS LANGUAGE=FORTRAN77 DATE=01-Feb-1989 SUBROUTINE USER (LEVEL,NEXT) C c this soap looks over the surf bank to try and detect errors c pmb 6/22/94 c INCLUDE '(BCS)' INCLUDE '(TITLES)' COMMON/SRFSTUFF/ 1 ICRUN,ICEVT,IDATE,IWWVB,NMURAW,NMUS2,NMUSH, 2 NPAIR,NWORDS,NADDRS,NBX,ND0,ICUT,NEOTS,NHOT, 3 ISHWR, IT0OFF, ISHOFF, MAXADJ, NHITT, 4 NSING, NLAP, NTRACK, 5 NGROUP, IWIDTH, XAVG, ZAVG, DAV, ASLOPE, 6 CSLOPE, CINT, ERROR, SRFPRP, EFF CHARACTER*(*) LEVEL CHARACTER*6 NEXT INTEGER NLINK,IPHEAD,RC,ICYCLE,IX,IY INTEGER LBVDB2,LPVDB2,IPATLN,IPCTLN,IPSFIL,IPADJC INTEGER IPSHLA ,NAMIND,NATLN,NCTLN C INTEGER IRUN,IEVT,ITIME,IDATE INTEGER NGROUP_IT,NGROUP_OOT,NMU REAL*8 JDAY,UT REAL*4 RA,DEC,AATLN,ACTLN,CCTLN,CATLN REAL*4 XSURF,YSURF,RSURF C REAL*4 CONTENTS(90,90) REAL*4 IOK CHARACTER*60 FILENAME CHARACTER*20 FILE1 CHARACTER*4 FILE2 CHARACTER*5 CTEMP INTEGER IPMMUS,IPMMU,IMSEARCH,IPSEARCH,IAHIST,ICHIST DATA LBVDB2/0/ c IF(LEVEL.EQ.'PGMINI')THEN OPEN(UNIT=14,FORM= 1 'UNFORMATTED',RECL=1024,ACCESS='DIRECT', 2 STATUS='NEW') CALL HOUTPU(26) CALL HRFILE(14,'ASTRO','N') CALL HBOOK1(200,' hit tubes',256,0.0,256.0,0.0) CALL HBOOK1(201,' hit times',128,0.0,128.0,0.0) CALL HBOOK1(300,' GR+TR all evts',100,0.0,100.0,0.0) CALL HBOOK1(301,' NMU S2 ALL EVTS',100,0.0,100.0,0.0) CALL HBOOK1(302,' NMU SH ALL EVTS',100,0.0,100.0,0.0) call hbook1(400,' GR+TR Cer evts',100,0.0,100.0,0.0) call hbook1(401,' nmu S2 Cer evts ',100,0.0,100.0,0.0) call hbook1(402,' nmu SH Cer evts ',100,0.0,100.0,0.0) ENDIF c IF(LEVEL.EQ.'EVREAD')THEN IPHEAD=NLINK('HEAD',1) IRUN=IBOS(IPHEAD+1) IEVT=IBOS(IPHEAD+2) IDATE=IBOS(IPHEAD+3) ITIME=IBOS(IPHEAD+4) c c find right spot in .srf files FILE1='DBDISK:[RUNS.SRF]RUN' FILE2='.SRF' WRITE(CTEMP,600)IRUN 600 FORMAT(I5) FILENAME=FILE1//CTEMP//FILE2 LUNSRF=33 ! guess OPEN(FILE=FILENAME,UNIT=LUNSRF,FORM= 1 'UNFORMATTED',STATUS='OLD',ERR=610) GOTO 620 610 WRITE(26,630)FILENAME 630 FORMAT(' cant open ',a,' skip it ') NEXT='EVREAD' RETURN c C C now find the right event 620 READ (LUNSRF,ERR=680) 1 ICRUN,ICEVT,IDATE,IWWVB,NMURAW,NMUS2,NMUSH, 2 NPAIR,NWORDS,NADDRS,NBX,ND0,ICUT,NEOTS,NHOT, 3 ISHWR, IT0OFF, ISHOFF, MAXADJ, NHITT, 4 NSING, NLAP, NTRACK, 5 NGROUP, IWIDTH, XAVG, ZAVG, DAV, ASLOPE, 6 CSLOPE, CINT, ERROR, SRFPRP, EFF CALL HFILL(300,FLOAT(NGROUP+NTRACK),0.0,1.0) CALL HFILL(301,FLOAT(NMUS2),0.0,1.0) CALL HFILL(302,FLOAT(NMUSH),0.0,1.0) IF(ICEVT.LT.IEVT) GOTO 620 IF(ICEVT.GT.IEVT)GOTO 650 CALL HFILL(400,FLOAT(NGROUP+NTRACK),0.0,1.0) CALL HFILL(401,FLOAT(NMUS2),0.0,1.0) CALL HFILL(402,FLOAT(NMUSH),0.0,1.0) CALL SURF(IRUN,IEVT) close(lunsrf) ENDIF GOTO 670 650 WRITE(26,660)ICRUN,IEVT 660 FORMAT(' CANT FIND RUN EVT ',2I7,' IN .SRF FILE') NEXT='EVREAD' RETURN 680 WRITE(26,690)ICRUN,IEVT,FILENAME 690 FORMAT(' ERROR LOOKING FOR ',2I10,A) NEXT='EVREAD' RETURN 670 CONTINUE c IF(LEVEL.EQ.'PGMEND')THEN call hprint(200) CALL HPRINT(201) CALL HPRINT(300) CALL HPRINT(301) CALL HPRINT(302) CALL HPRINT(400) CALL HPRINT(401) CALL HPRINT(402) C c c write to histogram file? doesnt work c CALL HROUT(0,ICYCLE,' ') CALL HREND('ASTRO') c ENDIF RETURN END SUBROUTINE SURF(IRUN,IEVT) INCLUDE '(BCS)' C************************************************************************ c* * C surf shack digester routine * c* * c************************************************************************ REAL*4 AATLN,ACTLN,CCTLN,CATLN COMMON/SRFSTUFF/ 1 ICRUN_S,ICEVT_S,IDATE_S,IWWVB_S, 1 NMURAW_S,NMUS2_S,NMUSH_S, 2 NPAIR_S,NWORDS_S,NADDRS_S,NBX_S, 2 ND0_S,ICUT_S,NEOTS_S,NHOT_S, 3 ISHWR_S, IT0OFF_S, ISHOFF_S, 3 MAXADJ_S, NHITT_S, 4 NSING_S, NLAP_S, NTRACK_S, 5 NGROUP_S, IWIDTH_S, XAVG_S, 5 ZAVG_S, DAV_S, ASLOPE_S, 6 CSLOPE_S, CINT_S, ERROR_S, SRFPRP_S, EFF_S COMMON/MUPARAM/ACTLN,CCTLN,AATLN,CATLN LOGICAL LHIT(0:128,0:255) INTEGER IRUN,IEVT,ITIME,IDATE INTEGER NGROUP_IT,NGROUP_OOT,NMU INTEGER I_SRFH_HITS,IPSRFH,IHIT,JHIT INTEGER NLMULT1 LOGICAL HIT(0:127,0:7,0:31) INTEGER NSING(0:127) INTEGER NTRACK(0:127),NLAP(0:127),NGROUP(0:127) C.. Set up the channel software decoding: .................................... INTEGER ICHAN(0:31) data ichan/27,28,29,31,26,25,24,23,19,20,21,22,18,17,16,15, 1 12,13,14,30,11,10, 9, 8, 4, 5, 6, 7, 3, 2, 1, 0/ REAL*4 XADDR,XTRANSF,XNULLBYTE,XEOTBYTE,XHIT REAL*8 JDAY,UT REAL*4 XSURF,YSURF,RSURF C REAL*4 X2_SURF,Y2_SURF,R2_SURF,Z2_SURF,HEIGHT REAL*4 IOK REAL*8 FASE,BX,BY,BZ,AX,AY,AZ,ALENGTH,AXB(4) DATA HEIGHT/714 00./ DATA X_SS/-150 00./ DATA Y_SS/-72 00./ c c decode SURF bank ala Nat c C.. Get the number of words. The first and last two are header info: ......... DO IJKL=0,127 NGROUP(IJKL)=0 NSING(IJKL)=0 NLAP(IJKL)=0 NTRACK(IJKL)=0 DO JKLI=0,7 DO KLIJ=0,31 HIT(IJKL,JKLI,KLIJ)=.FALSE. LIJK=JKLI*32+KLIJ LHIT(IJKL,LIJK)=.FALSE. ENDDO ENDDO ENDDO IPSURF=NLINK('SURF',1) Ipointer = IPsurf Nwords = IBOS(Ipointer) Ipointer = Ipointer + 2 nhits=0 C------------------------------------------------------------------------------ C.. Each set contains three bytes: HI_ADD, LO_ADD, and DATA. Start ......... C.. processing with the first HI_ADD, and call new words when necessary: .... C------------------------------------------------------------------------------ C.. Decode the data. ......................................................... do 500 while (Ipointer.lt.IPsurf+Nwords-4) C C.. HI_ADD: 1 EOT A8 A7 A6 A5 A4 A3 ......................................... IA8_A3 = IAND(Jbyte,'3F'X) call get_byte(Ipointer,Ibyte,Jbyte,IEOT,IEOTs) C C.. LO_ADD: 0 A2 A1 A0 N2 N1 N0 D7 ......................................... IA2 = ISHFT(IAND(Jbyte,'40'X),-6) Iaddr = ISHFT(IA8_A3,+1) + iA2 Igroup = ISHFT(IAND(Jbyte,'30'X),-4) Icard = ISHFT(IAND(Jbyte,'0E'X),-1) ID7 = IAND(Jbyte,'01'X) call get_byte(Ipointer,Ibyte,Jbyte,IEOT,IEOTs) C C.. DATA: 0 D6 D5 D4 D3 D2 D1 D0 ......................................... ID6_D0 = IAND(Jbyte,'7F'X) Istatus = ISHFT(ID7,+7) + ID6_D0 call get_byte(Ipointer,Ibyte,Jbyte,IEOT,IEOTs) C C.. Insist that the next byte is a HI_ADD; skip hit storage if not: .......... if (IAND(Jbyte,'80'X).eq.0) then miss_byte = miss_byte + 1 c write (26,15)iaddr,icard,ichan(n),icard*32+ichan(n),jbyte 15 format(' lost hit at addr,card,chan,card*32+chan',4i10,z2) c write(26,7) 7 format(' missed next hi_add byte') do while (IAND(Jbyte,'80'X).eq.0.AND.Ipointer.lt.IPsurf+Nwords-4) call get_byte(Ipointer,Ibyte,Jbyte,IEOT,IEOTs) c write(26,8)jbyte 8 format(' next byte is ',z2) end do goto 500 end if C C.. Store hit: .............................................................. do i = 0, 7 n = Igroup*8 + i if (IAND(2**i,istatus).gt.0) then if(icard*32+ichan(n).ne.158)then c write (26,5)iaddr,icard,ichan(n),icard*32+ichan(n) 5 format(' raw hit addr,card,chan,card*32+chan',4i10) hit(Iaddr,Icard,Ichan(n)) = .TRUE. LHIT(IADDR,ICARD*32+ICHAN(N))=.TRUE. CALL HFILL(200,FLOAT(ICARD*32+ICHAN(N)),0.0,1.0) CALL HFILL(201,FLOAT(IADDR),0.0,1.0) nhits=nhits+1 xhit2=icard*32+ichan(n) endif end if end do 500 CONTINUE C.. Record the trigger time: ................................................. Itrigger = Iaddr IT0surf = Itrigger c write(26,6)itrigger 6 format( 'SURF last ss address= ',i10) c c this form mmusrf.for, which is where nat counts groups,etc CALL GROUP_COUNT(LHIT,NGROUP,NLAP,NSING,NTRACK) C C PRINT EVERYTHING C IN_TIME=0 IN_SIZE=0 IF(JPIC.LT.20)THEN JPIC=JPIC+1 WRITE(26,1003)IRUN,IEVT,I_SHOWER,N_SHOWER,IHITS, 1 MAX_TIME,IWIDTH,ILAPS,ISINGLES, 1 IGROUPS,ITRACKS,LEADEDGE,ILAPS+ITRACKS,HIT_CORR, 1 NLMULT1,NLMULT2,RSURF,KTIME, 2 NHITS,I_SRFH_HITS,XSURF,YSURF,ZENITH, 1 MOD(127+ISURF_TIME-IT0SURF-1,128), 1 IT0SURF,IT0OFF_S,ISHOFF_S, 1 NSING_S,NLAP_S,NTRACK_S,NGROUP_S, 3 (NGROUP(I),I=0,127), 1 (NSING (I),I=0,127), 4 (NLAP (I),I=0,127), 5 (NTRACK(I),I=0,127) 1003 FORMAT(/,' runevent ',2i8,' shower ',i4,' of ',i4, 1 /,' SRFH hits in shower =',I4,' maxt=',i4,' width=',i4, 1 /,' laps=',i4,' singles=',i4, 1 ' groups=',i4,' tracks=',i4,' leading time=',i4, 1 /,' NL total= ',i4,' NL Corr=',f10.1,' NL mult1= ',i5, 1 ' NL mult2=',i5,' dist from ss= ',f10.2,' cm time-t0=',i10, 1 /,' SURF hits',i10,' SRFH hits ',i10, 1 ' NL xy ',2f10.1,' zenith=',f5.1,' GRTIME= ',I6, 1 ' surf t0=',i4,/,' data from .srf t0,sing,lap,tr,gr ', 1 2i10,4i5, 1 /,' GROUPS t is addr-t0',/,4(32(1X,I2),/) 1 /,' SINGLES ',/,4(32(1X,I2),/) 1 /,' LAPS ',/,4(32(1X,I2),/) 1 /,' TRACKS ',/,4(32(1X,I2),/)) CALL I2PICTURE(HIT,It0surf-3,0) ENDIF IOK=0.0 C C RETURN END subroutine GET_BYTE(pointer,Ibyte,byte,EOT,EOTs) C============================================================================== C= This subroutine reads a 32-bit word and chops it into four 8-bit = C= bytes, flipping the upper and lower 16-bit words to account for the = C= Jorway format. It also checks for an EOT bit. = C= = C= Nat Longley 1 February 1991 Author = C============================================================================== IMPLICIT INTEGER (A-Z) INCLUDE '(BCS)' LOGICAL EOT EOT = .FALSE. Ibyte = Ibyte - 1 if (Ibyte.lt.0) then pointer = pointer + 1 word = IBOS(pointer) Ibyte = 3 end if C.. The four-byte word is read as b1-b0-b3-b2, so: if (Ibyte.eq.3) byte = ISHFT(IAND(word, 'FF00'X),- 8) if (Ibyte.eq.2) byte = IAND(word, 'FF'X) if (Ibyte.eq.1) byte = ISHFT(IAND(word,'FF000000'X),-24) if (Ibyte.eq.0) byte = ISHFT(IAND(word, 'FF0000'X),-16) C.. Check for EOT: if (IAND(byte,'C0'X).eq.'C0'X) then EOT = .TRUE. EOTs = EOTs + 1 end if return end SUBROUTINE I2PICTURE(HIT,ADDR,T0SURF) C C This subroutine draws a picture of the C surface detector for the time slices C ADDR-1 to ADDR+4 PMB,6/8/91 C IMPLICIT INTEGER (A-Z) C INCLUDE '(BCS)' INCLUDE '(TITLES)' INCLUDE '(CEPGCW)' INCLUDE '(CBANKP)' C LOGICAL HIT(0:127,0:7,0:31) CHARACTER*132 LINEUP,LINEDN CHARACTER*1 ONE C LUN=26 TIME = MOD(127+ADDR-T0SURF,128) WRITE(LUN,90)T0SURF 90 FORMAT(' Times are addresses-T0SURF (',i4' )') DO 100 IADDR=ADDR-2,ADDR+10 JADDR=MOD(IADDR+128,128) TIME = MOD(127+JADDR-T0SURF,128) C C write surf time to first 4 spaces WRITE(LINEUP,20)TIME WRITE(LINEDN,20)TIME 20 FORMAT(1X,I3,128X) c c do top tubes first ICOUNT=5 DO 110 ICARD=0,7 IF(ICARD.EQ.4)ICOUNT=ICOUNT+2 DO 120 ICHAN=0,28,2 IF(HIT(JADDR,ICARD,ICHAN))THEN ONE='X' ELSE ONE='-' ENDIF LINEUP(ICOUNT:ICOUNT)=ONE ICOUNT=ICOUNT+1 120 CONTINUE 110 CONTINUE WRITE(LUN,30)LINEUP 30 FORMAT(A) c c now do the bottom tubes ICOUNT=5 DO 130 ICARD=0,7 IF(ICARD.EQ.4)ICOUNT=ICOUNT+2 DO 140 ICHAN=1,29,2 IF(HIT(JADDR,ICARD,ICHAN))THEN ONE='X' ELSE ONE='-' ENDIF LINEDN(ICOUNT:ICOUNT)=ONE ICOUNT=ICOUNT+1 140 CONTINUE 130 CONTINUE WRITE(LUN,40)LINEDN 40 FORMAT(A,/) 100 CONTINUE RETURN END SUBROUTINE HITHIT(HIT,ICLUMPY,ICLUMPY_TIME) C C this calculates the hit-hit distances of all pairs c and books them in histos 110,111 c LOGICAL HIT(0:127,0:7,0:31) LOGICAL HIT2(0:127,0:7,0:31) DATA ITUBEWIN/6/ ! window width for clumpiness test- ! this number must be even C C first ditch any hits that are not at least 2 usec long C DO 1 ITIME=0,126 DO 2 ICARD=0,7 DO 3 ICHAN=0,31 IF(HIT(ITIME,ICARD,ICHAN).AND. 1 HIT(ITIME+1,ICARD,ICHAN))THEN HIT2(ITIME,ICARD,ICHAN)=.TRUE. ELSE HIT2(ITIME,ICARD,ICHAN)=.FALSE. ENDIF 3 CONTINUE 2 CONTINUE 1 CONTINUE C C do last time separately DO 4 ICARD=0,7 DO 5 ICHAN=0,31 IF(HIT(127,ICARD,ICHAN).AND.HIT(0,ICARD,ICHAN))THEN HIT2(127,ICARD,ICHAN)=.TRUE. ELSE HIT2(127,ICARD,ICHAN)=.FALSE. ENDIF 5 CONTINUE 4 CONTINUE C C now look thru all the hits; for each hit cc find distance from it to the other hits on the c same side of the array- do it separately for c even ( top layer ) and odd ( bottom layer ) of tubes c C also count max hits in a 10-tube window c MAXHIT =0 ICLUMPY_TIME=-999 DO 10 ITIME=0,127 c do one side at a time DO 20 ICARD=0,3 DO 30 ICHAN=0,30 C find a hit IF(.NOT.HIT2(ITIME,ICARD,ICHAN))GOTO 30 C find distance to all other hits on same side of the array DO 40 JCARD=0,3 DO 50 JCHAN=0,30 IF(.NOT.HIT2(ITIME,JCARD,JCHAN))GOTO 50 IDIST=(ICARD-JCARD)*15+(ICHAN-JCHAN)/2 C C only book if greater than 0 to avoid double counts IF(IDIST.GT.0)THEN ENDIF 50 CONTINUE 40 CONTINUE c c find number of hits in 10-tube window NWINDOW=0 DO 60 KCHAN2=ICHAN-ITUBEWIN,ICHAN+ITUBEWIN KCHAN=KCHAN2 KCARD=ICARD C check for allowed card; dont go into nnext side IF(KCHAN.LT.0)THEN KCHAN=KCHAN+32 KCARD=KCARD-1 ELSE IF ( KCHAN.GT.31)THEN KCHAN=KCHAN-32 KCARD=KCARD+1 ENDIF IF(KCARD.LT.0.OR.KCARD.GT.3)GOTO 60 IF(HIT(ITIME,KCARD,KCHAN))NWINDOW=NWINDOW+1 60 CONTINUE IF(NWINDOW.GT.MAXHIT)THEN MAXHIT=NWINDOW ICLUMPY_TIME=ITIME ENDIF C C histogram where they happened- note this will histo a c big clump several times IF(NWINDOW.EQ.3)THEN NUMBER=ICARD*32+ICHAN ENDIF IF(NWINDOW.GE.4)THEN NUMBER=ICARD*32+ICHAN ENDIF 30 CONTINUE 20 CONTINUE c c now do other side c DO 220 ICARD=4,7 DO 230 ICHAN=1,30 C find a hit IF(.NOT.HIT2(ITIME,ICARD,ICHAN))GOTO 230 C find its neighbors DO 240 JCARD=4,7 DO 250 JCHAN=1,30 IF(.NOT.HIT2(ITIME,JCARD,JCHAN))GOTO 250 IDIST=(ICARD-JCARD)*15+(ICHAN-JCHAN)/2 C C only book if greater than 0 to avoid double counts IF(IDIST.GT.0)THEN ENDIF 250 CONTINUE 240 CONTINUE c c find number of hits in 10-tube window NWINDOW=0 DO 260 KCHAN2=ICHAN-ITUBEWIN,ICHAN+ITUBEWIN KCHAN=KCHAN2 KCARD=ICARD C check for allowed card; dont go into nnext side IF(KCHAN.LT.0)THEN KCHAN=KCHAN+32 KCARD=KCARD-1 ELSE IF ( KCHAN.GT.31)THEN KCHAN=KCHAN-32 KCARD=KCARD+1 ENDIF IF(KCARD.LT.4.OR.KCARD.GT.7)GOTO 260 IF(HIT(ITIME,KCARD,KCHAN))NWINDOW=NWINDOW+1 260 CONTINUE IF(NWINDOW.GT.MAXHIT)THEN MAXHIT=NWINDOW ICLUMPY_TIME=ITIME ENDIF c c fill hot channel histo IF(NWINDOW.EQ.3)THEN NUMBER=ICARD*32+ICHAN ENDIF IF(NWINDOW.GE.4)THEN NUMBER=ICARD*32+ICHAN ENDIF 230 CONTINUE 220 CONTINUE 320 CONTINUE 10 continue c ICLUMPY=MAXHIT RETURN END SUBROUTINE HITHIT2(HIT,LOOK_TIME,IWIDTH,N_CLUMP,N_LOOSE) C C this rascal looks through the hit array and returns the c number of hits in clumps at time leadedge and loose c PMB 8/22/94 c LOGICAL HIT(0:127,0:7,0:31) LOGICAL HIT2(0:127,0:7,0:31) DATA IWINDOW/4/ ! window width for clumpiness test- ! this number must be even C C first ditch any hits that are not at least 2 usec long C DO 1 ITIME=0,126 DO 2 ICARD=0,7 DO 3 ICHAN=0,31 IF(HIT(ITIME,ICARD,ICHAN).AND. 1 HIT(ITIME+1,ICARD,ICHAN))THEN HIT2(ITIME,ICARD,ICHAN)=.TRUE. ELSE HIT2(ITIME,ICARD,ICHAN)=.FALSE. ENDIF 3 CONTINUE 2 CONTINUE 1 CONTINUE C C do last time separately DO 4 ICARD=0,7 DO 5 ICHAN=0,31 IF(HIT(127,ICARD,ICHAN).AND.HIT(0,ICARD,ICHAN))THEN HIT2(127,ICARD,ICHAN)=.TRUE. ELSE HIT2(127,ICARD,ICHAN)=.FALSE. ENDIF 5 CONTINUE 4 CONTINUE N_CLUMP=0 N_LOOSE=0 c c look at times around the shower time DO 200 LTIME=-1,IWIDTH KTIME=MOD(LOOK_TIME+1,128)+LTIME DO 20 ICARD=0,3 DO 30 ICHAN=0,31 IF(.NOT.HIT2(KTIME,ICARD,ICHAN))GOTO 30 ISUM=0 DO 40 KCHAN=ICHAN-IWINDOW,ICHAN+IWINDOW JCHAN=KCHAN JCARD=ICARD IF(JCHAN.LT.0)THEN JCARD=JCARD-1 JCHAN=JCHAN+31 ENDIF IF(JCHAN.GT.31)THEN JCARD=JCARD+1 JCHAN=JCHAN-31 ENDIF IF(JCARD.LT.0.OR.JCARD.GT.3)GOTO 40 IF(HIT2(KTIME,JCARD,JCHAN))ISUM=ISUM+1 40 CONTINUE IF(ISUM.GE.4)N_CLUMP=N_CLUMP+1 IF(ISUM.LT.4)N_LOOSE=N_LOOSE+1 30 continue 20 CONTINUE C C do other side DO 120 ICARD=4,7 DO 130 ICHAN=0,31 IF(.NOT.HIT2(KTIME,ICARD,ICHAN))GOTO 130 ISUM=0 DO 140 KCHAN=ICHAN-IWINDOW,ICHAN+IWINDOW JCHAN=KCHAN JCARD=ICARD IF(JCHAN.LT.0)THEN JCARD=JCARD-1 JCHAN=JCHAN+31 ENDIF IF(JCHAN.GT.31)THEN JCARD=JCARD+1 JCHAN=JCHAN-31 ENDIF IF(JCARD.LT.4.OR.JCARD.GT.7)GOTO 140 IF(HIT2(KTIME,JCARD,JCHAN))ISUM=ISUM+1 140 CONTINUE IF(ISUM.GE.4)N_CLUMP=N_CLUMP+1 IF(ISUM.LT.4)N_LOOSE=N_LOOSE+1 130 continue 120 CONTINUE 200 CONTINUE RETURN END SUBROUTINE STAT_CORR(IHITS,NTUBE,HIT_CORR) C C do stat correction for ihits into ntube TEMP=1.0-FLOAT(IHITS)/FLOAT(NTUBE) IF(TEMP.GT.0.0)THEN HIT_CORR=-NTUBE/(2*0.82)*ALOG(temp) ELSE HIT_CORR=NTUBE ENDIF RETURN END SUBROUTINE GROUP_COUNT(LHIT,NGROUP,NLAP,NSINGLE,NTRACK) C C takes array of hits and counts groups/tracks/laps/etc LOGICAL LHIT(0:128,0:255),LGROUP(0:255) INTEGER NSING(0:127) INTEGER NTRACK(0:127),NLAP(0:127),NGROUP(0:127) LOGICAL LHOT(0:127),LGRPCK INTEGER NHITT(0:127) DO ITIME=0,128 DO ICHAN=0,255 IF (.NOT.LHOT(ICHAN)) THEN ITIME1 = MAX(ITIME-1, 0) ITIME2 = MIN(ITIME+1,127) IF (.NOT.LHIT(ITIME1,ICHAN)) NHITT(ITIME1)=NHITT(ITIME1)+1 IF (.NOT.LHIT(ITIME ,ICHAN)) NHITT(ITIME )=NHITT(ITIME )+1 IF (.NOT.LHIT(ITIME2,ICHAN)) NHITT(ITIME2)=NHITT(ITIME2)+1 LHIT (ITIME1,ICHAN) = .TRUE. LHIT (ITIME ,ICHAN) = .TRUE. LHIT (ITIME2,ICHAN) = .TRUE. END IF ENDDO ENDDO C.. Find and store number of loud channels: DO 1700 ICHAN = 0, 255 IF (LHOT(ICHAN)) NHOT = NHOT + 1 1700 CONTINUE C------------------------------------------------------------------------------ C.. Hit patterns: C.. Single: A hit in one layer (does not overlap any other hit). C.. Track: Overlapping singles, separate in either layer from other tracks. C.. Group: Adjacent tracks and singles (can contain more than one track). C.. Lap: Adjacent singles which are not part of a group (one layer only). C.. C.. Cycle time, channels (15 channels/preamp). Reset flags when moving from C.. south to north panel. Skip time slices below threshold. DO 5000 ITIME = 0, 127 IF (NHITT(ITIME).LT.2*MINGRP) GOTO 5000 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C.. Identify the group nuclei (consecutive hit tubes): DO 2320 IAMP = 0, 15 IF (MOD(IAMP,8).EQ.0) LGRPCK = .FALSE. DO 2310 I = 0, 14 ICHAN = IAMP*16 + I LGROUP(ICHAN) = (LHIT(ITIME,ICHAN).AND.LGRPCK) LGRPCK = LHIT(ITIME,ICHAN) 2310 CONTINUE 2320 CONTINUE C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C.. Check each hit to see if it is part of a group: DO 3320 IAMP = 0, 15 DO 3310 I = 0, 14 ICHAN = IAMP*16 + I IF (LHIT(ITIME,ICHAN)) THEN C.. Search forward for a group nucleus: J = I IAMP1 = IAMP ICHAN1 = ICHAN LGRPCK = .TRUE. 2500 IF (ICHAN1.EQ.254.OR.ICHAN1.EQ.126) GOTO 2600 J = MOD(J+1,15) IF (J.EQ.0) IAMP1 = MOD(IAMP1+1,16) ICHAN1 = IAMP1*16 + J IF (LGROUP(ICHAN1)) LGROUP(ICHAN) = .TRUE. IF (.NOT.(LHIT(ITIME,ICHAN1).OR.LGRPCK)) GOTO 2600 LGRPCK = LHIT(ITIME,ICHAN1) GOTO 2500 2600 CONTINUE C.. Search backward for a group nucleus: J = I IAMP1 = IAMP ICHAN1 = ICHAN LGRPCK = .TRUE. 2700 IF (ICHAN1.EQ.0.OR.ICHAN1.EQ.128) GOTO 2800 J = MOD(J+14,15) IF (J.EQ.14) IAMP1 = MOD(IAMP1+15,16) ICHAN1 = IAMP1*16 + J IF (LGROUP(ICHAN1)) LGROUP(ICHAN) = .TRUE. IF (.NOT.(LHIT(ITIME,ICHAN1).OR.LGRPCK)) GOTO 2800 LGRPCK = LHIT(ITIME,ICHAN1) GOTO 2700 2800 CONTINUE END IF 3310 CONTINUE 3320 CONTINUE C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C.. Now count singles, laps, tracks, and groups. Reset counters each new side: DO 4320 IAMP = 0, 15 IF (MOD(IAMP,8).EQ.0) THEN ICHAN1 = 255 ICHAN2 = 255 END IF DO 4310 I = 0, 14 ICHAN = IAMP*16 + I IF (LGROUP(ICHAN).AND..NOT.LGROUP(ICHAN2)) THEN IF (LGROUP(ICHAN1)) NTRACK(ITIME) = NTRACK(ITIME) + 1 IF (.NOT.LGROUP(ICHAN1)) NGROUP(ITIME) = 1 NGROUP(ITIME) + 1 END IF IF (LHIT(ITIME,ICHAN).AND..NOT.LGROUP(ICHAN)) THEN NSING(ITIME) = NSING(ITIME) + 1 IF (.NOT.LHIT(ITIME,ICHAN2)) NLAP(ITIME) = 1 NLAP(ITIME) + 1 END IF ICHAN2 = ICHAN1 ICHAN1 = ICHAN 4310 CONTINUE 4320 CONTINUE 5000 CONTINUE RETURN END