SUBROUTINE EHIST
CEHIST*2 ENTERS EVENT VARIABLES INTO HISTOGRAMS
C EXTRA CARD PARAMETER VERSION -- INCOMPATIBLE WITH ANY OTHER NVERTX
C ************************* COMMON COMMON ************************** 0030
COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
DIMENSION ZMAP(2000) NBOD0110
DIMENSION REMARK(500)
DIMENSION OTABLE(7,50), JTABLE(7,50), RTABLE(9,20,2), NBOD0120
1 LTABLE(9,20,2), ITABLE(6,20), VAL(100), IVAL(100), NBOD0130
2 WGT(100) NBOD0140
DIMENSION PARA(1000),NPARA(1000),SNAME(1000),NAME(1000)
DIMENSION HEAD(11), NBRNCH(10) NBOD0170
DIMENSION KTABLE(7,100), HTABLE(7,100), DCTRA(3), DIRINC(3),
1 VM(3), VN(3), WTABLE(2)
EQUIVALENCE (MAP,ZMAP) NBOD0340
EQUIVALENCE (REMARK,MAP(1001))
EQUIVALENCE (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)), NBOD0350
1 (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)), NBOD0360
2 (WGT,MAP(1631)) NBOD0370
EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)), NBOD0380
1 (NTAPE,MAP(1988)), (EINC,MAP(1998)), NBOD0390
2 (PINC,MAP(1999)), (BINC,MAP(2000)) NBOD0400
EQUIVALENCE (KTABLE,HTABLE,MAP), (WTABLE,MTABLE), (RADIAN, 0310
1 MISC(2)), (DIRINC,PARS(95)), (DCTRA,MAP(1852)), 0320
2 (VM,MAP(1833)), (VN,MAP(1836)), (LISTW,MAP(1979)), 0330
3 (LISTG,MAP(1989)), (IPS,MAP(1973)), (WPS,MAP(1974)) 0340
EQUIVALENCE (PARA,NPARA,PARS),(SNAME,NAME,MAP(1))
EQUIVALENCE (PI, MISC), (RADIAN, MISC(2)), (NIT, MISC(3)), NBOD0490
1 (NOT, MISC(4)), (HEAD, MISC(5)), (NBRNCH, MISC(16)), NBOD0500
2 (NPAGE, MISC(26)), (NORD, MISC(27)) NBOD0510
C ****************** END OF C D E PACKAGE ************************** 0280
C 0350
IF (LISTW) 3, 3, 1 0360
1 CALL GENFUN(LISTW, 0) 0370
3 IF (LISTG) 7, 7, 5 0380
5 CALL GENFUN(LISTG, 0 ) 0390
7 NXC = 0 0400
C 0410
DO 200 K = 1,100 0420
NCFLAG = 0 0430
IF (KTABLE(1,K)) 500, 500, 8 0440
C HISTOGRAM, X PLOT OR Y PLOT 0450
8 NBR = 1 0460
KT = KTABLE(1,K) 0470
IF (KT - 1000) 9, 801, 801 0480
801 IF (KT - 2000) 8011, 802, 802 0490
8011 NXC = 0 0500
NBR = 2 0510
GO TO 805 0520
802 IF (NXC) 200, 803, 200 0530
803 NBR = 3 0540
805 KT= MOD(KT, 1000) 0550
C SET KT AND KTT, VARIABLE CODES W AND W/O CMS CODE 0560
9 KTT = MOD(KT,10) 0570
IF (KTT) 200, 901, 902 0580
901 KTT = 10 0590
KT = KT - 90 0600
C CONDITIONAL TEST 0610
902 KFLAG = 0 0620
IF (KTABLE(3,K)) 9021, 10, 903 0630
9021 KFLAG = 3 0640
903 KCON = IABS(KTABLE(3,K)) 0650
IF(KFLAG.EQ.3) KCON = KCON/1000
CALL GENFUN (KCON, KFLAG) 0660
IF (NCFLAG) 905, 10, 10 0670
905 GO TO (200, 907, 200), NBR 0680
907 NXC = 1 0690
GO TO 200 0700
C GET HISTOGRAMMING DATA 0710
10 M = KTABLE(2,K) 0720
N = KTABLE(5,K) 0730
WGT(1)= WPS 0740
NRT = 1 0750
IPS = IPS 0760
GO TO (1002, 1001), IPS 0770
1001 NRT = 2 0780
MA = M + N + 2 0790
MB = 2*MA - M 0800
1002 IF (N) 1003, 1004, 1004 0810
1003 NRT = 2 0820
WGT(1)= WGT(1)* WEIGHT 0830
N = -N 0840
MA = M + N + 2 0850
MB = MA + N + 2 0860
1004 XBEG = HTABLE(6,K) 0870
XEND = HTABLE(7,K) 0880
ML = IABS(KTABLE(4,K)) 0890
IF(KTABLE(4,K).LT.0) ML = ML/1000
MO = KLIST(ML) 0900
ML = ML + 1 0910
IF (KTT - 10) 1008, 1005, 1005 0920
1005 MO = KLIST(ML) 0930
ML = ML + 1 0940
1008 ME = ML + MO - 1 0950
KE = 0 0960
KBEG = ML 0970
C SET CMS TRANSFORMATION DATA 0980
KCMS = (KT - 1)/10 0990
IF (KCMS - 1) 19, 11, 11 1000
11 KE = KLIST(ME) 1010
ME = ME - 1 1020
IF (KE) 200, 200, 14
14 JV = JTABLE ( 7,KE ) 1100
DO 15 KK = 1,3 1110
15 DCTRA ( KK ) = OTABLE ( KK, KE ) 1120
TMASS = RTABLE ( 9, JV, 1 ) 1130
BETLAB = OTABLE ( 5, KE ) 1140
BPLAB = OTABLE ( 4, KE ) 1150
16 IF (KCMS - 1) 19, 17, 18 1160
17 TMASS = 0.0 1170
18 BETA = BPLAB/(BETLAB + TMASS) 1180
C 1190
19 GO TO (20, 40, 60, 80, 20, 60, 80, 40, 40, 100), KTT 1200
C ANGLE HISTOGRAM ( A CARD) 1210
20 NENT = 0 1220
DO 39 ML = KBEG, ME 1230
Q = 0.0 1240
KL = KLIST(ML) 1250
IF (KCMS) 200, 21, 25 1260
21 DO 22 KK = 1,3 1270
22 VM(KK) = OTABLE ( KK,KL) 1280
GO TO 30 1290
25 DO 26 KK = 1,3 1300
26 VN(KK) = OTABLE ( KK,KL ) 1310
EIN = OTABLE ( 5,KL ) 1320
PIN = OTABLE ( 4, KL ) 1330
CALL LORTRA (BETA, DCTRA(1), EIN, PIN, VN(1), EVAL, PVAL, VM(1)) 1340
30 DO 31 KK = 1,3 1350
31 Q = Q + DIRINC(KK) * VM(KK) 1360
IF (ABS(Q) - 1.0) 33, 33, 32 1370
32 Q = SIGN(1.0,Q) 1380
33 IF (KTT - 5) 34, 35, 34 1390
34 Q =ACOS(Q) * RADIAN 1400
35 NENT = NENT + 1 1410
VAL(NENT) = Q 1420
39 CONTINUE 1430
GO TO 110 1440
C MOMENTUM HISTOGRAM (P CARD) 1450
40 NENT = 0 1460
DO 59 ML = KBEG, ME 1470
KL = KLIST(ML) 1480
IF (KCMS) 200, 41, 45 1490
41 PVAL = OTABLE(4,KL) 1500
EVAL = OTABLE(5,KL) 1510
GO TO 50 1520
45 DO 46 KK = 1,3 1530
46 VN(KK) = OTABLE ( KK,KL ) 1540
EIN = OTABLE( 5,KL ) 1550
PIN = OTABLE( 4,KL ) 1560
CALL LORTRA (BETA, DCTRA(1), EIN, PIN, VN(1), EVAL, PVAL, VM(1)) 1570
50 CONTINUE 1580
IF (KTT - 8) 501, 505, 503 1590
501 Q = PVAL 1600
GO TO 52 1610
503 Q = EVAL 1620
GO TO 52 1630
505 IV = JTABLE(6,KL) 1640
IVB = JTABLE(7,KL) 1650
DO 507 IP = 1, 8 1660
IF (LTABLE(IP,IV,2) - IVB) 507, 508, 507 1670
507 CONTINUE 1680
GO TO 200 1690
508 MSNO = LTABLE(IP,IV,1) 1700
CALL GETMS (MSNO,FM) 1710
Q = EVAL - FM 1720
52 NENT = NENT + 1 1730
VAL(NENT) = Q 1740
59 CONTINUE 1750
GO TO 110 1760
C RELATIVE ANGLE HISTOGRAM (R CARD) 1770
60 NENT = 0 1780
DO 79 ML = KBEG, ME, 2 1790
Q = 0.0 1800
KL = KLIST(ML) 1810
MLL = ML +1 1820
KLL = KLIST (MLL) 1830
IF (KCMS) 200, 601, 605 1840
601 DO 602 KK = 1,3 1850
VM(KK) = OTABLE(KK,KL) 1860
602 VN(KK) = OTABLE(KK,KLL) 1870
GO TO 607 1880
605 EIN = OTABLE(5,KL) 1890
PIN = OTABLE(4,KL) 1900
CALL LORTRA (BETA,DCTRA(1), EIN,PIN,OTABLE(1,KL), EVAL,PVAL,VM(1)) 1910
EIN = OTABLE(5,KLL) 1920
PIN = OTABLE(4,KLL) 1930
CALL LORTRA (BETA,DCTRA(1), EIN,PIN,OTABLE(1,KLL), EVAL,PVAL,VN(1) 1940
1) 1950
607 DO 61 KK = 1,3 1960
61 Q = Q + VM(KK) * VN(KK) 1970
IF (ABS(Q) - 1.0) 63, 63, 62 1980
62 Q = SIGN(1.0,Q) 1990
63 IF (KTT - 6 ) 64, 65, 64 2000
64 Q =ACOS(Q) * RADIAN 2010
65 NENT = NENT + 1 2020
VAL(NENT) = Q 2030
79 CONTINUE 2040
GO TO 110 2050
C INVARIANT MASS HISTOGRAM ( M CARD) 2060
80 NENT = 1 2070
VAL(1)= SQMASS (KBEG,ME) 2080
IF (KTT - 4) 200, 92, 110 2090
92 VAL(1)= SQRT(VAL(1)) 2100
GO TO 110 2110
C FUNCTION HISTOGRAM (F CARD) 2120
100 KLENT = KTABLE(4,K) 2130
IF (KLENT) 106, 108, 108 2140
106 KCMS = KCMS + 3 2150
KLENT = -KLENT/1000
108 CALL GENFUN (KLENT, KCMS) 2170
109 NENT= MAX0(1, IABS(NCFLAG)) 2180
C VAL AND NENT ALL READY, LOAD WEIGHT ARRAY 2190
110 DO 111 KK = 1, NENT 2200
111 WGT(KK) = WGT(1) 2210
GO TO (112, 120, 130), NBR 2220
C ENTER INTO HISTOGRAM 2230
112 GO TO (114, 116), NRT 2240
114 CALL HISTO (VAL(1), NENT, MTABLE(M), N, XBEG, XEND) 2250
GO TO 200 2260
116 CALL HISTOW (VAL(1), NENT, MTABLE(M), WTABLE(MA), N, XBEG, XEND, 2270
1 WGT(1), WTABLE(MB)) 2280
GO TO 200 2290
C RECORD X COORDINATE FOR PLOT 2300
120 CONTINUE 2310
DO 124 KK = 1, NENT 2320
124 VAL (KK + 50) = VAL(KK) 2330
NA = N 2340
AMIN = XBEG 2350
AMAX = XEND 2360
GO TO 200 2370
C ENTER EVENTS INTO PLOT 2380
130 CONTINUE 2390
CALL ENTMAT (NRT, VAL(51), VAL(1), NENT, WGT(1), MTABLE(M), WTABLE 2400
1(M), AMIN, AMAX, NA, XBEG, XEND, N) 2410
200 CONTINUE 2420
C 2430
500 CONTINUE 2440
RETURN 2450
END 2460
SUBROUTINE OHIST (NOZ)
COHIST*2 HISTOGRAM OUTPUT ROUTINE
C EXTRA CARD PARAMETER VERSION -- INCOMPATIBLE WITH ANY OTHER NVERTX
C ZERO ONLY IF NOZ NEGATIVE 0030
C ****************** COMMON COMMON *************************** 0040
COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
COMMON /LIMIT/LIMMNO,LIMLNO,LIMKNO,LIMEX
DIMENSION ZMAP(2000)
DIMENSION OTABLE(7,50), JTABLE(7,50), RTABLE(9,20,2),
1 LTABLE(9,20,2), ITABLE(6,20), VAL(100), IVAL(100),
2 WGT(100)
DIMENSION HTABLE(7,100), KTABLE(7,100), TITLE(48)
DIMENSION PARA(1000),NPARA(1000),SNAME(1000),TABLE(100)
DIMENSION HEAD(11), NBRNCH(10)
DIMENSION WTABLE(2)
EQUIVALENCE (MAP,ZMAP),(TABLE(1),PARA(101))
EQUIVALENCE (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)),
1 (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)),
2 (WGT,MAP(1631))
EQUIVALENCE (HTABLE, KTABLE, MAP)
EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),
1 (NTAPE,MAP(1988)), (EINC,MAP(1998)),
2 (PINC,MAP(1999)), (BINC,MAP(2000))
EQUIVALENCE (IPS,MAP(1973)), (WPS,MAP(1974)) 0640
EQUIVALENCE(NOUTH,MAP(1980)),(NOUTM,MAP(1981)),(NPT,MAP(1982))
EQUIVALENCE (TITLE,MAP(1870))
EQUIVALENCE (PARA,NPARA,PARS),(SNAME,MAP)
EQUIVALENCE (PI, MISC), (RADIAN, MISC(2)), (NIT, MISC(3)),
1 (NOT, MISC(4)), (HEAD, MISC(5)), (NBRNCH, MISC(16)),
2 (NPAGE, MISC(26)), (NORD, MISC(27))
EQUIVALENCE (MTABLE, WTABLE) 0670
C *************** END COMMON COMMON ************************* 0320
DIMENSION AME(3), AMES(6)
EQUIVALENCE (AME,NAM)
IF (NOZ) 5001 ,5, 5 0700
5001 DO 501 KK = 1, LIMMNO 0710
501 MTABLE(KK) = 0 0720
GO TO 502 0730
5 CONTINUE 0740
CALL ITRNDM(0,IOLD) 8/17/68
WRITE (NOT,9200) IOLD 8/17/68
9200 FORMAT('0TO CONTINUE THIS RUN SET THE STARTING VALUE OF RANDOM = '8/17/68
1 I10) 8/17/68
NH = 0 0750
DO 200 K = 1,100 0760
IF (KTABLE(1,K))500,500,10 0770
10 M = KTABLE(2,K) 0780
N = KTABLE(5,K) 0790
NZ = 0 0800
GO TO (17, 15), IPS 0820
15 NZ = 2 0830
I = M + N + 2 0840
J = 2*I - M 0850
17 IF (N) 20, 70, 70 0860
20 NZ = 2 0870
N = -N 0880
I = M + N + 2 0890
J = I + N + 2 0900
70 XBEG = HTABLE(6, K) 0910
XEND = HTABLE(7,K) 0920
CALL NAME(K, AME(1))
85 CONTINUE 0940
IF (KTABLE(1,K) - 1000) 150, 90, 90 0950
90 IF (KTABLE(1,K) - 2000) 95, 100, 100 0960
95 KX = K 0970
DO 96 I=1,3
96 AMES(I) = AME(I)
NA = N 0990
AMIN = XBEG 1000
AMAX = XEND 1010
GO TO 200 1020
100 DO 101 I=1,3
101 AMES(I+3) = AME(I)
NZ= MAX0(NZ, 1) 1040
NH = NH + 1 1060
IF(NOUTM.EQ.0) GO TO 103
WRITE(NPT,9123)NH,PINC,TITLE
9123 FORMAT(4H NO.I3,1XF9.4,3X,48A1)
270 DO 300 I=1,N
MBEG=M+(I-1)*(NA+1)
MEND=MBEG+NA-1
IF (NZ-1) 280, 280, 290
280 WRITE (NPT,9400) (MTABLE(J),J=MBEG,MEND)
GO TO 300
290 WRITE (NPT,9450) (WTABLE(J),J=MBEG,MEND)
300 CONTINUE
103 CALL OUTMAT (NOT,AMES(1),NZ,MTABLE(M),AMIN,AMAX,NA,XBEG,XEND,N)
WRITE (NOT,9100)NH 1070
9100 FORMAT (3H NO I4, 25H TWO DIMENSIONAL PLOT OF ) 1080
CALL HISCAP (0,KX) 1090
CALL HISCAP (0,K) 1100
GO TO 200 1110
150 CALL TRHIST (NOT, NZ, NAM, MTABLE(M), WTABLE(I), WTABLE(J), N,
1 XBEG, XEND) 1130
NH = NH + 1 1140
IF(NOUTH.EQ.0) GO TO 105
WRITE(NPT,9150)NH,PINC,AME,TITLE
9150 FORMAT(4H NO.I3,1XF9.4,1X3A4,2X48A1)
IF (NZ) 350, 350, 360
350 MHI = M+N-1
WRITE (NPT,9400) (MTABLE(NPM), NPM=M,MHI)
9400 FORMAT (12I6)
GO TO 105
360 MHI = I+N-1
WRITE (NPT,9450) (WTABLE(NPM), NPM=I,MHI)
9450 FORMAT (10F8.2)
105 WRITE (NOT,9000)
9000 FORMAT (1H0) 1160
CALL HISCAP (NH,K) 1170
200 CONTINUE 1180
500 CONTINUE 1190
502 CONTINUE 1200
RETURN 1210
END 1220