SUBROUTINE DEFINE IMPLICIT NONE REAL H INTEGER NWPAWC PARAMETER (NWPAWC = 3000000) COMMON/PAWC/H(NWPAWC) INTEGER i, bs CALL HLIMIT(NWPAWC) DO i = 0, 1 bs = 100*(1-i) CALL HBOOK1(bs+1,'STATISTICS', 20,0.5,20.5,0.0) CALL HBOOK1(bs+2,'ALL TRACKS',100,0.,500.,0.0) CALL HBOOK1(bs+3,'PEN.TRACKS',100,0.,500.,0.0) CALL HBOOK1(bs+10,'NTRK',11,-0.5,10.5,0.0) CALL HBOOK1(bs+11,'MAX.LAYER',19,0.5,19.5,0.0) CALL HBOOK1(bs+12,'T.2 SEC',24,0.5,24.5,0.0) CALL HBOOK1(bs+13,'T.2 SEC',24,0.5,24.5,0.0) CALL HBOOK1(bs+14,'TIME HITS',30,-0.5,29.5,0.0) CALL HBOOK1(bs+15,'TRK TIME ',50,0.0,50.0,0.0) CALL HBOOK1(bs+16,'TRK TIME-DS',100,-10.,10.,0.0) CALL HBOOK2(bs+17,'TRK TIME-DS',16,-5.0,3.0,24,0.5,24.5,0.0) ENDDO CALL HBOOK1(4, 'N DS',6,-0.5,5.5,0.0) CALL HBOOK1(5,'DS-BS RAW',140,-9.75,60.25,0.0) CALL HBOOK1(6,'N T.2 NEW', 20,0.5,20.5,0.0) CALL HBOOK1(7,'T.2 SEC',24,0.5,24.5,0.0) CALL HBOOK1(18,'N T.2 HARD',20,0.5,20.5,0.0) CALL HBOOK2(19,'CLASS 1',24,0.5,24.5,19,0.5,19.5,0.0) CALL HBOOK2(20,'CLASS 2',24,0.5,24.5,19,0.5,19.5,0.0) CALL HBOOK1(21,'FAULTS',100,42447.5,42547.5,0.0) CALL HBOOK1(22,'NEVNTS',100,42447.5,42547.5,0.0) CALL HBOOK1(25,'ST BACK',30,0.5,30.5,0.0) CALL HBOOK2(26,'CLASSES',2,-0.5,1.5,2,-4990.,5010.,0.0) CALL HBOOK2(27,'T.2vsT.2',4,0.5,4.5,5,-0.5,4.5,0.0) CALL HBOOK2(28,'IC vs T2',24,0.5,24.5,7,-0.5,6.5,0.0) DO i = 0, 4 CALL HBOOK2(30+i,'EFF',24,0.5,24.5,19,0.5,19.5,0.0) ENDDO RETURN END SUBROUTINE DPLOT IMPLICIT NONE #include #include #include #include #include #include #include #include #include INTEGER ia, i, j, n, bs, mode, isec, m2s, dse INTEGER is, il, is0, il0, mod0, modu, ihit, IUCOMP INTEGER IRUSES(21,24,0:1),jsec(0:1),jlay(0:1),nhts(0:1) INTEGER ITRKS(50,0:1) INTEGER TH(0:1) REAL TM(0:1), SG(0:1) REAL DS, PRNTDC INTEGER tdch(4), iflg LOGICAL ldump /.FALSE./ LOGICAL lasec /.TRUE./ SAVE ldump LOGICAL l1,l2 ICFAIL = 1 CALL HF1( 1, 1.0, 1.0) CALL HF1(101, 1.0, 1.0) CALL TDCUNP('TS','CAL',-200.,400.) CALL HF1(4, REAL(TSTHIT(2)), 1.0) IF(TSTHIT(2).NE.1) RETURN DS = TSTTDC(2,1) CALL HF1(5,DS-TSTTDC(1,1),1.0) CALL ADCUNP('IC','CAL') CALL ADCUNP('RD','CAL') CALL TDCUNP('TS','CAL',-1.e6,1.e6) c New T.2 (TDC) system n = 0 DO j = 1, 24 IF(TSTHIT(24+j).GT.0) THEN n = n + 1 CALL HF1(7, REAL(j), 1.0) ENDIF ENDDO CALL HF1(6, REAL(n), 1.0) CALL TR2UNP(0) CALL HF1( 1, 2.0, 1.0) CALL HF1(101, 2.0, 1.0) DO ia = 0, 1 bs = 100*(1-ia) CALL RD_TRK(ia) CALL HF1(bs+10, REAL(NTRK), 1.0) IF(NTRK.NE.1) GOTO 50 jsec(ia) = (ITRK(1,1)-1)/21+1 isec = jsec(ia) IF(.NOT.lasec.AND..NOT.(2.LE.isec.AND.isec.LE.12)) GOTO 50 CALL HF1(bs+12, REAL(isec), 1.0) CALL HF1(bs+1, 3.0, 1.0) CALL HF1(bs+2, ETRK(1), 1.) nhts(ia) = NHTRK(1) IF(ia.eq.0.AND.16.le.isec.and.isec.le.16) THEN c CALL DUMP_RDTRK(36) ENDIF C Find the last layer jlay(ia) = 0 DO i = 19, 1, -1 DO j = 1, 24 IF(IRUSE(i,j).NE.0) THEN CALL HF1(bs+11,REAL(i),1.0) jlay(ia) = i GOTO 10 ENDIF ENDDO ENDDO 10 CONTINUE c Hist. for penetrating tracks IF(jlay(ia).EQ.19) THEN CALL HF1(bs+3, ETRK(1), 1.) CALL HF1(bs+1, 4.0, 1.0) CALL HF1(bs+13, REAL(isec), 1.0) CALL TRKTIM_RD(1,0) CALL HF1(bs+14, REAL(NHITS_TM), 1.0) CALL HF1(bs+15, TIM_TM, 1.0) IF(EXT_CON(8).AND.ia.EQ.1) THEN CALL HF1(bs+16, TIM_TM-DS, 1.0) CALL HF2(bs+17, TIM_TM-DS, REAL(isec), 1.0) ENDIF IF(EXT_CON(9).AND.ia.EQ.0) THEN CALL HF1(bs+16, TIM_TM-DS, 1.0) CALL HF2(bs+17, TIM_TM-DS, REAL(isec), 1.0) ENDIF IF(ia.EQ.1) THEN n = 0 DO i = 1, 24 IF(RDCMB(1,1,i).GT.0.2.AND. + RDCMB(1,2,i).GT.1.0) THEN n = n + 1 DO j = 1, 6 IF(ICCAL(j,1).GT.0.2.AND.ICCAL(j,2).GT.0.2) THEN CALL HF2(28, REAL(i), REAL(j), 1.0) ENDIF ENDDO ENDIF ENDDO DO j = 8, 11 IF(EXT_CON(j)) THEN CALL HF1(18, REAL(j), 1.0) CALL HF2(27, REAL(j-7), REAL(n), 1.0) ENDIF ENDDO ENDIF ENDIF CALL UCOPY(IRUSE,IRUSES(1,1,ia),504) CALL UCOPY(ITRK(1,1),ITRKS(1,ia),nhts(ia)) 50 CONTINUE ENDDO ! Over ADC/TDC algorithm IF(jsec(0).NE.jsec(1)) STOP 'Err1' IF(.NOT.lasec.AND..NOT.(2.LE.isec.AND.isec.LE.12)) RETURN C Check respective effic. IF(jlay(0).GT.0) THEN CALL HF1(1, 10., 1.0) IF(jlay(1).EQ.jlay(0)) THEN CALL HF1(1, 11., 1.0) ELSEIF(jlay(1).LT.jlay(0)) THEN CALL HF1(1, 12., 1.0) ELSE CALL HF1(1, 13., 1.0) ENDIF ENDIF CALL HF1(22, REAL(nrun), 1.0) IF(jlay(0).EQ.19) THEN CALL HF1(1, 14., 1.0) DO i = 1, nhts(0) modu = ITRKS(i,0) is = (modu-1)/21+1 il = modu-(is-1)*21 CALL HF2(33, REAL(is), REAL(il), 1.0) ENDDO IF(jlay(1).EQ.jlay(0)) THEN CALL HF1(1, 15., 1.0) DO i = 1, nhts(0) modu = ITRKS(i,0) is = (modu-1)/21+1 il = modu-(is-1)*21 CALL HF2(30, REAL(is), REAL(il), 1.0) ENDDO DO i = 1, nhts(1) modu = ITRKS(i,0) is = (modu-1)/21+1 il = modu-(is-1)*21 IF(RDTHIT(1,il,is).NE.0)CALL HF2(31,REAL(is),REAL(il),1.) IF(RDTHIT(2,il,is).NE.0)CALL HF2(32,REAL(is),REAL(il),1.) ENDDO c Temporary. 15-16,17 modules investigation. c c l1 = IUCOMP(310, ITRKS(1,1),nhts(1)) c l2 = IUCOMP(311, ITRKS(1,1),nhts(1)) c IF (l1.NE.0.AND.l2.EQ.0) THEN c CALL DUMP_RDTRK(6) c Type *,'Hit in 15-16',rdcal(1,16,15),rdcal(2,16,15), c + rdcal(1,17,15),rdcal(2,17,15) c pause c ELSEIF(l1.EQ.0.AND.l2.NE.0) THEN c CALL DUMP_RDTRK(6) c Type *,'Hit in 15-17',rdcal(1,16,15),rdcal(2,16,15), c + rdcal(1,17,15),rdcal(2,17,15) c pause c ENDIF ELSEIF(jlay(1).LT.jlay(0)) THEN CALL HF1(1, 16., 1.0) DO i = nhts(1), 1, -1 modu = ITRKS(i,1) ihit = IUCOMP(modu,ITRKS(1,0),nhts(0)) IF(ihit.NE.0) THEN IF(.NOT.(ihit.LT.nhts(0))) STOP 'I.Th.1' CALL HF1(25, REAL(nhts(1)-i+1), 1.0) mod0 = ITRKS(ihit+1,0) is0 = (mod0-1)/21+1 il0 = mod0-(is0-1)*21 is = (modu-1)/21+1 il = modu-(is-1)*21 IF(.NOT.(is0.EQ.is-1.AND.il0.EQ.il+2)) THEN ! Skip sp. case dse = m2s(itrks(1,0))-m2s(itrks(nhts(0),0))+1 IF(dse.LT.1) dse = dse + 24 IF(dse.GT.3.OR. + (nrdhit(4).GT.100.OR.rdhits.GT.100)) GOTO 20 ! Get rid of garbage events IF(nrun.EQ.42457.AND.nevt.EQ.12483) GOTO 20 ICFAIL = 0 CALL TDMAPC('RD',1,il,is,tdch(3),iflg) CALL TDMAPC('RD',2,il,is,tdch(4),iflg) CALL TDMAPC('RD',1,il0,is0,tdch(1),iflg) CALL TDMAPC('RD',2,il0,is0,tdch(2),iflg) WRITE(33,'(X,I6,I9,2I3,X,4(I3,1H,))') + nrun,nevt,is0,il0,tdch C CALL DUMP_RDTRK(33) IF(RDTHIT(1,il0,is0).EQ.0.AND.RDTHIT(2,il0,is0).EQ.0) + THEN CALL HF1(1,18.0,1.0) CALL HF2(26,0.0,rdcmb(1,il0,is0),1.0) IF(rdcmb(1,il0,is0).LT.10.0) THEN C print *,'3.X',nrun,nevt,rdcmb(1,il0,is0) ENDIF ELSE CALL HF2(26,1.0,rdcmb(1,il0,is0),1.0) C print *,'2.4',nrun,nevt,rdcmb(1,il0,is0) ENDIF IF(rdcmb(1,il0,is0).GT.10.0) THEN CALL HF1(1,20.,1.0) CALL HF2(20, REAL(is0), REAL(il0), 1.0) CALL DUMP_RDTRK(34) ELSE CALL HF2(19, REAL(is0), REAL(il0), 1.0) CALL DUMP_RDTRK(35) ENDIF CALL HF1(21, REAL(nrun), 1.0) IF(rdcmb(1,il,is).LT.10.0.AND. + (m2s(itrks(1,0))-m2s(itrks(nhts(0),0))+1).LE.2.AND. + il.GE.7.AND..FALSE.) THEN CALL ADCUNP('RD','PED') CALL ADCUNP('RD','CAL') DO j = 2, 4 print *,is0,il0,rdamp(1,il0,is0,j),rdamp(2,il0,is0,j) print *,is ,il ,rdamp(1,il ,is ,j),rdamp(2,il ,is ,j) ENDDO print *,0.5*(1.67*(il0-7)+130.0)* * alog(rdped(1,il0,is0)/rdped(2,il0,is0)) print *,0.5*(1.67*(il-7)+130.0)* * alog(rdped(1,il,is)/rdped(2,il,is)) CALL DUMP_RDTRK(6) pause ENDIF ELSE CALL HF1(1,19.0,1.0) ENDIF GOTO 20 ENDIF ENDDO STOP 'No common modules or zero time track' 20 CONTINUE ELSE CALL HF1(1, 17., 1.0) ENDIF ENDIF IF(.NOT.ldump) RETURN CALL DUMP_RDTRK(6) pause RETURN END SUBROUTINE MY_END_RUN CALL EXEC_ON_EXIT RETURN END SUBROUTINE EXEC_ON_EXIT #include CALL HROPEN(LTEMP, 'HBTEMP', 'test.hbk', 'N', 1024, ISTAT ) IF(ISTAT .NE. 0) THEN print *,'Error at opening test.hbk' RETURN ENDIF CALL HROUT(0, ICYCLE, ' ') CALL HREND('HBTEMP') CLOSE(LTEMP) print *,'Hist. saved' RETURN END SUBROUTINE DUMP_RDTRK(olun) IMPLICIT NONE INTEGER olun #include #include #include #include #include INTEGER i, j, isec INTEGER TH(0:1) REAL TM(0:1), SG(0:1) REAL PRNTDC C Find track time DO i = 0, 1 CALL RD_TRK(i) IF(NTRK.EQ.1) THEN CALL TRKTIM_RD(1,0) TH(i) = NHITS_TM TM(i) = TIM_TM SG(i) = SIG_TM ELSE TM(i) = -99.0 TM(i) = 0.0 SG(i) = 0.0 ENDIF ENDDO CALL RD_TRK(1) isec = (ITRK(1,1)-1)/21+1 write(olun,'(X,A,I6,I8,2I3)') 'NRUN, NEVT, T.2, NTRK=',NRUN, NEVT, + ISEC, NTRK write(olun,'(X,A,F7.2,I2)') 'E, HITS',ETRK(1),NHTRK(1) write(olun,'(X,A,2I3,2F6.2)') 'IMOST(2),TDOTA(2)',IMOST,TTDOTA write(olun,400) (TH(j),TM(j),SG(j),j=0, 1) 400 FORMAT(X,'TRKTIM: NHIT, TIME',2(I3,F6.2,'+/-',F4.2)) write(olun,*) ' ' C print worked RS TDC channels c CALL TDCUNP('RD','CAL',-99.,999.) write(olun,300) 0,(j,j=1,24) DO i = 19, 1, -1 write(olun,300) i,(NINT(PRNTDC(2,i,j)), j=1,24) write(olun,300) i,(NINT(PRNTDC(1,i,j)), j=1,24) c write(olun,*) ' ' ENDDO write(olun,*) ' ' write(olun,300) 0,(j,j=1,24) DO i = 19, 1, -1 write(olun,300) i,(IRUSE(i,j),j=1,24) ENDDO write(olun,*) ' ' CALL RD_TRK(0) C Print worked RS ADC channels write(olun,300) 0,(j,j=1,24) DO i = 19, 1, -1 write(olun,300) i,(NINT(10*RDCMB(1,i,j)), j=1,24) c write(olun,*) ' ' 300 FORMAT(X,25(I3)) ENDDO write(olun,*) ' ' write(olun,300) 0,(j,j=1,24) DO i = 19, 1, -1 write(olun,300) i,(IRUSE(i,j),j=1,24) ENDDO write(olun,*) ' ' RETURN END REAL FUNCTION PRNTDC(en,la,se) IMPLICIT NONE #include INTEGER en,la,se INTEGER i, modu modu = (se-1)*21+la IF(rdthit(en,la,se).LE.0) THEN PRNTDC = 0.0 DO i = 1, rdhits IF(rdtmod(i).EQ.modu) THEN PRNTDC = -9.0 GOTO 99 ENDIF ENDDO ELSE PRNTDC = RDTTDC(en,la,se,rdthit(en,la,se)) ENDIF 99 CONTINUE RETURN END INTEGER FUNCTION m2s(modu) IMPLICIT NONE INTEGER modu,is,il IF(.NOT.(1.LE.modu.AND.modu.LE.1008)) STOP 'm2s: Err1' is = (modu-1)/21+1 il = modu-(is-1)*21 m2s = is RETURN END