Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0009/nvhed.for
There is 1 other file named nvhed.for in the archive. Click here to see a list.
SUBROUTINE HEDING
CHEDING*1 PRINTS OUT HEADING FOR RUN HEDI0010
C ************************* COMMON COMMON **************************HEDI0030
COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
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 PARA(1000),NPARA(1000),SNAME(1000),NAME(1000),TABLE(100)
DIMENSION HEAD(11), NBRNCH(10),HTABLE(7,100)
DIMENSION KTABLE(7,100), TITLE(48),OBANK(90), IBANK(90), HEDI0100
1 TBLMS(30), AD(40), HLIST(500) HEDI0110
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 (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),
1 (NTAPE,MAP(1988)), (EINC,MAP(1998)),
2 (PINC,MAP(1999)), (BINC,MAP(2000))
EQUIVALENCE (KTABLE, MAP), (TITLE, MAP(1870)), (OBANK, IBANK,
1 MAP(1779)), (IPS, MAP(1973)), (GMINP, MAP(1975)),
2 (GMAXP, MAP(1976)), (LISTW, MAP(1979)), (LISTG,
3 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 (LTAPE,NBRNCH(9)), (LINK,NBRNCH(10)), (HTABLE,MAP)
EQUIVALENCE (HLIST, KLIST), (TBLMS, PARS), (AD, PARS(40)),
1 (RSCALE, PARS(98))
C ************************* END OF C, D, E STATEMENTS **************HEDI0340
DATA ASTERK/'****'/, BLANKS/' '/, HNON/'NON-'/, AHOL/'A'/,
1PARENL, PARENR/'(', ')'/, PLUS/' +'/
C HEDI0430
WRITE (NOT,9005)TITLE HEDI0440
9005 FORMAT ( 1H1 48A1)
GO TO (3, 4), IPS INVERTX
3 TYP =BLANKS
GO TO 5 HEDI0530
4 TYP = HNON
5 WRITE (NOT,9007)MTOT, TYP HEDI0560
9007 FORMAT ( 35H0THE FOLLOWING HISTOGRAMS REFER TO HEDI0570
1 I6, 36H THROWS OF THE FOLLOWING REACTIONS, A4, 21HINVARIANT PHAHEDI0580
2SE-SPACE ) HEDI0590
TMASS = RTABLE(9,1,1) HEDI0600
BETA = PINC/(EINC + TMASS) HEDI0610
BETA= AMIN1(BETA, 1.0) HEDI0620
GAMMA = 1.0/SQRT(1.0 - BETA**2) HEDI0630
OMEGA = (EINC + TMASS)/GAMMA HEDI0640
WRITE (NOT,9012)PINC, EINC, OMEGA, BETA, GAMMA HEDI0650
9012 FORMAT (1H0 43HINITIAL STATE PARAMETERS - BEAM MOMENTUM = F10.4, HEDI0660
1 3X14HBEAM ENERGY = F10.4 / 1H0 27X16HCMS ENERGY = F10.4, HEDI0670
2 3X9HBETA = 5XF10.4, 3X10HGAMMA = 4XF10.4 ) HEDI0680
IF (BINC) 7, 601, 7
601 IF (GMINP) 7, 7, 602
602 WRITE (NOT,9006)GMINP, GMAXP HEDI0710
9006 FORMAT ( 44H0THIS IS A BREMMSTRAHLUNG SPECTRUM BETWEEN F10.3, HEDI0720
1 4H AND F10.3 ) HEDI0730
7 WRITE (NOT,9008)
9008 FORMAT ( 1H0 120(1H*))
WRITE (NOT,9009) HEDI0760
9009 FORMAT (18H VERT DIS POL /18H ----------------- ) HEDI0770
DO 100 K = 1,20 HEDI0780
IF ( ITABLE ( 1,K)- 1 ) 100, 100, 9 HEDI0790
9 DO 10 KK = 1,11
OBANK(KK) = BLANKS
10 CONTINUE HEDI0830
CALL NTOL ( 1, OBANK(1), K ) HEDI0840
IDUM = ITABLE(5,K)/10
IF (IDUM .GT. 0) OBANK(2) = BCDW(IDUM)
15 IF ( ITABLE (6,K) ) 20,20,18
18 IDUM = ITABLE(6,K) HEDI0940
CALL NTOL ( 2, OBANK(3), JTABLE(6, IDUM) )
20 IF (K - 1) 100, 22, 23 HEDI0970
22 OBANK(7) = AHOL
OBANK(8) = AHOL
IBANK(5) = BINC*RSCALE + 0.5
GO TO 24
23 KK = ITABLE(3,K)
CALL NTOL(1, OBANK(7), KK)
CALL NTOL(1, OBANK(8), K)
IDUM = ITABLE(4,K)
KDUM = LTABLE(IDUM, KK, 1) HEDI1050
IBANK(5) = TBLMS(KDUM)*RSCALE + 0.5
IF (KDUM - 20) 24, 25, 25 HEDI1150
24 OBANK(6) = PARENL
OBANK(9) = PARENR
GO TO 26 HEDI1190
25 OBANK(6) = ASTERK
OBANK(9) = ASTERK
26 IF (RTABLE(9, K, 1)) 100, 30, 28
28 OBANK(10) = PLUS
IDUM = RTABLE(9,K,1)*RSCALE + 0.5 HEDI1310
OBANK(11) = BCDW(IDUM)
30 IDUM = ITABLE(1,K ) HEDI1370
II = 12
DO 40 KK = 1, IDUM HEDI1390
IF ( KK-1) 40, 34, 32 HEDI1400
32 OBANK (II) = PLUS
II = II +1 HEDI1430
34 KDUM = LTABLE(KK, K, 1) HEDI1440
IBANK(II) = TBLMS(KDUM) * RSCALE + 0.5 HEDI1450
II = II + 1 HEDI1460
IF (LTABLE(KK, K, 1) - 20 ) 35, 36, 36 HEDI1470
35 OBANK(II) = PARENL
OBANK(II+3) = PARENR
GO TO 37
36 OBANK(II) = ASTERK
OBANK(II+3) = ASTERK
37 CALL NTOL(1, OBANK(II+1), K)
CALL NTOL(1, OBANK(II+2), LTABLE(KK, K, 2))
II = II + 4
40 CONTINUE HEDI1640
II = II - 1 HEDI1650
WRITE (NOT,9040)( IBANK(KK), KK = 1, II )
9040 FORMAT (1H0,2X,A3,A4,5X,2A1,5X,I5,4A1,A3,A4,3H =,8(I5,4A1,A2))
100 CONTINUE HEDI1680
WRITE (NOT,9008)
NSFL = 0 HEDI1720
DO 104 K = 1, 20 HEDI1730
IF(ITABLE(5, K)) 104, 104, 102 HEDI1740
102 NSFL = NSFL + 1 HEDI1750
IBANK(1) = ITABLE(5, K) / 10 HEDI1760
IDUM = ITABLE(5, K) + 1 HEDI1770
IEND = IDUM + 9 HEDI1780
II = 2 HEDI1790
DO 103 KK = IDUM, IEND HEDI1800
IF (AD(KK)) 1021, 103, 1021 HEDI1810
1021 OBANK(II) = AD(KK) HEDI1820
IBANK(II+1) = KK - IDUM
OBANK(II+2) = PLUS
II = II + 3
103 CONTINUE HEDI1920
II = II - 2
IF (II) 104, 1032, 1034
1032 WRITE (NOT,9103) IBANK(1)
GO TO 104
1034 WRITE (NOT,9103)(IBANK(KK),OBANK(KK+1),IBANK(KK+2), KK=1,II,3)
9103 FORMAT(7H0 DIS I3, 3H = 7(F7.2, 6H(COS** I1, 1H) A2))
104 CONTINUE HEDI1990
C FERMI ADDITIONS HEDI2000
DO 210 K = 1, 20 HEDI2010
IF (RTABLE(9, K, 2)) 201, 210, 201 HEDI2020
201 NSFL = NSFL + 1 HEDI2030
CALL NTOL (1, AA, K) HEDI2040
WRITE (NOT,9201)AA, RTABLE(9,K,2) HEDI2050
9201 FORMAT (8H0VERTEX A2, 25H HAS A FERMI MOMENTUM OF F9.3, 5H MAX)HEDI2060
210 CONTINUE HEDI2070
IF (NSFL) 1045, 1045, 1041 HEDI2080
1041 WRITE (NOT,9008)
1045 CONTINUE HEDI2120
NRT = 0 HEDI2130
IF (LISTW) 112, 112, 105 HEDI2140
C WEIGHT REQUEST PRINT OUT HEDI2150
105 KK = LISTW + 1 HEDI2160
OBANK(1) = HLIST(LISTW) HEDI2180
CALL GENFUN (LISTW,-1) HEDI2190
DO 1051 K=1,3
1051 OBANK(K+1) = VAL(K)
DO 106 K=5,7
OBANK(K) = HLIST(KK) HEDI2230
106 KK = KK + 1 HEDI2240
MO = KLIST(KK) HEDI2250
J = 7
NRT = 1 HEDI2270
IF (MO) 110, 110, 1062 HEDI2280
1062 MB = LISTW + 5 HEDI2290
ME = MB + MO - 1 HEDI2300
107 CONTINUE HEDI2310
DO 108 MM = MB, ME HEDI2320
J = J + 2
KC = KLIST(MM) HEDI2340
CALL NTOL(2, OBANK(J-1), JTABLE(6,KC))
108 CONTINUE HEDI2430
GO TO (110, 116), NRT HEDI2440
110 WRITE (NOT,9110)(IBANK(MM), MM=1,5),(OBANK(MM), MM=6,J)
C CHANGE 3A4 TO 3A5 IN NEXT STATEMENT FOR PDP-10
9110 FORMAT(20H0WEIGHTING FUNCTION I2, 1X 3A5, 13H. PARAMETERS HEDI2460
1I4, 2(2H, F9.4), 2X 9HTRACKS 6(2A1,4X)/(61X,10(2A1,4X)))
112 IF (LISTG) 1161, 1161, 114 HEDI2480
C EXPERIMENTAL FACILITY REQUEST PRINT OUT HEDI2490
114 OBANK(1) = HLIST(LISTG) HEDI2510
CALL GENFUN (LISTG,-1) HEDI2520
DO 1141 K=1,3
1141 OBANK(K+1) = VAL(K)
IBANK(5) = NTAPE
OBANK(6) = HLIST(LISTG+1)
OBANK(7) = HLIST(LISTG+2)
J = 7
MO = KLIST(LISTG + 3) HEDI2590
NRT = 2 HEDI2600
IF (MO) 116, 116, 115 HEDI2610
115 MB = LISTG + 4 HEDI2620
ME = MB + MO - 1 HEDI2630
GO TO 107 HEDI2640
116 WRITE (NOT,9118)(IBANK(MM), MM=1,5),(OBANK(MM), MM=6,J)
C CHANGE 3A4 TO 3A5 IN NEXT STATEMENT FOR PDP-10
9118 FORMAT(23H0EXPERIMENTAL FUNCTION I2, 2X 3A5, 10H. TAPE NO. HEDI2660
1I3, 12H PARAMETERS 2F9.0,2X 9HTRACKS 6(2A1,4X)/
2(61X,10(2A1,4X)))
1161 IF (NRT) 118, 118, 1162 HEDI2680
1162 WRITE (NOT,9008)
118 WRITE (NOT,9100)
9100 FORMAT ( 47H THE FOLLOWING HISTOGRAMS HAVE BEEN REQUESTED / 1H HEDI2760
1 48(1H-))
KH = 0 HEDI2780
DO 150 K = 1, 100 HEDI2790
IF (KTABLE(1,K)) 150, 121, 130 HEDI2800
130 IF (KTABLE(1,K) - 1000) 135, 140, 140 HEDI2810
135 KH = KH + 1 HEDI2820
CALL HISCAP (KH,K) HEDI2830
GO TO 150 HEDI2840
140 IF (KTABLE(1,K) - 2000) 142, 146, 146 HEDI2850
142 KX = K HEDI2860
GO TO 150 HEDI2870
146 KH = KH + 1 HEDI2880
WRITE (NOT,9146)KH HEDI2890
9146 FORMAT (3H0NO I4, 25H TWO DIMENSIONAL PLOT OF ) HEDI2900
CALL HISCAP (0,KX) HEDI2910
CALL HISCAP (0,K) HEDI2920
150 CONTINUE HEDI2930
121 WRITE (NOT,9008) 8/17/68
IF (IRNDM) 123, 123, 122 8/17/68
122 WRITE (NOT,9300) IRNDM 8/17/68
9300 FORMAT ('0THE STARTING VALUE OF RANDOM WAS SET = ' I10) 8/17/68
123 RETURN 8/17/68
END HEDI2960
SUBROUTINE HISCAP (KH, K)
CHISCAP*2 SUBROUTINE FOR HISTOGRAM CAPTION PRINT-OUT -- ALSO LISTS ALL
C CARD PARAMETERS -- EXTRA CARD PARAMETER VERSION
C K IS HISTOGRAM NUMBER HISC0030
C EXTENSIVE CHANGES MADE FOR PDP-10 LDK 12/69
C ************************ COMMON COMMON ***************************
COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
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 KTABLE(7,100), OBANK(90)
DIMENSION PARA(1000),NPARA(1000),SNAME(1000),TABLE(100)
DIMENSION HEAD(11), NBRNCH(10),HTABLE(7,100)
DIMENSION HLIST(500)
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 (KTABLE,MAP), (OBANK,MAP(1779)) HISC0360
EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)),
1 (NTAPE,MAP(1988)), (EINC,MAP(1998)),
2 (PINC,MAP(1999)), (BINC,MAP(2000))
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 (LTAPE,NBRNCH(9)), (LINK,NBRNCH(10)), (HTABLE,MAP)
EQUIVALENCE (HLIST,KLIST)
C ************************* END OF C, D, E STATEMENTS **************HISC0340
DIMENSION FMT(70), F1(3),F2(3),F3(8),F4(4),F5(5),F6(8)
DATA F1/'(3H0NOI4,4H OF '/
DATA F2/'(11X,3A5, 3X '/
DATA F3/'3H ( 3H ) 1H, I6, F7.3,E13.6, /26X '/
DATA F4/'3A5,2A1,2(2A5,2X), '/
DATA F5/'(2A1,4X)/(71X10(2A1,4X)))'/
DATA F6/'(9X12HIF FUNCTION 3A5,1X ) 6H OF '/
EQUIVALENCE (BLANKS,F6(8))
DIMENSION CMS(10), WGHTED(2), TRKLST(2)
DATA CMS/'IN THE LABORATOR Y E CMS OF IN CMS AT VERT '/
DATA WGHTED/' ,WEIGHTED'/, TRKLST/'TRACK LIST'/
C HISC0370
NRT = 1
NBR = 1 HISC0380
IF (KH .LE. 0) NBR = 2
KK = MOD(KTABLE(1,K), 1000) HISC0420
MC = IABS(KTABLE(4,K)) HISC0430
IQFLAG = 1
IF (KTABLE(4,K)) 31, 32, 32
31 IDOWN = MOD(MC,1000)
MC = MC/1000
IQFLAG = 2
32 IF (KK - 100) 95, 70, 70
70 KK = KK - 90 HISC0450
MC = MC + 1 HISC0460
95 MO = KLIST(MC) HISC0470
ML = MC + 1 HISC0480
ME = MC + MO HISC0490
ICMS = ME
IF (KK .GT. 10) ME = ME-1
CALL NAME (K, OBANK(1)) HISC0500
IK = 4
GO TO (110,96), IQFLAG
C STORE CARD PARAMETERS IN OBANK
96 IDOWN = MC + IDOWN
IUP = ME
ME = IDOWN - 1 12/28/67
DO 98 IJ = IDOWN,IUP
OBANK(IK) = HLIST(IJ)
98 IK = IK + 1
110 OBANK(IK) = CMS(1)
IF (KK - 10) 111, 111, 115 HISC0510
C LABORATORY PLOT HISC0520
111 DO 112 I=2,5
IJ = IK+I-1
112 OBANK(IJ) = CMS(I)
GO TO 135 HISC0590
115 IF (KK - 20) 117, 117, 118 HISC0600
C PARTICLE REST FRAME PLOT HISC0610
117 OBANK(IK+1) = CMS(6)
OBANK(IK+2) = CMS(7)
C GET TRACK NAME HISC0660
KC = KLIST(ICMS)
IF (KC) 135, 135, 1173
1173 CALL NTOL(2, OBANK(IK+3), JTABLE(6,KC))
GO TO 135 HISC0810
C NORMAL CMS PLOT HISC0820
118 OBANK(IK) = CMS(8)
OBANK(IK+1) = CMS(9)
OBANK(IK+2) = CMS(10)
OBANK(IK+3) = BLANKS
C GET VERTEX NAME HISC0860
120 KC = KLIST(ICMS)
IF (KC) 135, 135, 128
128 CALL NTOL(1, OBANK(IK+4), JTABLE(7,KC))
135 IK = IK + 5
C CHECK FOR WEIGHT REQUEST HISC1090
IF (KTABLE(5,K)) 140, 150, 150
140 OBANK(IK) = WGHTED(1)
IK = IK + 1
OBANK(IK) = WGHTED(2)
GO TO 160
150 OBANK(IK) = BLANKS
IK = IK + 1
OBANK(IK) = BLANKS
160 IK = IK + 1
IF (ME - ML) 180, 165, 165 HISC1270
165 OBANK(IK) = TRKLST(1)
IK = IK + 1
OBANK(IK) = TRKLST(2)
IK = IK + 1
DO 170 MM = ML,ME
KC = KLIST (MM) HISC1290
CALL NTOL(2, OBANK(IK), JTABLE(6,KC))
170 IK = IK+2
180 JE = IK-1
C COMPILE FORMAT ARRAY
190 FMT(1) = F2(1)
IK = 2
GO TO (200,210),NBR
200 DO 201 I=1,3
201 FMT(I) = F1(I)
IK = 4
210 FMT(IK) = F2(2)
IK = IK + 1
FMT(IK) = F2(3)
GO TO (270, 240),IQFLAG
240 NPOS = 104
C FORMAT CARD PARAMETERS
250 FMT(IK) = F3(1)
IK = IK+1
DO 260 IJ=IDOWN,IUP
251 IF (KLIST(IJ).GT.999999 .OR. KLIST(IJ).LT.-99999) GO TO 254
252 NPOS = NPOS -7 12/29/67
IF (NPOS) 257, 253, 253 12/29/67
253 FMT(IK) = F3(4)
GO TO 259 12/29/67
254 IF (HLIST(IJ).GE.999.9995 .OR. HLIST(IJ).LE.-99.9995 .OR.
1 ABS(HLIST(IJ)).LT.0.001) GO TO 2545
NPOS = NPOS - 8
IF (NPOS) 257, 255, 255 12/29/67
255 FMT(IK) = F3(5)
GO TO 259
2545 NPOS = NPOS-14
IF (NPOS) 257,256, 256 12/29/67
256 FMT(IK) = F3(7)
FMT(IK+1) = F3(8)
IK = IK+1
GO TO 259 12/29/67
257 FMT(IK) = F3(9)
NPOS = 104
IK = IK + 1 12/29/67
GO TO 251 12/29/67
259 FMT(IK+1) = F3(3)
260 IK = IK + 2
FMT(IK - 1) = F3(2)
269 GO TO (261,430),NRT
261 IF (NPOS-49) 264, 262, 262
262 L = (NPOS-43)/6
GO TO 280
264 FMT(IK) = F3(8)
270 IK = IK+1
L = 10
280 DO 284 I=1,4
FMT(IK) = F4(I)
284 IK = IK+1
FMT(IK) = BCDW(L)
IK = IK+1
DO 286 I=1,5
FMT(IK) = F5(I)
286 IK = IK+1
GO TO (298,292),NBR
292 WRITE (NOT,FMT) (OBANK(MM), MM =1,JE)
GO TO 299
298 WRITE (NOT,FMT) KH, (OBANK(MM),MM = 1,JE)
299 IF (KTABLE(3,K)) 300, 500, 300
C NOTE CONDITIONAL REQUEST HISC1480
300 NFK = IABS(KTABLE(3,K))
NRT = 2
IQFLAG = 1
IF (KTABLE(3,K)) 303,304,304
303 IDOWN = MOD(NFK,1000)
NFK = NFK/1000
IQFLAG = 2
304 NFN = KLIST(NFK) HISC1500
CALL GENFUN (NFK, -1) HISC1510
DO 305 I=1,3
305 OBANK(I) = VAL(I)
IK = 4
MO = KLIST(NFK + 1) HISC1520
ML = NFK + 2
ME = NFK + MO + 1
GO TO (340,320), IQFLAG
C PICK UP PARAMETERS
320 IDOWN = NFK + IDOWN + 1
IUP = ME
ME = IDOWN -1
DO 335 IJ = IDOWN, IUP
OBANK(IK) = HLIST(IJ)
335 IK = IK + 1
340 IF (ME-ML) 390, 350, 350
C PICK UP TRACK LABELS
350 DO 360 MM = ML,ME
KC = KLIST(MM)
CALL NTOL(2, OBANK(IK), JTABLE(6,KC))
360 IK = IK+2
C COMPILE FORMAT
390 JE = IK-1
420 DO 425 I=1,5
425 FMT(I) = F6(I)
IK = 6
NPOS = 93
GO TO (430,250), IQFLAG
430 IF (ME-ML) 435,440,440
435 FMT(IK) = F6(6)
GO TO 490
440 IF (NPOS-12) 450, 445, 445
445 L = NPOS/6 - 1
GO TO 460
450 FMT(IK) = F3(8)
IK = IK+1
L=15
460 FMT(IK) = F6(7)
FMT(IK+1) = F6(8)
FMT(IK+2) = BCDW(L)
IK = IK+3
DO 470 I=1,5
FMT(IK) = F5(I)
470 IK = IK+1
490 WRITE (NOT,FMT) (OBANK(MM),MM=1,JE)
500 RETURN
END
SUBROUTINE NAME (KK, OBANK)
CNAME RETURNS NAME OF HISTOGRAM KK IN OBANK(1-3)
C ************************* COMMON COMMON ************************** 0030
COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2)
DIMENSION ZMAP(2000) NBOD0110
DIMENSION REMARK(500)
DIMENSION PARA(1000),NPARA(1000),SNAME(1000),LNAME(1000)
DIMENSION KTABLE(7,100), OBANK(90), VAL(100) 0060
EQUIVALENCE (MAP,ZMAP) NBOD0340
EQUIVALENCE (REMARK,MAP(1001))
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,MAP), (VAL,MAP(1531)) 0160
EQUIVALENCE (PARA,NPARA,PARS),(SNAME,LNAME,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 STATEMENTS **************** 0140
DIMENSION HNAME(3,9)
DATA HNAME /'PROD. ANGLE MOMENTUM RELATIVE ANGLE INV
1ARIANT MASS PROD. COSINE RELATIVE COSINEMASS SQUARED KINETIC E
2NERGY TOTAL ENERGY '/
C 0170
KA = MOD(KTABLE(1,KK), 1000) 0180
IF (KA - 100) 80, 50, 50
50 IND = KTABLE(4,KK) 0200
IF (IND .LT. 0) IND = -IND/1000
CALL GENFUN (IND, -1) 0210
DO 60 I=1,3
60 OBANK(I) = VAL(I)
GO TO 100 0240
80 KC = MOD(KA, 10)
DO 90 I=1,3
90 OBANK(I) = HNAME(I,KC)
100 RETURN 0700
END 0710