perm filename CALC.F4[2,VDS]3 blob
sn#167653 filedate 1975-07-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00035 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 C MAIN PROGRAM -- "LOOK-UP"
C00016 00003 SUBROUTINE OUTPUT (PRINT)
C00026 00004 SUBROUTINE CONTRL (START, PRINT)
C00029 00005 SUBROUTINE UPDATE (START)
C00039 00006 SUBROUTINE MESAGE (ERR, RTRN)
C00046 00007 SUBROUTINE CLEAR
C00049 00008 SUBROUTINE RPAREN
C00053 00009 SUBROUTINE EQUAL
C00057 00010 SUBROUTINE SIGN
C00060 00011 SUBROUTINE FUNCTN (START)
C00064 00012 SUBROUTINE SEMI
C00067 00013 SUBROUTINE IMEDEX
C00070 00014 SUBROUTINE COLAPS (RTRN)
C00075 00015 SUBROUTINE COMBIN (A, NARGS, RTRN)
C00085 00016 SUBROUTINE ADD (X, K)
C00088 00017 SUBROUTINE ENTRY
C00091 00018 SUBROUTINE DIGIT
C00094 00019 SUBROUTINE ENTEXP
C00097 00020 SUBROUTINE CORECT (START)
C00101 00021 SUBROUTINE ADEXPD (RTRN)
C00104 00022 SUBROUTINE RECALL (START)
C00107 00023 SUBROUTINE STORE (START)
C00114 00024 SUBROUTINE SCR (START)
C00117 00025 SUBROUTINE LSTKEY
C00120 00026 SUBROUTINE FLAG (START)
C00122 00027 SUBROUTINE SETUP (RTRN)
C00125 00028 SUBROUTINE ENTRUP
C00128 00029 SUBROUTINE NUMBER (START, RTRN)
C00131 00030 SUBROUTINE FINDN (START, RTRN)
C00134 00031 SUBROUTINE REG (RTRN)
C00138 00032 SUBROUTINE RANGE (RTRN)
C00141 00033 SUBROUTINE ARGMNT (START)
C00147 00034 SUBROUTINE ROUND
C00150 00035 SUBROUTINE FDIGIT (START, RTRN)
C00153 ENDMK
C⊗;
C MAIN PROGRAM -- "LOOK-UP"
C DATE OF LAST CHANGE - 750104
IMPLICIT INTEGER (A-Z)
LOGICAL START, NEXT, FIXFLG, TRUE
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
10 DO 20 II=2,21
DO 20 JJ=1,17
IF (JJ.LT.12) UFLAG(JJ)=0
20 R(II,JJ)=15
R(21,2)=1
R(21,3)=5
DO 30 II=4,16
30 R(21,II)=0
R(21,17)=1
C
C REGISTERS ARE ALLOCATED AS FOLLOWS: R(1)="PI", R(2)="A",
C R(3)="LST X", R(4)="LST Y", R(5)="R0", ..., R(20)="R15",
C R(21)="HIGHEST REG NUMBER AVAILABLE"
C
C ** CONTROL PARAMETERS
C
C SKIP = OUTPUT CONTROL (0 -> FULL STACK, 1 -> SHORT STACK,
C 2 -> DISPLAY, 3 -> DISPLAY & REGISTERS)
C FIXFLG = "DISPLAY" CONTROL (T -> "FIX" MODE)
C FIX = NUMBER OF DECIMAL DIGITS IN "FIX" MODE (0-9)
C SCI = NUMBER OF DIGITS IN "SCI" MODE (1-10)
C SMAX = NUMBER OF REGISTERS IN THE "STACK"
C
SKIP=3
FIXFLG=.TRUE.
FIX=2
SCI=5
SMAX=7
C
TYPE 1000
ACCEPT 1600, START
IF (START) GO TO 50
TYPE 1100
ACCEPT 1700, SKIP
TYPE 1200
ACCEPT 1600, START
IF (START) GO TO 40
TYPE 1300
ACCEPT 1600, FIXFLG
TYPE 1400
ACCEPT 1800, FIX, SCI
SCI=SCI+1
40 TYPE 1500
ACCEPT 1700, SMAX
C CONSIDER 100 TEST EQUATIONS
50 DO 340 TEST=1,100
ERROR=0
CODE=-1
OLD=1
DO 60 II=1,50
60 EXPR(II)=15
CALL CLEAR
TYPE 1900, TEST
CALL OUTPUT (-1)
KEY=0
C OUTPUT CURRENT INFO & OBTAIN NEXT KEY-CODE
70 CALL CONTRL (1, SKIP)
C DECODE KEY-CODE
IF (NEXT) NEXT=.FALSE.
IF (CODE.LE.12) GO TO 80
IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 90
IF (CODE.EQ.15) GO TO 330
IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 100
IF (CODE.EQ.18) GO TO 110
IF (CODE.EQ.20) GO TO 120
IF (CODE.EQ.22) GO TO 130
IF (CODE.GT.22 .AND. CODE.LT.25 .OR.
* CODE.EQ.38 .OR. CODE.EQ.39) GO TO 170
IF (CODE.EQ.25) GO TO 180
IF (CODE.EQ.26) GO TO 190
IF (CODE.EQ.27) GO TO 200
IF (CODE.EQ.28) GO TO 210
IF (CODE.EQ.29) GO TO 220
IF (CODE.EQ.31) GO TO 230
IF (CODE.EQ.32) GO TO 240
IF (CODE.EQ.33) GO TO 250
IF (CODE.EQ.34) GO TO 260
IF (CODE.EQ.35) GO TO 270
IF (CODE.EQ.36) GO TO 280
IF (CODE.EQ.37) GO TO 290
IF (CODE.GT.39 .AND. CODE.LT.44) GO TO 100
IF (CODE.EQ.44 .OR. CODE.EQ.45) GO TO 140
IF (CODE.EQ.46 .OR. CODE.EQ.47) GO TO 150
IF (CODE.EQ.48) GO TO 160
C- IF (CODE.EQ.49) GO TO ???
IF (CODE.EQ.50) GO TO 300
IF (CODE.EQ.51) GO TO 310
IF (CODE.EQ.52) GO TO 320
C KEY-CODE ERROR?
IF (CODE.EQ.99) GO TO 10
CALL MESAGE (81, RTRN)
GO TO 330
C CALL KEY ROUTINE
80 CALL ENTRY
GO TO 330
90 CALL SIGN
GO TO 330
100 CALL OPRATR
GO TO 330
110 CALL LPAREN
GO TO 330
120 CALL RPAREN
GO TO 330
130 CALL EQUAL
GO TO 330
140 CALL FUNCTN (1)
GO TO 330
150 CALL FUNCTN (3)
GO TO 330
160 CALL FUNCTN (4)
GO TO 330
170 CALL RECALL (1)
GO TO 330
180 CALL RECALL (2)
GO TO 330
190 CALL CLEAR
GO TO 340
200 CALL CLEARX (2)
GO TO 330
210 CALL CORECT (2)
GO TO 330
220 CALL DRPSTK
GO TO 330
230 CALL STORE (1)
GO TO 330
240 CALL FIXN
GO TO 330
250 CALL SCIN
GO TO 330
260 CALL IMEDEX
GO TO 330
270 CALL EXCH
GO TO 330
280 CALL SEMI
GO TO 330
290 CALL COMMA
GO TO 330
300 CALL SCR (1)
GO TO 330
310 CALL FLAG (1)
GO TO 330
320 CALL KYMODE (0)
C GO BACK AND GET ANOTHER KEY-STROKE, MAYBE
330 IF (KEY.LT.50) GO TO 70
340 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' PRODUCE "DISPLAY & REGISTERS" OUTPUT'
* /' DISPLAY IN FIX MODE W/ FIX=2 & SCI=4'
* /' USE A 7 LEVEL "STACK"'
* //' THESE ARE OKAY. ("T" OR "F")'/)
1100 FORMAT (/' ENTER CODE FOR DESIRED OUTPUT: 0 = LONG STACK'
* /33X,'1 = SHORT STACK'/33X,'2 = DISPLAY ONLY'
* /33X,'3 = DISPLAY (& REGISTERS)'/)
1200 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' ("T" OR "F")'/)
1300 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. ("T"/"F")'/)
1400 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. ("N <SP> M")'/)
1500 FORMAT (/' ENTER NUMBER OF STACK REGISTERS WANTED (MAX = 7)'/)
1600 FORMAT (L1)
1700 FORMAT (I)
1800 FORMAT (2I)
1900 FORMAT ('1 TEST NO.',I3/)
END
BLOCK DATA
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, STEP
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA NEXT /.FALSE./, STEP /.FALSE./, UFLAG /11*0/,
* PGMPTR /0/, W /17*0/, LFRC /0/, TEMP/0/,
* R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8),
* R(1,9),R(1,10),R(1,11),R(1,12),R(1,13),R(1,14),R(1,15),
* R(1,16),R(1,17) /15,3,1,4,1,5,9,2,6,5,3,5,9,0,15,0,0/
END
SUBROUTINE OUTPUT (PRINT)
C DATE OF LAST CHANGE - 741118
IMPLICIT INTEGER (A-Z)
DIMENSION CHAR(56), STROKE(50), SIGN(7), ESN(7), REG(17),
* DISP(32), DISP2(16)
LOGICAL EEX, DP, FIXFLG, STEP
REAL*8 NAME(3)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
2 /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
3 /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
4 /OUTPT/ SKIP, DISPLY(32), PGMPTR
5 /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
2 CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
3 CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .',' E'/,
4 CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +',' ',' /'/,
5 CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
6 CHAR(21),CHAR(22),CHAR(23),CHAR(24)/' O',' =',' A','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CD','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/'DS','LK','->','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SI','IX','XC',' ;'/,
A CHAR(37),CHAR(38),CHAR(39),CHAR(40)/' ,','LX','LY','=?'/,
B CHAR(41),CHAR(42),CHAR(43),CHAR(44)/' ≠',' >',' <','MG'/,
C CHAR(45),CHAR(46),CHAR(47),CHAR(48)/'AG','AB','SR','↑2'/,
D CHAR(49),CHAR(50),CHAR(51),CHAR(52)/' %','SC','FL','KL'/,
E CHAR(53),CHAR(54),CHAR(55),CHAR(56)/'XX','XX','XX','XX'/
DATA NAME /' A =', 'LAST X =','LAST Y ='/
C VARIOUS VALUES OF "SKIP" GIVE: -1 → CLEAR EXPRESSION
C 0 → LONG OUTPUT
C 1 → SHORT OUTPUT
C 2 → DISPLAY ONLY
C 3 → DISPLAY (& REGISTERS)
C
C IF "PRINT" < "SKIP", SET "SKIP2" TO "PRINT"
SKIP2=SKIP
IF (PRINT.LT.SKIP) SKIP2=PRINT
IF (SKIP2.GE.0) GO TO 20
DO 10 II=1,50
10 STROKE(II)=CHAR(15)
RETURN
20 DO 30 II=OLD,KEY
JJ=EXPR(II)
IF (JJ.EQ.0) JJ=10
30 STROKE(II)=CHAR(JJ)
TYPE 1000, (STROKE(II),II=1,KEY)
OLD=KEY+1
IF (SKIP2.EQ.2) GO TO 50
KK=SMAX
IF (SKIP2.EQ.1) KK=2
DO 40 II=1,KK
JJ=X(II,1)
IF (JJ.EQ.0) JJ=10
SIGN(II)=CHAR(JJ)
JJ=X(II,15)
IF (JJ.EQ.0) JJ=10
IF (JJ.EQ.12) JJ=42
40 ESN(II)=CHAR(JJ)
50 DO 60 II=1,32
JJ=DISPLY(II)
IF (JJ.EQ.0) JJ=10
60 DISP(II)=CHAR(JJ)
DO 70 II=1,16
JJ=DSP(II)
IF (JJ.EQ.0) JJ=10
70 DISP2(II)=CHAR(JJ)
IF (SKIP2.GT.1) GO TO 100
IF (SKIP2.EQ.1) GO TO 90
TYPE 1100, DP, L, EEX, M, FIXFLG, FIX, NEXT, SCI, STEP, ERROR
IF (SMAX.LT.3) GO TO 90
TYPE 1200, SMAX, P(SMAX), SIGN(SMAX), (X(SMAX,NN),NN=2,14),
2 ESN(SMAX), X(SMAX,16), X(SMAX,17), OP(SMAX)
IF (SMAX.EQ.3) GO TO 90
JJ=SMAX-3
DO 80 II=1,JJ
KK=SMAX-II
80 TYPE 1300, KK, P(KK), SIGN(KK), (X(KK,NN),NN=2,14),
2 ESN(KK), X(KK,16), X(KK,17), OP(KK)
90 TYPE 1400, P(2), SIGN(2), (X(2,NN), NN=2,14), ESN(2), X(2,16),
2 X(2,17), OP(2), P(1), SIGN(1), (X(1,NN), NN=2,14),
3 ESN(1), X(1,16), X(1,17), OP(1)
IF (SKIP2.EQ.0) TYPE 1500, DISP
100 TYPE 1600, DISP2
IF (SKIP2.EQ.2) RETURN
DO 120 II=2,4
IF (R(II,2).EQ.15) GO TO 120
DO 110 JJ=1,17
KK=R(II,JJ)
IF (KK.EQ.0) KK=10
IF (KK.EQ.12) KK=42
110 REG(JJ)=CHAR(KK)
TYPE 1700, NAME(II-1), (REG(NN), NN=1,17)
120 CONTINUE
DO 140 II=5,20
IF (R(II,2).EQ.15) GO TO 140
JJ=II-5
DO 130 KK=1,17
LL=R(II,KK)
IF (LL.EQ.0) LL=10
IF (LL.EQ.12) LL=42
130 REG(KK)=CHAR(LL)
TYPE 1800, JJ, (REG(NN), NN=1,17)
140 CONTINUE
DO 150 II=1,11
IF (UFLAG(II).EQ.1) GO TO 160
150 CONTINUE
RETURN
160 TYPE 1900, UFLAG
RETURN
1000 FORMAT (/6X, 'EXPRESSION: ', 21A3, (/18X, 21A3))
1100 FORMAT (//14X,'FLAGS: DP -',L2,20X,'INDICES: L -',
2 I2/22X,'EEX -',L2,30X,'M -',I2/22X,'FIXFLG-',
3 L2,30X,'FIX -',I2/22X,'NEXT -',L2,30X,'SCI -',
4 I2/22X,'STEP -',L2,30X,'ERROR -',I2)
1200 FORMAT (//14X, 'STACK: S(', I2, ') -', 4X, I2, ' / ', A2,
2 I2, ' .', 12I2, A2, 2I2, ' /', I3)
1300 FORMAT (22X, 'S(', I2, ') -', 4X, I2, ' / ', A2, I2, ' .',
2 12I2, A2, 2I2, ' /', I3)
1400 FORMAT (/22X, 'S( 2) -', 4X, I2, ' / ', A2, I2, ' .', 12I2,
2 A2, 2I2, ' /', I3/22X, 'S( 1) -', 4X, I2, ' / ',
3 A2, I2, ' .', 12I2, A2, 2I2, ' /', I3/)
1500 FORMAT (2(/14X, 'DISPLAY:', 9X, 16A2/)//)
1600 FORMAT (/14X, 'DISPLAY:', 9X, 16A2///)
1700 FORMAT (15X, A8, 1X, 2A2, ' .', 15A2)
1800 FORMAT (14X, 'REG(', I2, ') =', 1X, 2A2, ' .', 15A2)
1900 FORMAT (/14X, 'USER FLAGS:', 6X, I2, 2X, 5I2, 2X, 4I2, I4/)
END
SUBROUTINE CONTRL (START, PRINT)
C DATE OF LAST CHANGE - 750318
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
IF (NEXT) RETURN
GO TO (1, 2, 3, 6, 6), START
C ** START 1 - UPDATE & FORMAT "DISPLAY"
1 CALL UPDATE (1)
GO TO 5
C ** START 2 - FORMAT "DISPLAY"
2 CALL UPDATE (2)
GO TO 5
C ** START 3 - DASHES → "DISPLAY"
3 DO 4 I=1,16
4 DSP(I)=13
DSP(8)=0
DSP(9)=CODE/10
DSP(10)=CODE-10*DSP(9)
5 CALL KYMODE (1)
C ** START 4 - USE "DISPLAY" AS IS
6 CALL OUTIN (PRINT)
IF (CODE.NE.30) GO TO 7
CALL LSTKEY
IF (.NOT.NEXT) GO TO 6
NEXT=.FALSE.
7 RETURN
END
SUBROUTINE OUTIN (PRINT)
C DATE OF LAST CHANGE - 750312
IMPLICIT INTEGER (A-Z)
COMMON /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
CALL OUTPUT (PRINT)
LSTK=CODE
1 TYPE 4
ACCEPT 5, CODE
IF (CODE.NE.100) GO TO 2
CALL OUTPUT (0)
GO TO 1
2 KEY=KEY+1
IF (KEY.LT.51) GO TO 3
KEY=1
OLD=1
CALL OUTPUT (-1)
3 EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
PGMPTR=PGMPTR+1
RETURN
4 FORMAT (' ?'/)
5 FORMAT (I)
END
SUBROUTINE UPDATE (START)
C DATE OF LAST CHANGE - 750124
C PURPOSE: 1 - COPY X(1) TO D USING CURRENT DISPLAY FORMAT
C (W CONTAINS X(1) ROUNDED TO RIGHT NO. OF DIGITS)
C 2A - COPY D TO DSP INSERTING SPACING BLANKS
C 2B - COPY DSP TO DSP RIGHT JUSTIFYING MANTISSA
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG, STEP
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (START.EQ.2) GO TO 19
C ** START1 - UPDATE DISPLAY CONTENTS
D(1)=X(1,1)
IF (OP(1).GE.70) GO TO 19
IF (.NOT.FIXFLG) GO TO 9
C DISPLAY IN "FIX" FORMAT, IF POSSIBLE
IF (X(1,16).GT.0 .AND. X(1,15).NE.13) GO TO 9
N=FIX
K=FIX+1
KMAX=10*X(1,16)+X(1,17)
IF (X(1,15).NE.13) GO TO 1
K=K-KMAX
IF (K.LT.0) GO TO 4
GO TO 2
1 K=K+KMAX
IF (K.LE.10) GO TO 2
N=9-KMAX
K=10
2 CALL ROUND
IF (W(16).GT.0 .AND. W(15).NE.13) GO TO 9
K=10*W(16)+W(17)+1
IF (W(15).EQ.13) GO TO 5
DO 3 I=1,K
3 D(I+1)=W(I+1)
J=K
K=K+1
KMAX=K+N
D(K+1)=11
GO TO 7
4 K=N+2
5 D(2)=0
D(3)=11
DO 6 I=3,K
6 D(I+1)=0
J=0
KMAX=N+2
7 K=K+1
IF (K.GT.KMAX) GO TO 8
J=J+1
D(K+1)=W(J+1)
GO TO 7
8 KMAX=15
GO TO 15
C DISPLAY IN "SCI" FORMAT
9 IF (.NOT.STEP) GO TO 10
IF (SCI.LT.7) GO TO 10
N=6
GO TO 11
10 N=SCI
11 K=N
CALL ROUND
D(2)=W(2)
D(3)=11
IF (W(15).NE.12) GO TO 12
IF (.NOT.STEP) N=10
IF (STEP) N=6
W(15)=15
12 DO 13 I=2,N
13 D(I+2)=W(I+1)
D(13)=12
DO 14 I=13,15
14 D(I+1)=W(I+2)
K=N+2
IF (K.GT.11) GO TO 17
KMAX=11
15 DO 16 I=K,KMAX
16 D(I+1)=15
C X(0) ≡ 0 ?
17 IF (X(1,2).NE.0) GO TO 19
DO 18 I=2,12
IF (D(I).NE.11) GO TO 18
D(I)=15
GO TO 19
18 CONTINUE
C ** START 2 - FORMAT DISPLAY CONTENTS
19 DO 20 II=1,16
DSP(II)=15
20 DISPLY(II)=D(II)
DSP(1)=D(1)
C DISPLAY FUNCTION?
IF (OP(1).LT.70) GO TO 21
DSP(3)=11
DSP(4)=0
DSP(5)=X(1,2)/10
DSP(6)=X(1,2)-10*DSP(5)
DSP(7)=11
IF (X(1,3).EQ.X(1,4)) GO TO 35
DSP(8)=X(1,3)
DSP(9)=13
DSP(10)=X(1,4)
DSP(11)=11
GO TO 35
C X(0) = "NULL" ?
21 IF (X(1,2).NE.15) GO TO 22
IF (M.EQ.1) GO TO 35
C DISPLAY PROGRAM POINTER?
22 IF (STEP) GO TO 32
C COPY D TO DSP, INSERTING SPACING BLANKS
I=1
K=0
J=0
N=0
23 N=N+1
IF (D(N+1).GT.9) GO TO 24
K=K+1
IF (K.NE.3) GO TO 23
K=0
J=J+1
GO TO 23
24 N=1
25 IF (K.EQ.0) GO TO 27
IF (D(N+1).GT.11) GO TO 30
26 IF (I.GT.15) GO TO 32
DSP(I+1)=D(N+1)
I=I+1
N=N+1
K=K-1
GO TO 25
27 IF (J.EQ.0) GO TO 29
IF (I.EQ.1) GO TO 28
DSP(I+1)=15
I=I+1
28 K=3
J=J-1
GO TO 25
29 IF (D(N+1).EQ.12) GO TO 31
K=4
J=10
GO TO 26
30 IF (D(13).NE.12) GO TO 35
31 K=13
IF (I.LT.13) GO TO 33
32 K=1
33 DO 34 II=K,16
34 DSP(II)=D(II)
IF (DSP(13).NE.12) GO TO 35
IF (DSP(15).NE.0) GO TO 35
DSP(15)=DSP(16)
DSP(16)=15
C
35 DO 36 II=1,16
36 DISPLY(II+16)=DSP(II)
C
C COPY DSP TO DSP, RIGHT JUSTIFYING MANTISSA
K=11
37 IF (DSP(K+1).NE.15) GO TO 38
K=K-1
IF (K.GE.0) GO TO 37
RETURN
38 IF (.NOT.STEP) GO TO 40
IF (DSP(13).NE.12) GO TO 39
N=11
GO TO 41
39 N=15
GO TO 41
40 IF (K.GT.9) RETURN
N=10
41 DSP(N+1)=DSP(K+1)
N=N-1
IF (K.EQ.0) GO TO 42
K=K-1
GO TO 41
42 N=N+1
DO 43 I=1,N
43 DSP(I)=15
RETURN
END
SUBROUTINE MESAGE (ERR, RTRN)
C DATE OF LAST CHANGE - 750706
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, RUNPGM, TEMPF2
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA RUNPGM /.FALSE./
RTRN=0
GO TO (1, 1, 2, 1, 3, 4, 4, 6), ERR
C ERRORS 1, 2, 4, 9, ...
1 TEMP=0
GO TO 8
C ERROR 3
2 IF (CODE.EQ.28) GO TO 20
IF (CODE.EQ.27) GO TO 20
IF (CODE.EQ.26) GO TO 19
TEMP=1
GO TO 8
C ERROR 5
3 TEMPF2=NEXT
GO TO 5
C ERRORS 6 & 7
4 TEMPF2=.FALSE.
5 TEMP=2
GO TO 7
C ERROR 8
6 TEMPF2=.FALSE.
TEMP=3
7 UFLAG(11)=1
IF (UFLAG(10).EQ.1) RETURN
C DISPLAY ERROR
8 ERROR=ERR
NEXT= .FALSE.
DO 9 I=1,16
9 DSP(I)=13
C KEYBOARD ERROR MESSAGE → "DSP"
DO 10 I=4,13
10 DSP(I)=15
DSP(5)=12
DO 11 I=6,9
11 DSP(I)=25
DSP(8)=21
DSP(11)=ERROR/10
DSP(12)=ERROR-10*DSP(11)
IF (ERROR.NE.7) GO TO 12
IF (X(1,15).EQ.13) GO TO 12
DSP(13)=21
DSP(14)=15
C MODIFY MESSAGE FOR PROGRAM ERROR, MAYBE
12 IF (RUNPGM) GO TO 13
IF (.NOT.STEP) GO TO 15
13 J=12
K=15
14 DSP(K+1)=DSP(J+1)
J=J-1
K=K-1
IF (J.GT.1) GO TO 14
DSP(5)=15
CALL KYMODE (2)
15 ERROR=0
C LOOK FOR AND ACT ACCORDING TO USER'S RESPONSE
I=LSTK
J=CODE
16 CALL CONTRL (5, 2)
IF (CODE.NE.27) GO TO 18
CODE=I
IF (TEMP.EQ.0) RETURN
IF (TEMP.EQ.1) GO TO 17
CODE=J
NEXT=TEMPF2
RETURN
17 CODE=-1
GO TO 20
18 IF (CODE.NE.28) GO TO 19
CODE=I
IF (TEMP.EQ.2) GO TO 17
IF (TEMP.EQ.3) TEMPF=.TRUE.
RETURN
19 IF (CODE.NE.26) GO TO 16
NEXT=.TRUE.
20 RTRN=1
RETURN
END
SUBROUTINE RESET
C DATE OF LAST CHANGE - 741024
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
L=1
M=1
DP=.FALSE.
EEX=.FALSE.
RETURN
END
SUBROUTINE FIXN
C DATE OF LAST CHANGE - 741108
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.TRUE.
CALL NUMBER (1, RTRN)
IF (RTRN.EQ.1) GO TO 1
FIX=W(2)
1 RETURN
END
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 741108
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.FALSE.
CALL NUMBER (1, RTRN)
IF (RTRN.EQ.1) GO TO 1
SCI=W(2)+1
1 RETURN
END
SUBROUTINE CLEAR
C DATE OF LAST CHANGE - 740920
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
CALL CLEARX (1)
DO 1 I=2,SMAX
J=I-1
P(I)=P(J)
OP(I)=OP(J)
DO 1 K=1,17
1 X(I,K)=X(J,K)
RETURN
END
SUBROUTINE LPAREN
C DATE OF LAST CHANGE - 750616
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
TEMPF=.FALSE.
IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).EQ.13) GO TO 1
IF (P(1).NE.7) GO TO 3
CALL MESAGE (9, RTRN)
RETURN
1 CALL TESTUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
X(1,2)=1
TEMPF=.TRUE.
2 CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
IF (.NOT.TEMPF) GO TO 3
IF (OP(2).EQ.50) OP(2)=51
3 P(1)=P(1)+1
4 RETURN
END
SUBROUTINE RPAREN
C DATE OF LAST CHANGE - 750616
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (OP(1).LT.2) GO TO 2
1 CALL MESAGE (1, RTRN)
RETURN
2 DO 3 I=1,SMAX
IF (P(I).NE.0) GO TO 4
3 CONTINUE
CALL MESAGE (2, RTRN)
RETURN
4 IF (P(I).NE.1) GO TO 7
IF (OP(I+1).LT.72) GO TO 7
K=1
IF (I.EQ.1) GO TO 6
J=I
5 IF (OP(J).NE.10) GO TO 6
K=K+1
J=J-1
IF (J.NE.1) GO TO 5
6 IF (X(I+1,3).LE.K) GO TO 7
CALL MESAGE (10, RTRN)
RETURN
7 IF (P(1).NE.0) GO TO 10
IF (X(1,2).EQ.15) GO TO 1
IF (OP(2).EQ.10) GO TO 8
PTR=2
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 13
GO TO 7
8 DO 9 I=3,SMAX
IF (OP(I).LT.72) GO TO 9
PTR=I
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 13
RETURN
9 CONTINUE
GO TO 1
10 P(1)=P(1)-1
IF (P(1).NE.0) RETURN
IF (X(1,2).NE.15) GO TO 12
C HERE TO STATEMENT 12 FIXES UP "()"
IF (OP(2)/10.NE.5) GO TO 11
IF (OP(2).EQ.51) X(2,2)=15
OP(2)=0
11 CALL DROP (1)
RETURN
12 IF (OP(2).LT.70) RETURN
PTR=2
CALL EXECUT (2, RTRN)
13 RETURN
END
SUBROUTINE EQUAL
C DATE OF LAST CHANGE - 741024
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).LT.10) GO TO 2
1 CALL MESAGE (1, RTRN)
RETURN
2 DO 3 I=1,SMAX
IF (P(I).EQ.0) GO TO 3
CALL MESAGE (2, RTRN)
RETURN
3 CONTINUE
4 IF (OP(2).EQ.0) GO TO 5
PTR=2
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 6
GO TO 4
5 OP(1)=1
C- RN="RESULT REGISTER NUMBER"
C- CALL TRANS (.TRUE.)
6 RETURN
END
SUBROUTINE EXCH
C DATE OF LAST CHANGE - 750416
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DO 1 I=1,17
1 W(I)=X(1,I)
DO 2 I=1,17
2 X(1,I)=X(2,I)
DO 3 I=1,17
3 X(2,I)=W(I)
IF (OP(1).GT.60) GO TO 4
IF (OP(2).LT.70) GO TO 5
4 W(1)=OP(1)
OP(1)=OP(2)
OP(2)=W(1)
5 RETURN
END
SUBROUTINE DRPSTK
C DATE OF LAST CHANGE - 750220
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
IF (OP(1).EQ.0) GO TO 2
1 CALL MESAGE (1, RTRN)
RETURN
2 IF (X(1,2).NE.15) GO TO 1
IF (P(1).NE.0) GO TO 1
CALL DROP (1)
RETURN
END
SUBROUTINE SIGN
C DATE OF LAST CHANGE - 750416
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
IF (OP(1).NE.0) GO TO 2
IF (X(1,2).EQ.15) GO TO 5
1 OP(1)=CODE+17
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 6
RETURN
2 IF (OP(1).EQ.1) GO TO 1
IF (OP(1).LT.72) GO TO 3
CALL MESAGE (1, RTRN)
RETURN
3 IF (X(SMAX,2).EQ.15) GO TO 4
CALL MESAGE (9, RTRN)
RETURN
4 CALL ENTRUP
5 IF (CODE.NE.13) GO TO 6
IF (X(1,1).EQ.13) D(1)=15
IF (X(1,1).NE.13) D(1)=13
X(1,1)=D(1)
6 RETURN
END
SUBROUTINE OPRATR
C DATE OF LAST CHANGE - 740925
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).LT.10) GO TO 2
1 CALL MESAGE (1, RTRN)
RETURN
2 IF (CODE.LT.19) OP(1)=CODE+24
IF (CODE.EQ.19) OP(1)=60
IF (CODE.EQ.36) OP(1)=10
IF (CODE.EQ.37) OP(1)=10
IF (CODE.GT.37) OP(1)=CODE-20
CALL COLAPS (RTRN)
RETURN
END
SUBROUTINE FUNCTN (START)
C DATE OF LAST CHANGE - 750612
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO ( 1, 2, 3, 9, 13), START
C ** START 1 - MULTIPLE VARIABLE FUNCTION
1 PTR=2
TEMP=2
C ** START 2 - VARIABLE ARGUMENT M.V.F. (PTR & TEMP SET)
2 NEXT=.TRUE.
GO TO 4
C ** START 3 - SINGLE VARIABLE FUNCTION
3 PTR=1
TEMP=1
NEXT =.FALSE.
4 TEMPF=.FALSE.
5 CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 12
X(1,2)=CODE
X(1,3)=PTR
X(1,4)=TEMP
D(1)=15
IF (TEMPF) GO TO 14
IF (NEXT) GO TO 6
OP(1)=70
RETURN
C CONTINUE MULTIPLE VARIABLE FUNCTION
6 OP(1)=72
7 NEXT=.FALSE.
C- FOLLOWING 8 LINES CHECK FOR VALID INPUT AFTER "M.V.O."
CALL CONTRL (2,2)
NEXT=.TRUE.
IF (CODE.EQ.18) RETURN
IF (CODE.EQ.34) RETURN
IF (CODE.GT.28) GO TO 8
IF (CODE.GT.25) RETURN
8 CALL MESAGE (1,RTRN)
IF (RTRN.EQ.1) GO TO 12
GO TO 7
C- FOLLOWING LINE USED IN PLACE OF ABOVE WHEN CHECKING NOT DONE
C- RETURN
C ** START 4 - "IMMEDIATE" SINGLE VARIABLE FUNCTION
9 IF (X(1,2).EQ.15) GO TO 10
IF (OP(1).LT.2) GO TO 11
10 CALL MESAGE (1, RTRN)
RETURN
11 OP(1)=70
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 12
OP(1)=0
PTR=0
CALL EXECUT (2, RTRN)
12 RETURN
C ** START 5 - "LANGUAGE FUNCTION"
13 TEMPF=.TRUE.
GO TO 5
14 IF (TEMP.EQ.1) GO TO 15
OP(1)=73
X(1,5)=OPCD
GO TO 16
15 OP(1)=71
16 CODE=18
IF (OP(2).NE.50) GO TO 17
IF (P(1).EQ.0) OP(2)=0
17 CALL LPAREN
RETURN
END
SUBROUTINE SEMI
C DATE OF LAST CHANGE - 750104
LOGICAL IF
DATA IF /.FALSE./
IF (.NOT.IF) GO TO 1
C TREAT AS STRING SEPARATOR FOR "IF"
IF=.FALSE.
RETURN
C TREAT AS GENERAL ARGUMENT SEPARATOR
1 CALL OPRATR
RETURN
END
SUBROUTINE COMMA
C DATE OF LAST CHANGE - 750701
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C TREAT AS ARGUMENT SEPARATOR FOR "MVO"?
K=1
DO 3 I=2,SMAX
IF (OP(I).LT.72) GO TO 2
IF (P(I-1).EQ.1) GO TO 4
1 CALL MESAGE (2, RTRN)
RETURN
2 IF (P(I-1).NE.0) GO TO 1
IF (OP(I).EQ.10) K=K+1
3 CONTINUE
GO TO 6
4 IF (X(I,4).GT.K) GO TO 5
CALL MESAGE (11, RTRN)
RETURN
5 CALL OPRATR
RETURN
C TREAT AS "NO-OP"
6 RETURN
END
SUBROUTINE IMEDEX
C DATE OF LAST CHANGE - 750608
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C- NOTE: FOLLOWING 5 LINES ARE BASED ON MVO'S CALLING "LPAREN"
C- IF (OP(2).LT.72) GO TO 2
C- IF (OP(1).NE.0) GO TO 3
C- CALL DROP (1)
C- NOTE: FOLLOWING LINE NOT USED WHEN MVO'S CALL "LPAREN"
IF (OP(1).LT.72) GO TO 2
OP(3)=OP(1)
OP(1)=0
DO 1 I=1,17
TEMP=X(1,I)
X(1,I)=X(2,I)
X(2,I)=X(3,I)
1 X(3,I)=TEMP
PTR=3
GO TO 9
2 IF (X(1,2).EQ.15) GO TO 3
IF (X(2,2).EQ.15) GO TO 3
IF (P(1).EQ.0) GO TO 4
3 CALL MESAGE (1, RTRN)
RETURN
4 IF (OP(1).LT.20) GO TO 8
IF (OP(2).LT.20) GO TO 5
IF (OP(2).NE.50) GO TO 3
5 IF (OP(1).NE.70) GO TO 6
CALL EXCH
GO TO 7
6 OP(2)=OP(1)
7 OP(1)=0
PTR=2
GO TO 9
8 IF (OP(2).LT.20) GO TO 3
9 CALL EXECUT (1, RTRN)
RETURN
END
SUBROUTINE COLAPS (RTRN)
C DATE OF LAST CHANGE - 740809
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
1 IF (P(1).NE.0) RETURN
IF (OP(2).EQ.10) RETURN
IF (OP(1)/10 .GT. OP(2)/10) RETURN
PTR=2
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 2
GO TO 1
2 RTRN=1
RETURN
END
SUBROUTINE EXECUT (START, RTRN)
C DATE OF LAST CHANGE - 741218
IMPLICIT INTEGER (A-Z)
DIMENSION A(2,17)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA A/34*0/
RTRN=0
IF (START.EQ.2) GO TO 4
C ** START 1 - BINARY OPERATORS & MULTIPLE ARGUMENT FUNCTIONS
IF (OP(2).EQ.70) GO TO 6
C SAVE X(2,N) IN "LST X" & X(1,N) IN "LST Y"
DO 1 N=1,17
R(4,N)=X(1,N)
R(3,N)=X(2,N)
DO 1 I=1,2
C? IF (X(I,2).EQ.15) X(I,2)=0
1 A(I,N)=X(I,N)
IF (OP(PTR).GT.71) GO TO 3
C EXECUTE BINARY FUNCTION
OPCD=OP(2)
CALL COMBIN (A, 2, RTRN)
IF (RTRN.EQ.1) GO TO 13
DO 2 N=1,17
2 X(1,N)=A(1,N)
GO TO 12
C EXECUTE "MVO"
3 IF (OP(PTR).EQ.73) GO TO 5
OPCD=OP(PTR)+X(PTR,2)
CALL COMBIN (A, 2, RTRN)
IF (RTRN.EQ.1) GO TO 13
GO TO 10
C ** START 2 - SINGLE ARGUMENT FUNCTIONS
4 IF (OP(2).LT.71) GO TO 6
5 CALL ARGMNT (2)
RETURN
C SAVE X(1,N) IN "LST X"; EXECUTE "SVO"
C? 6 IF (X(1,2).EQ.15) X(1,2)=0
6 RN=-2
CALL TRANS (.TRUE.)
DO 7 N=1,17
7 A(1,N)=X(1,N)
IF (PTR.NE.0) GO TO 8
OPCD=70+CODE
GO TO 9
8 OPCD=OP(2)+X(2,2)
9 CALL COMBIN (A, 1, RTRN)
IF (RTRN.EQ.1) GO TO 13
10 DO 11 N=1,17
11 X(1,N)=A(1,N)
IF (X(1,2).EQ.0) X(1,1)=15
IF (PTR.EQ.0) RETURN
C CONSIDER SIGN PRECEEDING FUNCTION
IF (X(PTR,1).NE.13) GO TO 12
SIGN=X(1,1)
IF (SIGN.EQ.13) X(1,1)=15
IF (SIGN.NE.13) X(1,1)=13
12 IF (X(1,2).EQ.0) X(1,1)=15
C DROP STACK APPROPRIATE AMOUNT
CALL DROP (2)
IF (PTR.LT.3) GO TO 13
PTR=PTR-1
GO TO 12
13 RETURN
END
SUBROUTINE COMBIN (A, NARGS, RTRN)
C DATE OF LAST CHANGE - 750701
C PURPOSE: EXECUTE- "A(2,N) OPCD A(1,N) → A(1,N)"
C "SVO [A(1,N)] → A(1,N)"
C "[A(2,N)] SVO → A(1,N)"
C "MVO [A(2,N); A(1,N)] → A(1,N)"
IMPLICIT INTEGER (A-Z)
REAL*8 RX(2), DABS, DLOG10
DIMENSION A(2,17), EXP(2)
COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
C (1) CONVERT A(I,N) TO RX(I)
DO 2 I=1,2
RX(I)=A(I,14)
DO 1 J=1,12
KK=14-J
1 RX(I)=0.1*RX(I)+A(I,KK)
IF (A(I,1).EQ.13) RX(I)=-RX(I)
EXP(I)=10*A(I,16)+A(I,17)
IF (A(I,15).EQ.13) EXP(I)=-EXP(I)
2 CONTINUE
C (2) NOW EXECUTE RX(2), OPCD, RX(1) -> RX(1)=RX1
IF (OPCD.GT.60) GO TO 21
IF (OPCD.EQ.60) GO TO 14
IF (OPCD.GT.31) GO TO 9
IF (OPCD.GT.23) GO TO 8
C RELATIONALS
VALUE=0
RX(1)=-RX(1)
CALL ADD (RX, EXP)
GO TO (3, 4, 5, 6), OPCD-19
3 IF (RX(1) .EQ. 0.0) VALUE=1
GO TO 7
4 IF (RX(1) .NE. 0.0) VALUE=1
GO TO 7
5 IF (RX(1) .GT. 0.0) VALUE=1
GO TO 7
6 IF (RX(1) .LT. 0.0) VALUE=1
7 RX(1)=VALUE
GO TO 35
C ADDITION/SUBTRACTION
8 IF (OPCD.EQ.30) RX(1)=-RX(1)
CALL ADD (RX, EXP)
GO TO 35
C MULTIPLICATION/DIVISION
9 IF (OPCD.EQ.40) GO TO 10
RX(1)=RX(2)*RX(1)
EXP(1)=EXP(2)+EXP(1)
GO TO 35
10 IF (RX(1).NE.0.0) GO TO 13
11 ERROR=6
12 KK=9
C- "EXP OF A"="+ OVERFLOW"
J=12
GO TO 41
13 RX(1)=RX(2)/RX(1)
EXP(1)=EXP(2)-EXP(1)
GO TO 35
C EXPONENTIATION
14 IF (RX(2)) 11, 15, 16
15 RX(1)=0.0
EXP(1)=0
GO TO 35
16 RX(2)=RX(1)*(DLOG10(RX(2))+EXP(2))
S=1
IF (RX(2)) 17, 18, 19
17 RX(2)=-RX(2)
S=-1
GO TO 19
18 RX(1)=1.0
EXP(1)=0
GO TO 35
19 RX(2)=DLOG10(RX(2))
EXP(2)=RX(2)
RX(2)=10.0**(RX(2)-EXP(2))
EXP(2)=EXP(1)+EXP(2)
IF (EXP(2).LT.2) GO TO 20
ERROR=7
GO TO 12
20 RX(2)=S*RX(2)*10.0**EXP(2)
EXP(1)=RX(2)
RX(1)=10.0**(RX(2)-EXP(1))
GO TO 35
C SINGLE VARIABLE FUNCTIONS
21 IF (NARGS.NE.1) GO TO 26
GO TO (22, 23, 25), OPCD-115
C "ABS (X)"
22 RX(1)=DABS(RX(1))
GO TO 35
C "SQRT (X)"
23 IF (RX(1).GT.0) GO TO 24
ERROR=6
RX(1)=-RX(1)
24 CALL MYSQRT(RX(1), EXP(1))
GO TO 35
C "(X)↑2"
25 RX(1)=RX(1)*RX(1)
EXP(1)=EXP(1)+EXP(1)
GO TO 35
C MULTIPLE VARIABLE FUNCTIONS
26 GO TO (27, 31), OPCD-115
C "MAG (X,Y)"
27 KK=EXP(2)-EXP(1)
IF (IABS(KK).LT.15) GO TO 29
IF (KK) 35, 29, 28
28 RX(1)=RX(2)
EXP(1)=EXP(2)
GO TO 35
29 DO 30 I=1,2
30 RX(I)=RX(I)*RX(I)
EXP(2)=KK*2
KK=EXP(1)
EXP(1)=0
CALL ADD (RX, EXP)
CALL MYSQRT (RX(1), EXP(1))
EXP(1)=EXP(1)+KK
GO TO 35
C "ARG (X,Y)"
31 IF (RX(2).NE.0.0) GO TO 33
32 RX(1)=9.0
EXP(1)=1
GO TO 35
33 EXP(2)=EXP(1)-EXP(2)
IF (EXP(2).GT.30) GO TO 32
EXP(1)=0
IF (EXP(2).GT.-30) GO TO 34
RX(1)=0.0
GO TO 35
34 RX(1)=DATAN((RX(1)/RX(2))*10.0**EXP(2))*57.29577951D0
C (3) EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
35 IF (RX(1).NE.0.0) GO TO 36
KK=0
GO TO 38
36 IF (DABS(RX(1)).GE.1.0) GO TO 37
RX(1)=RX(1)*10.0
EXP(1)=EXP(1)-1
GO TO 36
37 IF (DABS(RX(1)).LT.10.0) GO TO 38
RX(1)=RX(1)/10.0
EXP(1)=EXP(1)+1
GO TO 37
38 IF (EXP(1).GE.0) GO TO 39
EXP(1)=-EXP(1)
A(1,15)=13
GO TO 40
39 A(1,15)=15
40 A(1,16)=EXP(1)/10
A(1,17)=EXP(1)-10*A(1,16)
C (4) CHECK FOR OVER/UNDER-FLOW
IF (A(1,16).LT.10) GO TO 43
ERROR=7
IF (A(1,15).NE.13) GO TO 12
KK=0
A(1,1)=15
C- "EXP OF A"="+"
J=15
41 A(1,1)=A(2,1)
DO 42 I=2,17
42 A(1,I)=KK
A(1,15)=J
GO TO 47
C (5) CONVERT RX(1)=RX(1) TO A(1,N), N=1, ..., 14
43 IF (RX(1).GE.0.0) GO TO 44
A(1,1)=13
RX(1)=-RX(1)
GO TO 45
44 A(1,1)=15
45 A(1,2)=RX(1)
DO 46 I=3,14
J=I-1
RX(1)=10.*(RX(1)-A(1,J))
46 A(1,I)=RX(1)
47 IF (ERROR.NE.0) CALL MESAGE (ERROR, RTRN)
RETURN
END
SUBROUTINE ADD (X, K)
C DATE OF LAST CHANGE - 750701
C PURPOSE: ADD TOGETHER TWO NUMBERS IN SCIENTIFIC NOTATION
DOUBLE PRECISION X, DABS, DLOG10
DIMENSION X(2), K(2)
J=K(1)-K(2)
IF (J.LT.15) GO TO 1
X(2)=0.0
GO TO 3
1 IF (J.GT.-15) GO TO 2
X(1)=0.0
K(1)=K(2)
GO TO 3
2 X(1)=X(1)*10.0**J
K(1)=K(1)-J
3 X(1)=X(1)+X(2)
IF (X(1).NE.0.0) GO TO 4
K(1)=0
GO TO 6
4 IF (DABS(X(1)).GE.1.0) GO TO 5
X(1)=X(1)*10.0
K(1)=K(1)-1
GO TO 4
5 KK=DLOG10(DABS(X(1)))+0.00001
X(1)=X(1)/10.0**KK
K(1)=K(1)+KK
6 RETURN
END
SUBROUTINE MYSQRT (X, K)
C DATE OF LAST CHANGE - 750701
C PURPOSE: TAKE SQUARE ROOT OF NUMBER IN SCIENTIFIC NOTATION
DOUBLE PRECISION X, DSQRT
IF (2*(K/2).EQ.K) GO TO 1
K=K-1
X=X*10.0
1 X=DSQRT (X)
K=K/2
RETURN
END
SUBROUTINE ENTRY
C DATE OF LAST CHANGE - 750628
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, NEXT, TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 11
DO 1 I=2,16
1 D(I)=15
2 IF (CODE.GT.9) GO TO 3
CALL DIGIT
GO TO 12
3 IF (CODE.NE.11) GO TO 4
CALL DECPT
GO TO 12
4 IF (CODE.NE.12) GO TO 5
CALL ENTEXP
IF (ERROR.NE.0) RETURN
GO TO 12
5 IF (CODE.NE.28) GO TO 6
CALL CORECT (1)
IF (.NOT.TEMPF) GO TO 12
RETURN
6 IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 7
IF (D(15).NE.0) GO TO 7
IF (D(16).NE.15) GO TO 7
D(14)=CODE
GO TO 12
7 IF (X(1,2).EQ.15) GO TO 8
IF (D(13).NE.12) GO TO 9
IF (CODE.EQ.26) GO TO 10
IF (CODE.EQ.27) GO TO 10
CALL ADEXPD (RTRN)
IF (RTRN.EQ.1) GO TO 11
IF (TEMPF) GO TO 12
GO TO 9
8 X(1,2)=0
9 CALL RESET
10 NEXT=.TRUE.
11 RETURN
C FORMAT "DISPLAY" & GET NEXT KEYSTROKE
12 CALL CONTRL (2, 2)
GO TO 2
END
SUBROUTINE DIGIT
C DATE OF LAST CHANGE - 750130
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (.NOT.EEX) GO TO 1
D(15)=D(16)
IF (D(15).EQ.15) D(15)=0
D(16)=CODE
RETURN
1 IF (M.GT.14) RETURN
IF (DP) GO TO 2
IF (M.EQ.14) RETURN
2 M=M+1
D(M)=CODE
IF (L.GT.13) RETURN
IF (DP) GO TO 3
IF (L.EQ.1) GO TO 4
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
GO TO 5
3 IF (L.NE.1) GO TO 5
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
4 IF (CODE.EQ.0) RETURN
5 L=L+1
X(1,L)=CODE
RETURN
END
SUBROUTINE DECPT
C DATE OF LAST CHANGE - 741004
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (.NOT.EEX) GO TO 1
EEX=.FALSE.
RETURN
1 IF (DP) RETURN
DP=.TRUE.
IF (M.GT.13) RETURN
M=M+1
D(M)=11
RETURN
END
SUBROUTINE ENTEXP
C DATE OF LAST CHANGE - 750125
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (.NOT.EEX) GO TO 2
CALL TESTUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
IF (D(13).NE.12) GO TO 1
CALL ADEXPD (RTRN)
IF (RTRN.EQ.1) GO TO 4
1 OP(1)=50
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 4
CALL ENTRUP
D(1)=15
X(1,1)=15
GO TO 3
2 IF (X(1,16).NE.0) RETURN
3 D(13)=12
D(14)=15
D(15)=0
D(16)=15
EEX=.TRUE.
IF (M.NE.1) RETURN
D(2)=1
D(3)=11
X(1,2)=1
M=3
L=2
DP=.TRUE.
4 RETURN
END
SUBROUTINE CLEARX (START)
C DATE OF LAST BHANGE - 750104
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 2, 3), START
C ** START 1 - CLEAR S(1)
1 P(1)=0
C ** START 2 - "CLEAR X"
2 OP(1)=0
C ** START 3 - CLEAR X(1)
3 D(1)=15
X(1,1)=15
X(1,2)=15
DO 4 I=3,17
4 X(1,I)=0
X(1,15)=15
CALL RESET
RETURN
END
SUBROUTINE CORECT (START)
C DATE OF LAST CHANGE - 750608
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP, TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (START.EQ.2) GO TO 12
C ** START 1 - ENTRY POINT FROM "ENTRY"
TEMPF=.FALSE.
IF (.NOT.EEX) GO TO 2
EEX=.FALSE.
DO 1 I=13,16
1 D(I)=15
RETURN
2 IF (M.GT.2) GO TO 4
IF (M.EQ.1) GO TO 3
IF (X(1,1).EQ.13) GO TO 4
3 CALL CLEARX (3)
TEMPF=.TRUE.
RETURN
4 IF (.NOT.DP) GO TO 6
IF (D(M).NE.11) GO TO 5
DP=.FALSE.
IF (M.EQ.2) TEMPF=.TRUE.
GO TO 11
5 IF (L.GT.2) GO TO 7
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
IF (L.EQ.2) GO TO 9
GO TO 11
6 IF (L.EQ.1) GO TO 11
IF (L.EQ.2) GO TO 8
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
7 X(1,L)=0
GO TO 10
8 TEMPF=.TRUE.
9 X(1,L)=15
10 L=L-1
11 D(M)=15
M=M-1
RETURN
C ** START 2 - ENTRY POINT FROM "LOOK-UP"
12 IF (OP(1).EQ.0) GO TO 14
IF (OP(1).LT.70) GO TO 13
CALL CLEARX (2)
RETURN
13 OP(1)=0
RETURN
14 IF (X(1,2).EQ.15) GO TO 16
15 CALL MESAGE (1, RTRN)
RETURN
16 IF (X(1,1).NE.13) GO TO 17
CALL CLEARX (3)
RETURN
17 IF (P(1).EQ.0) RETURN
IF (P(1).GT.1) GO TO 18
IF (OP(2).EQ.71) GO TO 15
IF (OP(2).EQ.73) GO TO 15
18 P(1)=P(1)-1
IF (P(1).NE.0) RETURN
IF (OP(2).GT.60) CALL DROP (1)
RETURN
END
SUBROUTINE ADEXPD (RTRN)
C DATE OF LAST CHANGE - 750702
C PURPOSE: ADD EXPONENT OF D TO THAT OF X(1)
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
TEMPF=.FALSE.
N=10*X(1,16)+X(1,17)
IF (X(1,15).EQ.13) N=-N
IF (D(15).EQ.15) D(15)=0
IF (D(16).EQ.15) D(16)=0
K=10*D(15)+D(16)
IF (D(14).EQ.13) K=-K
N=N+K
IF (IABS(N).LT.100) GO TO 4
CALL MESAGE (8, RTRN)
IF (RTRN.EQ.1) GO TO 7
IF (TEMPF) GO TO 7
IF (N.LT.0) GO TO 1
K=9
C- "EXP OF A"="+ OVERFLOW"
N=12
GO TO 2
1 K=0
X(1,1)=15
C- "EXP OF A"="+"
N=15
2 DO 3 I=2,17
3 X(1,I)=K
X(1,15)=N
GO TO 7
4 IF (N.GE.0) GO TO 5
N=-N
X(1,15)=13
GO TO 6
5 X(1,15)=15
6 X(1,16)=N/10
X(1,17)=N-X(1,16)*10
7 RETURN
END
SUBROUTINE EXPON (A,B,C,N)
C DATE OF LAST CHANGE - 740210
C ADD "N" TO THE EXPONENT "ABC" (I.E. SIGN, DIGIT, DIGIT)
IMPLICIT INTEGER (A-Z)
IF (B.EQ.15) B=0
IF (C.EQ.15) C=0
K=10*B+C
IF (A.EQ.13) K=-K
K=K+N
IF (K.GE.0) GO TO 1
K=-K
A=13
GO TO 2
1 A=15
2 B=K/10
C=K-10*B
RETURN
END
SUBROUTINE RECALL (START)
C DATE OF LAST CHANGE - 750314
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 5, 6), START
C ** START 1 - EXPLICIT REGISTERS (A, PI, LST X, LST Y)
1 IF (CODE-24) 2, 3, 4
2 RN=-3
GO TO 7
3 RN=-4
GO TO 8
4 RN=CODE-40
GO TO 7
C ** START 2 - "R" REGISTERS
5 LFRC=1
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 11
IF (TEMPF) RETURN
C ** START 3 - RECALL INDICATED REGISTER (RN IN W)
6 CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 11
7 IF (R(RN+5,2).NE.15) GO TO 8
CALL MESAGE (5, RTRN)
IF (RTRN.EQ.1) GO TO 11
8 CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 11
IF (X(1,1).EQ.13) GO TO 9
CALL TRANS (.FALSE.)
RETURN
9 CALL TRANS (.FALSE.)
IF (X(1,1).EQ.13) GO TO 10
X(1,1)=13
RETURN
10 X(1,1)=15
11 RETURN
END
SUBROUTINE STORE (START)
C DATE OF LAST CHANGE - 750612
IMPLICIT INTEGER (A-Z)
DIMENSION OPCODE(7), A(2,17)
LOGICAL TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA OPCODE /30, 31, 0, 40, 41, 0, 60/
GO TO (1, 12, 21), START
C ** START 1 - LOOK FOR DESTINATION
1 IF (OP(1).LT.70) GO TO 2
CALL MESAGE (1, RTRN)
RETURN
2 OPCD=0
TEMP=0
3 LFRC=2
CODE=31
4 CALL FINDN (2, RTRN)
IF (RTRN.EQ.1) GO TO 20
IF (K.NE.0) GO TO 11
IF (CODE.NE.25) GO TO 5
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 20
IF (.NOT.TEMPF) GO TO 11
IF (OPCD.NE.0) GO TO 8
GO TO 3
5 IF (CODE.NE.23) GO TO 6
N=-3
RN=-3
GO TO 13
6 IF (CODE.NE.51) GO TO 7
LFRC=5
CALL FDIGIT (1, RTRN)
IF (RTRN.EQ.1) GO TO 20
IF (TEMPF) GO TO 2
GO TO 21
7 IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
* CODE.EQ.17 .OR. CODE.EQ.19) GO TO 10
IF (CODE.NE.28) GO TO 9
IF (OPCD.EQ.0) RETURN
IF (TEMP.EQ.1) GO TO 2
IF (LSTK.EQ.OPCD) GO TO 2
8 CODE=OPCD
TEMP=1
GO TO 4
9 CALL MESAGE (3, RTRN)
IF (RTRN.EQ.1) GO TO 20
GO TO 2
10 OPCD=CODE
GO TO 4
11 TEMP=1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
12 CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 20
13 KMAX=RN
IF (OPCD.NE.0) OPCD=OPCODE(OPCD-12)
DO 18 RN=N,KMAX
IF (OPCD.EQ.0) GO TO 17
K=RN+5
IF (R(K,2).NE.15) GO TO 14
CALL MESAGE (5, RTRN)
IF (RTRN.EQ.1) GO TO 20
14 DO 15 I=1,17
A(1,I)=X(1,I)
A(2,I)=R(K,I)
15 IF (A(2,I).EQ.15) A(2,I)=0
IF (A(1,2).EQ.15) A(1,2)=0
CALL COMBIN (A, 2, RTRN)
IF (RTRN.EQ.1) GO TO 20
DO 16 I=1,17
16 R(K,I)=A(1,I)
GO TO 18
17 CALL TRANS (.TRUE.)
18 CONTINUE
19 IF (OP(1).EQ.0) OP(1)=1
20 RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
21 TEMP=1
IF (X(1,1).EQ.13 .OR. X(1,2).EQ.0 .OR.
* X(1,15).EQ.13 .OR. X(1,2).EQ.15) TEMP=0
DO 22 I=N,RN
K=I+1
22 UFLAG(K)=TEMP
GO TO 19
END
SUBROUTINE TRANS (STORE)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL STORE
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
K=RN+5
IF (STORE) GO TO 4
DO 1 I=1,17
1 X(1,I)=R(K,I)
IF (X(1,2).NE.15) GO TO 3
DO 2 I=2,17
2 X(1,I)=0
X(1,15)=15
3 RETURN
4 DO 5 I=1,17
5 R(K,I)=X(1,I)
IF (R(K,2).EQ.15) R(K,2)=0
IF (R(K,1).EQ.13 .AND. R(K,2).EQ.0) R(K,1)=15
RETURN
END
SUBROUTINE SCR (START)
C DATE OF LAST CHANGE - 750303
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 5, 8), START
C ** START 1 - FIND ARGUMENT
1 CODE=50
CALL CONTRL (3, 2)
IF (CODE.NE.25) GO TO 2
LFRC=3
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 10
IF (TEMPF) GO TO 1
TEMP=1
GO TO 5
2 IF (CODE.NE.23) GO TO 3
N=-3
RN=-3
GO TO 6
3 IF (CODE.NE.51) GO TO 4
LFRC=4
CALL FDIGIT (1, RTRN)
IF (RTRN.EQ.1) GO TO 10
IF (TEMPF) GO TO 1
GO TO 8
4 CALL MESAGE (3, RTRN)
IF (RTRN.EQ.1) GO TO 10
GO TO 1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
5 CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 10
6 DO 7 I=N,RN
K=I+5
DO 7 J=1,17
7 R(K,J)=15
RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
8 DO 9 I=N,RN
K=I+1
9 UFLAG(K)=0
10 RETURN
END
SUBROUTINE LSTKEY
C DATE OF LAST CHANGE - 750704
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION W2(16)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
DO 1 I=1,16
W2(I)=DSP(I)
1 DSP(I)=11
DSP(1)=15
2 IF (LSTK.GE.0) GO TO 4
DO 3 I=8,10
3 DSP(I)=13
GO TO 5
4 DSP(8)=0
DSP(9)=LSTK/10
DSP(10)=LSTK-10*DSP(9)
5 CALL KYMODE (1)
CALL OUTIN (2)
IF (CODE.NE.27) GO TO 7
DO 6 I=1,16
6 DSP(I)=W2(I)
RETURN
7 IF (CODE.EQ.30) GO TO 2
NEXT=.TRUE.
RETURN
END
SUBROUTINE KYMODE (START)
C DATE OF LAST CHANGE - 741231
IMPLICIT INTEGER (A-Z)
LOGICAL STEP
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
GO TO (1, 2, 3), START+1
C ** START 0 - COMPLEMENT "STEP"
1 STEP=.NOT.STEP
RETURN
C ** START 1 - DISPLAY PROGRAM POINTER?
2 IF (.NOT.STEP) RETURN
C ** START 2 - DISPLAY PROGRAM POINTER!
3 DSP(1)=PGMPTR/1000
DSP(2)=PGMPTR/100-10*DSP(1)
DSP(3)=PGMPTR/10-100*DSP(1) -10*DSP(2)
DSP(4)=PGMPTR/1-1000*DSP(1)-100*DSP(2)-10*DSP(3)
RETURN
END
SUBROUTINE FLAG (START)
C DATE OF LAST CHANGE - 750314
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (START.EQ.2) GO TO 1
C ** START 1 - FIND FLAG NUMBER
LFRC=6
CALL FDIGIT (1, RTRN)
IF (RTRN.EQ.1) GO TO 2
IF (TEMPF) RETURN
C ** START 2 - FLAG NUMBER KNOWN (HELD IN N)
1 RN=N
CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 2
X(1,2)=UFLAG(RN+1)
2 RETURN
END
SUBROUTINE SETUP (RTRN)
C DATE OF LAST CHANGE - 750610
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
IF (X(1,2).EQ.15) RETURN
IF (OP(1).NE.0) GO TO 2
CALL TESTUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
OP(1)=50
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 4
1 CALL ENTRUP
RETURN
2 IF (OP(1).EQ.1) GO TO 5
IF (OP(1).LT.72) GO TO 3
IF (CODE.EQ.18) GO TO 3
CALL MESAGE (1, RTRN)
RTRN=1
RETURN
3 IF (X(SMAX,2).EQ.15) GO TO 1
CALL MESAGE (9, RTRN)
4 RTRN=1
RETURN
C CODE = 81, 82, ... WHEN "LANGUAGE FUNCTION" BEING FORMED
5 IF (CODE.GT.79) GO TO 3
IF (CODE.EQ.38) GO TO 6
II=RN
RN=-2
CALL TRANS (.TRUE.)
RN=II
6 CALL CLEARX (2)
RETURN
END
SUBROUTINE TESTUP (RTRN)
C DATE OF LAST CHANGE - 740625
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
RTRN=0
IF (X(SMAX,2).EQ.15) RETURN
IF (OP(2).LT.50) GO TO 1
IF (P(1).EQ.0) GO TO 2
1 CALL MESAGE (9, RTRN)
RTRN=1
2 RETURN
END
SUBROUTINE ENTRUP
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
KMAX=SMAX-1
DO 1 I=1,KMAX
J=SMAX-I
K=J+1
P(K)=P(J)
OP(K)=OP(J)
DO 1 N=1,17
1 X(K,N)=X(J,N)
C- IF (X(SMAX,2).NE.15) "TURN ON 'STACK FULL' LIGHT"
CALL CLEARX (1)
RETURN
END
SUBROUTINE DROP (START)
C DATE OF LAST CHANGE - 750608
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 2, 3), START
C ** START 1 - DROP S(2), ..., S(SMAX)
1 J=1
GO TO 4
C ** START 2 - DROP S(3), ..., S(SMAX)
2 P(1)=P(2)
J=2
GO TO 4
C ** START 3 - DROP S(PTR+1), ..., S(SMAX)
3 J=PTR
4 KMAX=SMAX-1
DO 5 I=J,KMAX
IF (I.GT.2 .AND. X(I,2).EQ.15) GO TO 6
JJ=I+1
P(I)=P(JJ)
OP(I)=OP(JJ)
DO 5 K=1,17
5 X(I,K)=X(JJ,K)
6 IF (X(SMAX,2).EQ.15) RETURN
OP(SMAX)=0
P(SMAX)=0
X(SMAX,1)=15
X(SMAX,2)=15
DO 7 I=3,17
7 X(SMAX,I)=0
X(SMAX,15)=15
C- "TURN OFF 'STACK FULL' LIGHT"
RETURN
END
SUBROUTINE NUMBER (START, RTRN)
C DATE OF LAST CHANGE - 750130
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
RTRN=0
IF (START.EQ.2) GO TO 5
C ** START 1 - FIND A NUMBER (0-9)
1 CALL CONTRL (1, 2)
IF (CODE.GT.9) GO TO 2
W(2)=CODE
RETURN
2 IF (LFRC.NE.0) GO TO 3
NEXT=.TRUE.
RTRN=1
RETURN
3 IF (CODE.EQ.18) GO TO 4
CALL MESAGE (3, RTRN)
IF (RTRN.EQ.1) GO TO 9
GO TO 1
4 CALL ARGMNT (1)
RTRN=1
RETURN
C ** START 2 - NUMBER FOUND FROM EXPRESSION (HELD IN W)
5 IF (W(17).EQ.0 .AND. W(16).EQ.0) GO TO 6
CALL MESAGE (4, RTRN)
RTRN=1
RETURN
C-
6 TYPE 7
7 FORMAT (10X, 'GOT TO "NUMBER AT "START 2" SOMEHOW!'/)
RTRN=1
C-
C- 6 GO TO (7, 8), CODE-7
C- 7 CALL P (2)
C- RETURN
C- 8 CALL STORE (2)
9 RETURN
END
SUBROUTINE FINDN (START, RTRN)
C DATE OF LAST CHANGE - 750104
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
GO TO (1, 2, 3), START
1 KMAX=1
GO TO 4
2 KMAX=2
GO TO 4
3 KMAX=3
4 NEXT=.FALSE.
K=0
I=CODE
5 CALL CONTRL (3, 2)
IF (CODE.GT.9) GO TO 6
W(17)=K
K=K+1
W(K+1)=CODE
IF (K.LT.KMAX) GO TO 5
RETURN
6 IF (K.GT.0) GO TO 7
IF (CODE.NE.18) GO TO 11
CALL ARGMNT (1)
RTRN=1
RETURN
7 IF (CODE.NE.28) GO TO 8
K=K-1
W(17)=K-1
CODE=W(K+1)
IF (K.EQ.0) CODE=I
GO TO 5
8 IF (CODE.NE.27) GO TO 9
K=0
GO TO 11
9 IF (CODE.NE.26) GO TO 10
K=0
10 NEXT=.TRUE.
11 RETURN
END
SUBROUTINE REG (RTRN)
C DATE OF LAST CHANGE - 750626
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
IND=0
TEMPF=.FALSE.
1 CALL FINDN (2, RTRN)
IF (RTRN.EQ.1) GO TO 14
IF (K.NE.0) GO TO 11
IF (CODE.NE.25) GO TO 4
IF (IND.NE.15) GO TO 3
CALL MESAGE (4, RTRN)
2 RTRN=1
RETURN
3 IND=IND+1
LFRC=0
GO TO 1
4 IF (CODE.NE.23) GO TO 7
IF (R(2,2).NE.15) GO TO 5
CALL MESAGE (5, RTRN)
IF (RTRN.EQ.1) GO TO 14
5 DO 6 I=1,17
W(I)=R(2,I)
IF (W(I).EQ.15) W(I)=0
6 CONTINUE
GO TO 11
7 IF (CODE.NE.22) GO TO 8
W(2)=1
W(3)=6
W(15)=15
W(16)=0
W(17)=1
GO TO 11
8 IF (CODE.EQ.26) GO TO 2
IF (CODE.EQ.27) GO TO 2
IF (CODE.NE.28) GO TO 10
IF (IND.EQ.0) GO TO 9
IND=IND-1
CODE=25
GO TO 1
9 TEMPF=.TRUE.
RETURN
10 CALL MESAGE (3, RTRN)
IF (RTRN.EQ.1) GO TO 14
CODE=25
GO TO 1
11 IF (IND.EQ.0) GO TO 14
CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 14
RN=RN+5
IF (R(RN,2).NE.15) GO TO 12
CALL MESAGE (5, RTRN)
IF (RTRN.EQ.1) GO TO 14
12 DO 13 I=1,17
W(I)=R(RN,I)
IF (W(I).EQ.15) W(I)=0
13 CONTINUE
IND=IND-1
GO TO 11
14 RETURN
END
SUBROUTINE RANGE (RTRN)
C DATE OF LAST CHANGE - 750225
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
TEMPF=.TRUE.
1 CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 6
IF (RN.NE.16) GO TO 2
CALL MESAGE (4, RTRN)
RETURN
2 IF (TEMP.EQ.1) GO TO 5
N=RN
TEMPF=.FALSE.
TEMP=TEMP-1
DO 3 I=1,13
3 W(I)=DSP(I)
W(14)=0
DO 4 I=14,16
4 W(I+1)=DSP(I)
GO TO 1
5 IF (TEMPF) N=RN
IF (RN.GE.N) GO TO 6
TEMP=RN
RN=N
N=TEMP
6 RETURN
END
SUBROUTINE REGNO (RTRN)
C DATE OF LAST CHANGE - 741126
C PURPOSE: CONVERT W TO INTEGER IN RN; CHECK FOR RN TOO BIG
IMPLICIT INTEGER (A-Z)
COMMON /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
K=21
CALL INTGER
KMAX=RN
K=0
CALL INTGER
IF (RN.LE.KMAX+1) GO TO 1
CALL MESAGE (4, RTRN)
RTRN=1
1 RETURN
END
SUBROUTINE ARGMNT (START)
C DATE OF LAST CHANGE - 750225
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 5), START
C ** START 1 - FORM GENERAL ARGUMENT
1 IF (LFRC.NE.0) GO TO 2
CALL MESAGE (3, RTRN)
RETURN
2 CODE=LFRC+80
LFRC=0
C- FOLLOWING 4 LINES ARE FOR A 2 ARGUMENT "LANGUAGE FUNCTION"
C- IF (CODE.LT.90) GO TO 3
C- PTR=2
C- TEMP=2
C- GO TO 4
3 PTR=1
TEMP=1
IF (CODE.GT.81 .AND. CODE.LT.86) TEMP=2
4 CALL FUNCTN (5)
RETURN
C ** START 2 - RETURN ARGUMENT(S) TO "LANGUAGE FUNCTION" IN W ([&D] &DSP)
5 TEMP=PTR-1
N=1
6 PTR=PTR-1
IF (X(1,15).NE.13) GO TO 8
DO 7 I=1,17
7 W(I)=0
GO TO 9
8 K=6
CALL ROUND
9 CALL DROP (1)
IF (OP(1).GT.70) GO TO 15
N=N+1
IF (N.GT.2) GO TO 12
DO 10 I=1,13
10 DSP(I)=W(I)
DO 11 I=14,16
11 DSP(I)=W(I+1)
GO TO 6
12 DO 13 I=1,13
13 D(I)=W(I)
DO 14 I=14,16
14 D(I)=W(I)
GO TO 6
15 PTR=X(1,2)-80
IF (PTR.EQ.2) OPCD=X(1,5)
IF (P(1).EQ.0) GO TO 16
CALL CLEARX (2)
GO TO 17
16 CALL DROP (1)
17 GO TO (19, 20, 21, 22, 22, 22, 18, 23, 23), PTR
18 CALL MESAGE (82, RTRN)
RETURN
19 CALL RECALL (3)
RETURN
20 CALL STORE (2)
RETURN
21 CALL SCR (2)
RETURN
22 CALL FDIGIT (2, RTRN)
RETURN
23 CALL NUMBER (2, RTRN)
RETURN
END
SUBROUTINE INTGER
C DATE OF LAST CHANGE - 741218
IMPLICIT INTEGER (A-Z)
DIMENSION S(17)
COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RN=0
IF (K.GT.0) GO TO 3
1 DO 2 I=1,17
2 S(I)=W(I)
GO TO 7
3 IF (S(2).NE.15) GO TO 5
DO 4 I=2,17
4 S(I)=0
S(15)=15
GO TO 7
5 DO 6 I=1,17
6 S(I)=R(K,I)
7 IF (S(15).EQ.13) RETURN
K=S(16)*10+S(17)+1
IF (K.LT.13) GO TO 8
RN=99999
RETURN
8 DO 9 I=1,K
9 RN=RN*10+S(I+1)
RETURN
END
SUBROUTINE ROUND
C DATE OF LAST CHANGE - 750123
C PURPOSE: ROUND X(1,I) TO K DIGITS & PUT RESULT IN W(I)
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
1 DO 2 I=1,17
2 W(I)=X(1,I)
IF (K.NE.15) GO TO 3
W(15)=12
RETURN
3 IF (W(2).EQ.15) W(2)=0
CNT=K+2
IF (W(CNT)-5) 11, 4, 7
C TEST DIGIT = 5 (TEST FURTHER)
4 CNT=14
KLAX=K+3
5 IF (W(CNT).GT.0) GO TO 7
IF (CNT.EQ.KMAX) GO TO 6
CNT=CNT-1
GO TO 5
6 CNT=K+1
IF (2*(W(CNT)/2) .EQ. W(CNT)) GO TO 11
C ROUND UP
7 CNT=K+1
8 W(CNT)=W(CNT)+1
IF (W(CNT).LT.10) GO TO 11
W(CNT)=W(CNT)-10
CNT=CNT-1
IF (CNT.GT.1) GO TO 8
C [W(2) OVERFLOWED; SHIFT RIGHT & SET W(2)=1]
CNT=K+2
9 W(CNT)=W(CNT-1)
IF (CNT.LE.3) GO TO 10
CNT=CNT-1
GO TO 9
10 W(2)=1
K=K+1
CALL EXPON (W(15), W(16), W(17), 1)
IF (W(16).LT.10) GO TO 11
K=15
GO TO 1
C PUT 0'S IN REMAINDER OF W
11 KMAX=K+1
DO 12 I=KMAX,13
12 W(I+1)=0
RETURN
END
SUBROUTINE FDIGIT (START, RTRN)
C DATE OF LAST CHANGE - 750315
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
IF (START.EQ.2) GO TO 7
C ** START 1 - FIND A DIGIT (0-9, A)
TEMPF=.FALSE.
1 CALL CONTRL (3, 2)
IF (CODE.GT.9) GO TO 2
N=CODE
GO TO 3
2 IF (CODE.NE.23) GO TO 4
N=10
3 RN=N
RETURN
4 IF (CODE.NE.18) GO TO 5
CALL ARGMNT (1)
RTRN=1
RETURN
5 IF (CODE.NE.28) GO TO 6
TEMPF=.TRUE.
RETURN
6 CALL MESAGE (3, RTRN)
IF (RTRN.EQ.1) GO TO 13
GO TO 1
C ** START 2 - DIGIT HAS BEEN FOUND FROM EXPRESSION
7 CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 13
IF (RN.GT.11) GO TO 8
IF (N.LT.11) GO TO 9
8 CALL MESAGE (4, RTRN)
RTRN=1
RETURN
9 GO TO (10, 11, 12), PTR-3
10 CALL SCR (3)
RETURN
11 CALL STORE (3)
RETURN
12 CALL FLAG (2)
13 RETURN
END