SUBROUTINE SETUP ( NERR )
CSETUP*2 SUBROUTINE TO READ IN AN EVENT -- EXTENDED CARD PARAMETER DECK
C ************************* COMMON COMMON **************************
COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
COMMON /LIMIT/LIMMNO,LIMLNO,LIMKNO,LIMEX
DIMENSION ZMAP(2000)
DIMENSION REMARK(500)
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 PARA(1000),NPARA(1000),SNAME(1000),NAME(1000)
DIMENSION HEAD(11), NBRNCH(10)
DIMENSION HLIST(500), TITLE(48), KTABLE(7,100), NC(48),
1 HTABLE(7,100), TBLMS(30)
EQUIVALENCE (MAP,ZMAP)
EQUIVALENCE (REMARK,MAP(1001))
EQUIVALENCE (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)),
1 (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)),
2 (WGT,MAP(1631))
EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),
1 (NTAPE,MAP(1988)), (EINC,MAP(1998)),
2 (PINC,MAP(1999)), (BINC,MAP(2000))
EQUIVALENCE (HLIST,KLIST), (HTABLE,KTABLE,MAP), (NC,MAP(1731)),
1 (TITLE,MAP(1870)), (TBLMS,PARS)
EQUIVALENCE (NTOT,PARS(99)),
1 (GMINP,MAP(1975)), (GMAXP,MAP(1976)), (GSCALE,MAP(1977)),
2 (IPS,MAP(1973)), (LISTW,MAP(1979)), (LISTG,MAP(1989))
EQUIVALENCE (MTOT,MAP(1987)), (IRNDM,MAP(1986)) 8/17/68
EQUIVALENCE (PARA,NPARA,PARS),(SNAME,NAME,MAP(1))
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(NOUTH,MAP(1980)),(NOUTM,MAP(1981)),(NPT,MAP(1982))
C ****************** END OF STANDARD CDE STATEMENTS ****************
DIMENSION VART(48)
DATA ITERAT /0/, BLANK /' '/
C 0370
IF (ITERAT) 100, 100, 101
C READ NEW CARD
100 READ (NIT,9150)CODE, MCODE, CM,TG, HBEG, HEND, VART
9150 FORMAT (A1,I3,2A1,2F9.3,48A1)
CALL LTON ( 1, CODE, L, LDUM)
CALL LTON (1, CM, LCM, LDUM)
CALL LTON (1, TG, LTG, LDUM)
C PROCESS PREVIOSLY READ CARD
101 IF (L-30) 105, 102, 105
C GET NEW PARAMETERS 0970
102 NERR=100 0980
ITERAT = 0
C BACKSPACE NIT
GO TO 1000 1000
105 IF (L.EQ.5 .AND. ((MCODE+LTG).GT.0 .OR. (HBEG+HEND).GT.0.) .AND.
1 ITERAT.NE.0) GO TO 25
IF ( L-8) 100, 110, 100 1030
C
C ITERATE * START BY ZEROING RDECAY 0450
25 CALL RDECAY ( 0, GARB, GARB, GARB, GARB, GARB, GARB, GARB )
IRNDM = 0 8/17/68
ITERAT = -1
C ZERO MTABLE IF LCM IS ZERO
IF (LCM) 27, 27, 28
27 CALL OHIST(-1) 0540
C RESET PHASE SPACE TYPE IF LTG IS NON-ZERO
28 IF (LTG-1) 30, 29, 2802
2802 LTG = 2
29 IF (LTG-IPS) 2906, 30, 2902
C REASSIGN HISTOGRAM SPACE IF IPS CHANGES FROM 1 TO 2 0590
2902 IF (SPACE(KTABLE(1,1),LIMMNO)) 2903, 2904, 2903
2903 ITERAT = 0
NERR=31
GO TO 1000
2904 CALL OHIST (-1) 0610
2906 IPS = LTG
30 IF (HBEG) 35,35,33 0630
33 PINC=HBEG 0640
EINC=SQRT(BINC**2+PINC**2) 0650
35 IF (HEND) 38,38,36
36 GMAXP=PINC 0670
GMINP=HEND
GSCALE=ALOG(GMAXP/GMINP) 0680
38 IF (MCODE) 41,41,40
40 MTOT = MCODE * 100 0700
41 IF (VART(1).EQ.BLANK) GO TO 43
DO 42 K=1,48
42 TITLE(K)=VART(K)
43 CALL SCALW 0710
GO TO 1000 0720
C
C ORIGINAL OR NEW EVENT SPECIFICATION 0730
110 CALL OHIST(-1)
DO 90 K = 1, 2000 0820
90 MAP (K) = 0 0830
DO 95 K = 1, LIMLNO 0840
95 KLIST(K) = 0 0850
CALL RDECAY ( 0, GARB, GARB, GARB, GARB, GARB, GARB, GARB )
MTOT = NTOT 0810
NERR = 0 0880
KNO = 1 0890
LNO = 1 0900
MNO = 1 0910
NXF = 0 0930
NFLG = 0
ITERAT = 0
PINC = HBEG
GMINP = HEND
DO 96 K=1,48
96 TITLE(K) = VART(K)
C SET P. S. TYPE MARKER - IPS 1060
IPS=LTG
IF (IPS - 1) 111, 111, 112 1080
111 IPS = 1 1090
GO TO 120 1100
112 IPS = 2 1110
120 BINC = TBLMS(MCODE) 1120
EINC = SQRT( BINC**2 + PINC**2 ) 1130
GMAXP = PINC 1160
IF (GMINP) 125, 125, 121 1170
C BREMMSTRAHLUNG SPECTRUM = GMINP * EXPF ( ABSF(RAN * GSCALE)) 1180
121 GSCALE= ALOG( GMAXP/ GMINP) 1190
C BEGINNING OF CARD READ-IN LOOP 1200
C CHECK IF TABLES ARE EXCEEDED 1210
125 IF (MNO-LIMMNO) 126, 126, 1281 1220
126 IF (LNO-LIMLNO) 127, 127, 1282 1230
127 IF (KNO-LIMKNO) 129, 129, 1283 1240
1281 NERR = 31 1250
GO TO 1000 1260
1282 NERR = 32 1270
GO TO 1000 1280
1283 NERR = 33 1290
GO TO 1000 1300
C OKAY, PROCEED 1310
129 CONTINUE 1320
KCODE = 0 1340
READ (NIT,9150)CODE, MCODE,CM,TG, HBEG, HEND, VART
CALL LTON ( 1, CODE, L, LDUM)
IF ( L ) 500, 500, 130 1370
130 CALL LTON ( 48, VART(1), NC(1), LENGTH)
131 CONTINUE 1390
C MCODE NEGATIVE REQUESTS WEIGHTED HISTOGRAM 1400
MNOINC = IABS(MCODE) + 2 1410
GO TO (132, 133), IPS 1420
132 IF (MCODE) 133, 135, 135 1430
133 MNOINC = 3 * MNOINC 1440
135 CALL LTON (1, CM, LCM, LDUM)
CALL LTON (1, TG, LTG, LDUM)
C BRANCH ON CARD CODE 1470
140 GO TO (300, 302, 304, 280, 490, 306, 383, 480, 500, 308, 310, 1490
1 500, 312, 180, 600, 314, 500, 316, 290, 200, 318, 220, 380, 150
2 510, 520, 500, 500, 500, 500, 480), L
C N CARD 1520
180 MTOT = MCODE * 100 1530
C REINITIALIZE RANDOM IF NECESSARY 8/17/68
IF (LENGTH-10) 182, 182, 188 8/17/68
182 DO 184 K=1,LENGTH 8/17/68
IF (NC(K).LT.0 .OR. NC(K).GT.9) GO TO 188 8/17/68
184 IRNDM = 10*IRNDM + NC(K) 8/17/68
IF (IRNDM) 188, 125, 186 8/17/68
186 CALL ITRNDM(IRNDM,LDUM) 8/17/68
GO TO 125 8/17/68
188 NERR = 11 8/17/68
GO TO 1000 8/17/68
C T CARD 1550
200 IF (NFLG) 2001, 2002, 2001 1560
2001 NERR = 9 1570
GO TO 1000 1580
2002 DO 219 K = 1, 48, 2 1590
KVA = NC( K ) 1600
IF ( KVA-20) 201, 201, 203 1610
201 IF ( KVA ) 203, 125, 202 1620
202 KVB = NC(K+1) 1630
IF ( KVB - KVA) 203, 203, 205 1640
203 NERR = 1 1650
GO TO 1000 1660
205 ITABLE (1, KVA) = ITABLE ( 1, KVA ) + 1 1670
II = ITABLE ( 1, KVA ) 1680
IF ( II-8 ) 210, 210, 207 1690
207 NERR = 2 1700
GO TO 1000 1710
210 LTABLE ( II, KVA, 1 ) = MCODE 1720
LTABLE ( II, KVA, 2 ) = KVB 1730
IF ( KVB ) 211, 219, 213 1740
211 NERR = 4 1750
GO TO 1000 1760
213 IF ( KVB- 20 ) 214, 214, 219 1770
214 IF ( ITABLE ( 3, KVB) ) 211, 216, 215 1780
215 NERR = 5 1790
GO TO 1000 1800
216 ITABLE ( 3, KVB ) = KVA 1810
II = ITABLE ( 1, KVA ) 1820
ITABLE ( 4, KVB ) = II 1830
219 CONTINUE 1840
GO TO 125 1850
C V CARD 1860
220 DO 230 K = 1, 48 1870
KVA = NC ( K ) 1880
IF (KVA) 221, 125, 223 1890
221 NERR = 7 1900
GO TO 1000 1910
223 IF (KVA - 20) 225, 225, 221 1920
225 RTABLE ( 9, KVA, 1 ) = TBLMS ( MCODE ) 1930
RTABLE(9,KVA,2) = HBEG 1940
230 CONTINUE 1950
GO TO 125 1960
C D CARD 1970
280 DO 289 K = 1, 48, 2 1980
KVA = NC (K) 1990
IF ( KVA ) 282, 125, 285 2000
282 NERR = 8 2010
GO TO 1000 2020
285 IF ( KVA- 20) 286, 286, 282 2030
286 ITABLE(5,KVA) = NC(K+1) * 10 2040
289 CONTINUE 2050
GO TO 125 2060
C S CARD 2070
C TERMINATE FIRST GROUP 2080
290 CALL OFIX (NFLG) 2090
292 DO 298 K = 1, 48, 4 2100
KVA = NC ( K ) 2110
IF ( KVA ) 293, 125, 294 2120
293 NERR = 13 2130
GO TO 1000 2140
294 IF ( KVA - 20 ) 295, 295, 293 2150
295 ITABLE(5,KVA) = 10 * NC(K+1) 2160
297 KV = NC(K+2) 2210
KVB = NC(K+3) 2220
NENT = NOTABL (KV, KVB) 2230
IF (NENT) 2972, 2972, 2975 2240
2972 NERR = 14 2250
GO TO 1000 2260
2975 ITABLE(6,KVA) = NENT 2270
298 CONTINUE 2280
GO TO 125 2290
C 2300
C A CLASS CARDS 2310
318 KCODE = KCODE + 1 2320
310 KCODE = KCODE + 3 2330
304 KCODE = KCODE + 3 2340
314 KCODE = KCODE + 1 2350
300 KCODE = KCODE + 1 2360
KNP = 1 2370
KERR = 1 2380
GO TO 330 2390
C R CLASS CARDS 2400
302 KCODE = KCODE + 3 2410
316 KCODE = KCODE + 3 2420
KNP = 2 2430
KERR = 2 2440
GO TO 330 2450
C M CLASS CARDS 2460
308 KCODE = KCODE + 3 2470
312 KCODE = KCODE + 4 2480
KNP = 24
KERR = 3 2500
GO TO 330 2510
C F CARD 2520
306 KCODE = KCODE + 100 2530
KNP = 23
KERR = 4 2550
C 2560
330 CALL OFIX (NFLG) 2570
KNC = 1 2580
NFN = 0 2590
NPAR = 0 2600
C LOOK FOR CONDITIONAL REQUEST 2610
CALL CONDIT (LNO, KCNO, NERR, LENGTH)
IF (NERR) 1000, 333, 1000 2630
C LOAD KTABLE FOR THIS HISTOGRAM 2640
333 KTABLE(1,KNO) = KCODE 2650
KTABLE(2,KNO) = MNO 2660
KTABLE(3,KNO) = KCNO 2670
KTABLE(4,KNO) = LNO 2680
KTABLE(5,KNO) = MCODE 2690
HTABLE(6,KNO) = HBEG 2700
HTABLE(7,KNO) = HEND 2710
MNO = MNO + MNOINC 2720
GO TO (340, 340, 340, 334), KERR 2730
C F CARD - READ OUT FUNCTION NUMBER 2740
334 NA = IABS(NC(KNC)) 2750
NB= IABS(NC(KNC+1)) 2760
NFN = 10*NA + NB 2770
IF (NFN - 10) 335, 336, 336 2780
335 NERR = 18 2790
GO TO 1000 2800
336 KLIST (LNO) = NFN 2810
LNO = LNO + 1 2820
KNC = KNC + 2 2830
340 KLNO = LNO 2840
LNO = LNO + 1 2850
C EXAMINE THE VARIABLE FIELD 2860
342 DO 358 KN = 1, KNP 2870
NA= IABS(NC(KNC)) 2880
NB= IABS(NC(KNC+1)) 2890
IF (NA) 368, 368, 343
C CHECK FOR COMMA 2910
343 IF (NA - 28) 350, 344, 353
344 IF (NFN) 353, 353, 345
345 KTABLE(4,KNO) = -(1000*KTABLE(4,KNO) + KLIST(KLNO) + 1)
CALL ECP(KNC, LENGTH, KLNO, LNO) 01/03/68
GO TO 368 01/03/68
350 KNC = KNC + 2
NENT = NOTABL (NA, NB) 3000
IF (NENT) 353, 353, 355 3010
353 GO TO (370, 372, 374, 376), KERR 3020
355 KLIST(LNO) = NENT 3030
KLIST(KLNO) = KLIST(KLNO) + 1 3040
LNO = LNO + 1 3050
358 CONTINUE 3060
IF (KNC - LENGTH) 360, 368, 368
C IF NEXT ENTRY IS NEGATIVE, ADD ON TO THIS HISTOGRAM 3080
360 IF (NC(KNC)) 342, 368, 362 3090
C FINISH OFF THIS HISTOGRAM, GET CMS REQUEST - IF ANY 3100
362 CALL CMSREQ (LCM, LNO, LTG, KNO, KLNO)
KNO = KNO + 1 3120
GO TO 333 3130
C END OF CARD - WRAP IT UP 3140
368 CALL CMSREQ (LCM, LNO, LTG, KNO, KLNO)
KNO = KNO + 1 3160
GO TO 125 3170
370 NERR = 15 3180
GO TO 1000 3190
372 NERR = 17 3200
GO TO 1000 3210
374 NERR = 16 3220
GO TO 1000 3230
376 NERR = 20 3240
GO TO 1000 3250
C O CARD * PUNCH OUT FACILITY JAN 12 67
600 NPT = MCODE
IF (HBEG .GT. 0.) NOUTM = 1
IF (HBEG .NE. 1.) NOUTH = 1
GO TO 125
C W CARD * WEIGHT CALCULATION 3260
380 CALL OFIX (NFLG) 3270
382 LNOFN = LNO 3280
LISTW = LNO 3290
KLIST(LNO+1) = MCODE 3300
LNO = LNO + 2 3310
GO TO 386 3320
C G CARD * EXPERIMENTAL FACILITY 3330
383 CALL OFIX (NFLG) 3340
385 LISTG = LNO 3350
NTAPE = MCODE 3360
LNOFN = LNO 3370
LNO = LNO + 1 3380
386 HLIST(LNO) = HBEG 3390
HLIST(LNO+1) = HEND 3400
LNONE = LNO + 2 3410
LNO = LNO + 3 3420
DO 399 K = 1, 48, 2 3430
KA = NC(K) 3440
KB = NC(K+1) 3450
IF (K - 1) 390, 390, 394 3460
390 NFN = 10*KA + KB 3470
IF (NFN - 10) 391, 392, 392 3480
391 NERR = 18 3490
GO TO 1000 3500
392 KLIST(LNOFN) = NFN 3510
GO TO 399 3520
394 IF (KA) 125, 125, 396 3530
396 NENT = NOTABL (KA, KB) 3540
IF (NENT) 397, 397, 398 3550
397 NERR = 20 3560
GO TO 1000 3570
398 KLIST(LNO) = NENT 3580
KLIST(LNONE) = KLIST(LNONE) + 1 3590
LNO = LNO + 1 3600
399 CONTINUE 3610
GO TO 125 3620
C E CARD MISSING, PROCEED 3630
480 CONTINUE
C E CARD 3670
490 MNOLFT=LIMMNO-MNO+1
WRITE (NOT,9200) LIMMNO,LIMLNO,LIMEX,LIMKNO,MNOLFT
9200 FORMAT (//16H0MTABLE LIMIT = I5,16H, KLIST LIMIT = ,I4,17H, EXBANK
1 LIMIT = I5,42H, MAXIMUM NUMBER OF HISTOGRAMS ALLOWED IS I4,1H.,
2 /11H0THERE ARE ,I6,26H LOCATIONS LEFT IN MTABLE. //)
C
IF (NFLG) 493, 491, 493
491 NERR = 12 3760
GO TO 1000 3770
493 CALL SCALW 3780
ITERAT = 1
GO TO 1000 3790
C ILLEGAL CARD CODE 3800
500 NERR = 10 3810
GO TO 1000 3820
C X CARD 3830
510 KCODE = 1000 3840
NXF = 1 3850
MNOINC = 0 3860
NXA= IABS(MCODE) 3870
GO TO 530 3880
C Y CARD 3890
520 IF (NXF - 1) 521, 522, 521 3900
521 NERR = 25 3910
GO TO 1000 3920
522 KCODE = 2000 3930
MNOINC= (NXA+ 1)*(IABS(MCODE) + 1) + 5 3940
530 L= IABS(NC(1)) 3950
DO 532 K = 1, 47 3960
532 NC(K) = NC(K+1) 3970
LENGTH = LENGTH - 1
GO TO 140 3980
1000 RETURN 3990
END 4000