perm filename CALC.F4[2,VDS]6 blob
sn#198043 filedate 1976-01-23 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00033 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 C MAIN PROGRAM -- "SYSTEM MONITOR"
C00016 00003 SUBROUTINE OUTPUT (PRINT)
C00026 00004 SUBROUTINE CONTRL (START, PRINT)
C00030 00005 SUBROUTINE UPDATE (START)
C00041 00006 SUBROUTINE MESAGE (TYPE, ERR, RTRN)
C00047 00007 SUBROUTINE RESET
C00050 00008 SUBROUTINE RPAREN (START)
C00054 00009 SUBROUTINE EQUAL
C00058 00010 SUBROUTINE SIGN
C00061 00011 SUBROUTINE FUNCTN (START)
C00068 00012 SUBROUTINE IMEDEX
C00072 00013 SUBROUTINE EXECUT (START, RTRN)
C00078 00014 SUBROUTINE COMBIN (A, NARGS, ESHIFT, RTRN)
C00090 00015 SUBROUTINE ENTRY
C00094 00016 SUBROUTINE DIGIT
C00097 00017 SUBROUTINE ENTEXP
C00100 00018 SUBROUTINE CORECT (START)
C00104 00019 SUBROUTINE ADEXPD (RTRN)
C00107 00020 SUBROUTINE RECALL (START)
C00110 00021 SUBROUTINE STORE (START)
C00117 00022 SUBROUTINE SCR (START)
C00120 00023 SUBROUTINE LSTKEY
C00123 00024 SUBROUTINE FLAG (START)
C00127 00025 SUBROUTINE SETUP (RTRN)
C00130 00026 SUBROUTINE FTSTUP (RTRN)
C00132 00027 SUBROUTINE ENTRUP
C00135 00028 SUBROUTINE NUMBER (START, RTRN)
C00138 00029 SUBROUTINE FINDN (START, RTRN)
C00141 00030 SUBROUTINE REG (RTRN)
C00148 00031 SUBROUTINE ARGMNT (START, RTRN)
C00154 00032 SUBROUTINE ROUND
C00157 00033 SUBROUTINE FDIGIT (START, RTRN)
C00160 ENDMK
C⊗;
C MAIN PROGRAM -- "SYSTEM MONITOR"
C DATE OF LAST CHANGE - 750104
IMPLICIT INTEGER (A-Z)
LOGICAL START, NEXT, FIXFLG, TRUE
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 DECODE = KEY-CODE INPUT (T -> ENCODED KEYS, F -> NUMERIC CODES)
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
DECODE=.TRUE.
SKIP=3
FIXFLG=.TRUE.
FIX=2
SCI=5
SMAX=10
C
TYPE 1000
ACCEPT 1700, START
IF (START) GO TO 50
TYPE 1100
ACCEPT 1700, DECODE
TYPE 1200
ACCEPT 1800, SKIP
TYPE 1300
ACCEPT 1700, START
IF (START) GO TO 40
TYPE 1400
ACCEPT 1700, FIXFLG
TYPE 1500
ACCEPT 1900, FIX, SCI
SCI=SCI+1
40 TYPE 1600
ACCEPT 1800, SMAX
C CONSIDER 100 TEST EQUATIONS
50 DO 330 TEST=1,100
ERROR=0
OLD=1
DO 60 II=1,50
60 EXPR(II)=15
CALL CLEAR
TYPE 2000, 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 320
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 100
IF (CODE.EQ.37) GO TO 280
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
IF (CODE.EQ.49) GO TO 140
IF (CODE.EQ.50) GO TO 290
IF (CODE.EQ.51) GO TO 300
IF (CODE.EQ.52) GO TO 310
C KEY-CODE ERROR?
IF (CODE.EQ.99) GO TO 10
CALL MESAGE (2, 01, RTRN)
GO TO 320
C CALL KEY ROUTINE
80 CALL ENTRY
GO TO 320
90 CALL SIGN
GO TO 320
100 CALL OPRATR
GO TO 320
110 CALL LPAREN
GO TO 320
120 CALL RPAREN (1)
GO TO 320
130 CALL EQUAL
GO TO 320
140 CALL FUNCTN (1)
GO TO 320
150 CALL FUNCTN (3)
GO TO 320
160 CALL FUNCTN (4)
GO TO 320
170 CALL RECALL (1)
GO TO 320
180 CALL RECALL (2)
GO TO 320
190 CALL CLEAR
GO TO 330
200 CALL CLEARX (2)
GO TO 320
210 CALL CORECT (2)
GO TO 320
220 CALL DRPSTK
GO TO 320
230 CALL STORE (1)
GO TO 320
240 CALL FIXN
GO TO 320
250 CALL SCIN
GO TO 320
260 CALL IMEDEX
GO TO 320
270 CALL EXCH
GO TO 320
280 CALL COMMA
GO TO 320
290 CALL SCR (1)
GO TO 320
300 CALL FLAG (1)
GO TO 320
310 CALL STPNUM (0)
C GO BACK AND GET ANOTHER KEY-STROKE
320 GO TO 70
330 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' ACCEPT "ENCODED" KEY-CODES'
* /' PRODUCE "DISPLAY & REGISTERS" OUTPUT'
* /' DISPLAY IN "FIX MODE" WITH FIX=2 & SCI=4'
* /' USE A 10 LEVEL "STACK"'
* //' THESE ARE OKAY. ("T" OR "F")'/)
1100 FORMAT (/' ENCODED KEY-CODES ARE TO BE ENTERED. ("T"/"F")'/)
1200 FORMAT (/' ENTER CODE FOR DESIRED OUTPUT: 0 = LONG STACK'
* /33X,'1 = SHORT STACK'/33X,'2 = DISPLAY ONLY'
* /33X,'3 = DISPLAY & REGISTERS'/)
1300 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' ("T" OR "F")'/)
1400 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. ("T"/"F")'/)
1500 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. ("N <SP> M")'/)
1600 FORMAT (/' ENTER NUMBER OF STACK REGISTERS WANTED (10 MAX)'/)
1700 FORMAT (L1)
1800 FORMAT (I)
1900 FORMAT (2I)
2000 FORMAT ('1 TEST NO.',I3/)
END
BLOCK DATA
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, STEPNO
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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./, STEPNO /.FALSE./, UFLAG /11*0/,
* CODE /-1/, 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(40), SIGN(7), ESN(7), REG(17),
* DISP(32), DISP2(16), NAME(3)
LOGICAL EEX, DP, FIXFLG, STEPNO
DOUBLE PRECISION NAME
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
2 /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
3 /INPUT/ CODE, DECODE, 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)/'MX','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
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 IF (KEY.LT.41) GO TO 40
OLD=1
KEY=21
DO 30 II=1,21
EXPR(II)=EXPR(II+20)
30 STROKE(II+19)=CHAR(15)
40 DO 50 II=OLD,KEY
JJ=EXPR(II)
IF (JJ.EQ.0) JJ=10
50 STROKE(II)=CHAR(JJ)
TYPE 1000, (STROKE(II),II=1,KEY)
OLD=KEY+1
IF (SKIP2.EQ.2) GO TO 70
KK=SMAX
IF (SKIP2.EQ.1) KK=2
DO 60 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
60 ESN(II)=CHAR(JJ)
70 DO 80 II=1,32
JJ=DISPLY(II)
IF (JJ.EQ.0) JJ=10
80 DISP(II)=CHAR(JJ)
DO 90 II=1,16
JJ=DSP(II)
IF (JJ.EQ.0) JJ=10
90 DISP2(II)=CHAR(JJ)
IF (SKIP2.GT.1) GO TO 120
IF (SKIP2.EQ.1) GO TO 110
TYPE 1100, DP, L, EEX, M, FIXFLG, FIX, NEXT, SCI, STEPNO, ERROR
IF (SMAX.LT.3) GO TO 110
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 110
JJ=SMAX-3
DO 100 II=1,JJ
KK=SMAX-II
100 TYPE 1300, KK, P(KK), SIGN(KK), (X(KK,NN),NN=2,14),
2 ESN(KK), X(KK,16), X(KK,17), OP(KK)
110 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
120 TYPE 1600, DISP2
IF (SKIP2.EQ.2) RETURN
DO 140 II=2,4
IF (R(II,2).EQ.15) GO TO 140
DO 130 JJ=1,17
KK=R(II,JJ)
IF (KK.EQ.0) KK=10
130 REG(JJ)=CHAR(KK)
TYPE 1700, NAME(II-1), (REG(NN), NN=1,17)
140 CONTINUE
DO 160 II=5,20
IF (R(II,2).EQ.15) GO TO 160
JJ=II-5
DO 150 KK=1,17
LL=R(II,KK)
IF (LL.EQ.0) LL=10
150 REG(KK)=CHAR(LL)
TYPE 1800, JJ, (REG(NN), NN=1,17)
160 CONTINUE
DO 170 II=1,11
IF (UFLAG(II).EQ.1) GO TO 180
170 CONTINUE
RETURN
180 TYPE 1900, UFLAG
RETURN
1000 FORMAT (/6X, 'EXPRESSION: ', 20A3, (/18X, 20A3))
1100 FORMAT (//6X,'FLAGS: DP -',L2,20X,'INDICES: L -',
2 I2/14X,'EEX -',L2,30X,'M -',I2/14X,'FIXFLG-',
3 L2,30X,'FIX -',I2/14X,'NEXT -',L2,30X,'SCI -',
4 I2/14X,'STEPNO-',L2,30X,'ERROR -',I2)
1200 FORMAT (//6X, 'STACK: S(', I2, ') -', 4X, I2, ' / ', A2,
2 I2, ' .', 12I2, A2, 2I2, ' /', I3)
1300 FORMAT (14X, 'S(', I2, ') -', 4X, I2, ' / ', A2, I2, ' .',
2 12I2, A2, 2I2, ' /', I3)
1400 FORMAT (/14X, 'S( 2) -', 4X, I2, ' / ', A2, I2, ' .', 12I2,
2 A2, 2I2, ' /', I3/14X, 'S( 1) -', 4X, I2, ' / ',
3 A2, I2, ' .', 12I2, A2, 2I2, ' /', I3/)
1500 FORMAT (2(/6X, 'DISPLAY:', 9X, 16A2))
1600 FORMAT (//6X, 'DISPLAY:', 9X, 16A2//)
1700 FORMAT (6X, A8, 2X, 2A2, ' .', 15A2)
1800 FORMAT (6X, 'REG(', I2, ') =', 1X, 2A2, ' .', 15A2)
1900 FORMAT (/6X, 'USER FLAGS: ', 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(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 DSP(1)=15
DO 4 I=2,16
4 DSP(I)=13
DSP(8)=0
DSP(9)=CODE/10
DSP(10)=CODE-10*DSP(9)
5 CALL STPNUM (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 - 750714
IMPLICIT INTEGER (A-Z)
LOGICAL STEPNO
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, OLD, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
CALL OUTPUT (PRINT)
LSTK=CODE
1 IF (.NOT.DECODE) GO TO 2
CALL DCODER (CODE)
GO TO 3
2 TYPE 5
ACCEPT 6, CODE
3 IF (CODE.LT.100) GO TO 4
IF (CODE.EQ.100) CALL OUTPUT (3)
IF (CODE.EQ.101) CALL OUTPUT (0)
GO TO 1
4 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
IF (STEPNO) PGMPTR=PGMPTR+1
RETURN
5 FORMAT (' N?'/)
6 FORMAT (I)
END
SUBROUTINE UPDATE (START)
C DATE OF LAST CHANGE - 750801
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, STEPNO
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, 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 20
C ** DISPLAY PARENTHESES, MAYBE
IF (P(1).EQ.0) GO TO 2
IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).NE.15) GO TO 2
DO 1 I=1,16
1 DSP(I)=15
I=1
IF (STEPNO) I=6
DSP(I)=P(1)/10
DSP(I+1)=P(1)-10*DSP(I)
IF (DSP(I).EQ.0) DSP(I)=15
DSP(I+2)=13
RETURN
C ** START1 - UPDATE DISPLAY CONTENTS
2 IF (OP(1).GE.70) GO TO 20
IF (.NOT.FIXFLG) GO TO 10
C DISPLAY IN "FIX" FORMAT, IF POSSIBLE
IF (X(1,16).GT.0 .AND. X(1,15).NE.13) GO TO 10
N=FIX
K=FIX+1
KMAX=10*X(1,16)+X(1,17)
IF (X(1,15).NE.13) GO TO 3
K=K-KMAX
IF (K.GE.0) GO TO 4
K=N+2
GO TO 6
3 K=K+KMAX
IF (K.LE.10) GO TO 4
N=9-KMAX
K=10
4 CALL ROUND
IF (W(16).GT.0 .AND. W(15).NE.13) GO TO 10
K=10*W(16)+W(17)+1
IF (W(15).EQ.13) GO TO 6
DO 5 I=1,K
5 D(I+1)=W(I+1)
J=K
K=K+1
KMAX=K+N
D(K+1)=11
GO TO 8
6 D(2)=0
D(3)=11
DO 7 I=3,K
7 D(I+1)=0
J=0
KMAX=N+2
8 K=K+1
IF (K.GT.KMAX) GO TO 9
J=J+1
D(K+1)=W(J+1)
GO TO 8
9 KMAX=15
GO TO 16
C DISPLAY IN "SCI" FORMAT
10 IF (.NOT.STEPNO) GO TO 11
IF (SCI.LT.7) GO TO 11
N=6
GO TO 12
11 N=SCI
12 K=N
CALL ROUND
D(2)=W(2)
D(3)=11
IF (W(15).NE.42) GO TO 13
IF (.NOT.STEPNO) N=10
IF (STEPNO) N=6
W(15)=15
13 DO 14 I=2,N
14 D(I+2)=W(I+1)
D(13)=12
DO 15 I=13,15
15 D(I+1)=W(I+2)
K=N+2
IF (K.GT.11) GO TO 18
KMAX=11
16 DO 17 I=K,KMAX
17 D(I+1)=15
C X(1) ≡ 0 ?
18 IF (X(1,2).NE.0) GO TO 20
DO 19 I=2,12
IF (D(I).NE.11) GO TO 19
D(I)=15
GO TO 20
19 CONTINUE
C ** START 2 - FORMAT DISPLAY CONTENTS
20 DO 21 II=1,16
DSP(II)=15
21 DISPLY(II)=D(II)
DSP(1)=X(1,1)
C DISPLAY FUNCTION?
IF (OP(1).LT.70) GO TO 22
DSP(3)=11
DSP(4)=0
DSP(5)=X(1,2)/10
DSP(6)=X(1,2)-10*DSP(5)
DSP(7)=11
DSP(8)=X(1,3)
IF (X(1,3).EQ.X(1,4)) GO TO 36
DSP(9)=13
DSP(10)=X(1,4)
GO TO 36
C X(0) = "NULL" ?
22 IF (X(1,2).NE.15) GO TO 23
IF (M.EQ.1) GO TO 36
C DISPLAY PROGRAM POINTER?
23 IF (STEPNO) GO TO 33
C COPY D TO DSP, INSERTING SPACING BLANKS
I=1
K=0
J=0
N=0
24 N=N+1
IF (D(N+1).GT.9) GO TO 25
K=K+1
IF (K.NE.3) GO TO 24
K=0
J=J+1
GO TO 24
25 N=1
26 IF (K.EQ.0) GO TO 28
IF (D(N+1).GT.11) GO TO 31
27 IF (I.GT.15) GO TO 33
DSP(I+1)=D(N+1)
I=I+1
N=N+1
K=K-1
GO TO 26
28 IF (J.EQ.0) GO TO 30
IF (I.EQ.1) GO TO 29
IF (I.EQ.16) GO TO 29
DSP(I+1)=15
I=I+1
29 K=3
J=J-1
GO TO 26
30 IF (D(N+1).EQ.12) GO TO 32
K=4
J=10
GO TO 27
31 IF (D(13).NE.12) GO TO 36
32 K=13
IF (I.LT.13) GO TO 34
33 K=2
34 DO 35 II=K,16
35 DSP(II)=D(II)
IF (DSP(13).NE.12) GO TO 36
IF (DSP(15).NE.0) GO TO 36
DSP(15)=DSP(16)
DSP(16)=15
C
36 DO 37 II=1,16
37 DISPLY(II+16)=DSP(II)
C
C COPY DSP TO DSP, RIGHT JUSTIFYING MANTISSA
K=11
38 IF (DSP(K+1).NE.15) GO TO 39
IF (K.EQ.0) RETURN
K=K-1
GO TO 38
39 IF (.NOT.STEPNO) GO TO 41
IF (DSP(13).NE.12) GO TO 40
N=11
IF (K.GT.7) K=7
GO TO 42
40 N=15
GO TO 42
41 IF (K.GT.9) RETURN
N=10
IF (DSP(9).EQ.13) N=12
42 DSP(N+1)=DSP(K+1)
IF (K.EQ.0) GO TO 43
N=N-1
K=K-1
GO TO 42
43 DO 44 I=1,N
44 DSP(I)=15
RETURN
END
SUBROUTINE MESAGE (TYPE, ERR, RTRN)
C DATE OF LAST CHANGE - 751116
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, RUNPGM, STEPNO, TEMPF, TEMPF2
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 (5, 5, 5, 1, 2, 3, 3), TYPE
1 IF (CODE.EQ.28) GO TO 20
IF (CODE.EQ.27) GO TO 20
IF (CODE.EQ.26) GO TO 19
GO TO 5
2 TEMPF2=NEXT
3 UFLAG(11)=1
IF (UFLAG(10).NE.1) GO TO 5
ERROR=0
DO 4 I=2,10
IF (R(20,I).NE.15) GO TO 4
R(20,I)=ERR/10
R(20,I+1)=ERR-10*R(20,I)
R(20,I+2)=13
R(20,13)=42
RETURN
4 CONTINUE
RETURN
C DISPLAY ERROR
5 ERROR=ERR
NEXT=.FALSE.
DO 6 I=1,16
6 DSP(I)=15
C KEYBOARD ERROR MESSAGE → "DSP"
DSP(4)=12
DO 7 I=5,8
7 DSP(I)=25
DSP(7)=21
DSP(10)=ERROR/10
DSP(11)=11
DSP(12)=ERROR-10*DSP(10)
IF (TYPE.GT.3) DSP(14)=25
C MODIFY MESSAGE FOR PROGRAM ERROR, MAYBE
IF (RUNPGM) GO TO 8
IF (.NOT.STEPNO) GO TO 10
8 J=13
K=15
9 DSP(K+1)=DSP(J+1)
J=J-1
K=K-1
IF (J.GT.2) GO TO 9
DSP(5)=15
CALL STPNUM (2)
10 ERROR=0
C LOOK FOR AND ACT ACCORDING TO USER'S RESPONSE
I=LSTK
J=CODE
11 CALL CONTRL (5, 2)
IF (CODE.NE.28) GO TO 16
CODE=I
GO TO (13, 20, 20, 13, 15, 14, 12), TYPE
12 TEMPF=.TRUE.
13 RTRN=0
RETURN
14 IF (OP(1).NE.0) OP(1)=0
15 CODE=-1
GO TO 20
16 IF (CODE.NE.27) GO TO 18
CODE=I
GO TO (13, 20, 15, 15, 17, 17, 17), TYPE
17 RTRN=0
CODE=J
IF (TYPE.EQ.5) NEXT=TEMPF2
RETURN
18 IF (CODE.NE.26) GO TO 11
19 NEXT=.TRUE.
20 RTRN=1
RETURN
END
SUBROUTINE FIXN
C DATE OF LAST CHANGE - 741108
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.TRUE.
LFRC=0
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, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.FALSE.
LFRC=0
CALL NUMBER (1, RTRN)
IF (RTRN.EQ.1) GO TO 1
SCI=W(2)+1
1 RETURN
END
SUBROUTINE RESET
C DATE OF LAST CHANGE - 741024
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, 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 CLEAR
C DATE OF LAST CHANGE - 740920
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, 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(10), X(10,17), OP(10), 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.15) GO TO 3
CALL MESAGE (2, 92, 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 (START)
C DATE OF LAST CHANGE - 750716
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (START.EQ.2) GO TO 11
C ** START 1 - NORMAL ENTRY FOR ")"
IF (OP(1).LT.2) GO TO 2
1 CALL MESAGE (2, 11, RTRN)
RETURN
2 DO 3 I=1,SMAX
IF (P(I).NE.0) GO TO 4
3 CONTINUE
CALL MESAGE (2, 21, 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 (2, 53, 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 14
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 14
RETURN
9 CONTINUE
CALL MESAGE (2, 36, RTRN)
RETURN
10 IF (X(1,2).NE.15) GO TO 11
CALL MESAGE (6, 23, RTRN)
IF (RTRN.EQ.1) GO TO 14
C ** START 2 - ENTRY FROM CORRECT TO REMOVE A "("
11 P(1)=P(1)-1
IF (P(1).NE.0) RETURN
IF (X(1,2).NE.15) GO TO 13
C HERE TO STATEMENT 13 FIXES UP "()"
IF (OP(2)/10.NE.5) GO TO 12
IF (OP(2).EQ.51) X(2,2)=15
OP(2)=0
12 CALL DROP (1)
IF (OP(1).LT.71) RETURN
IF (OP(1).EQ.72) RETURN
CALL DROP (1)
RETURN
13 IF (OP(2).LT.70) RETURN
PTR=2
CALL EXECUT (2, RTRN)
14 RETURN
END
SUBROUTINE EQUAL
C DATE OF LAST CHANGE - 741024
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), 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 (2, 11, RTRN)
RETURN
2 DO 3 I=1,SMAX
IF (P(I).EQ.0) GO TO 3
CALL MESAGE (2, 22, 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(10), X(10,17), OP(10), 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(10), X(10,17), OP(10), D(16), DSP(16), SMAX
IF (OP(1).EQ.0) GO TO 2
1 CALL MESAGE (2, 16, RTRN)
RETURN
2 IF (X(1,2).NE.15) GO TO 1
IF (P(1).NE.0) GO TO 1
IF (OP(2).EQ.50) OP(2)=0
CALL DROP (1)
RETURN
END
SUBROUTINE SIGN
C DATE OF LAST CHANGE - 750416
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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, 52, RTRN)
RETURN
3 IF (X(SMAX,2).EQ.15) GO TO 4
CALL MESAGE (2, 91, 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(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, 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 (2, 12, 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(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 ARGUMENT FUNCTION
1 PTR=2
TEMP=2
IF (CODE.EQ.49) TEMP=6
C ** START 2 - VARIABLE ARGUMENT M.A.F. (PTR & TEMP ALREADY SET)
2 NEXT=.TRUE.
GO TO 4
C ** START 3 - SINGLE ARGUMENT FUNCTION
3 PTR=1
TEMP=1
NEXT =.FALSE.
4 TEMPF=.FALSE.
5 CALL FTSTUP (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 ARGUMENT FUNCTION
6 OP(1)=72
7 NEXT=.FALSE.
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, 52, RTRN)
IF (RTRN.EQ.1) GO TO 12
GO TO 7
C ** START 4 - "IMMEDIATE" SINGLE ARGUMENT FUNCTION
9 IF (X(1,2).EQ.15) GO TO 10
IF (OP(1).LT.2) GO TO 11
10 CALL MESAGE (2, 12, 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 COMMA
C DATE OF LAST CHANGE - 750701
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C TREAT AS ARGUMENT SEPARATOR FOR "M.A.F."?
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, 22, 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 (2, 54, 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(10), X(10,17), OP(10), 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 (X(2,2).EQ.15) GO TO 1
IF (P(1).EQ.0) GO TO 2
1 CALL MESAGE (2, 15, RTRN)
RETURN
C- FOLLOWING 5 LINES ARE BASED ON M.A.F.'S CALLING "LPAREN"
C- 2 IF (OP(2).LT.72) GO TO 4
C- IF (OP(1).NE.0) GO TO 1
C- CALL DROP (1)
C- FOLLOWING LINE NOT USED WHEN M.A.F.'S CALL "LPAREN"
2 IF (OP(1).LT.72) GO TO 4
IF (X(3,2).EQ.15) GO TO 1
OP(3)=OP(1)
OP(1)=0
DO 3 I=1,17
TEMP=X(1,I)
X(1,I)=X(2,I)
X(2,I)=X(3,I)
3 X(3,I)=TEMP
PTR=3
GO TO 9
4 IF (OP(1).LT.20) GO TO 8
IF (OP(2).LT.20) GO TO 5
IF (OP(2).NE.50) GO TO 1
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 1
9 CALL EXECUT (1, RTRN)
RETURN
END
SUBROUTINE COLAPS (RTRN)
C DATE OF LAST CHANGE - 740809
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), 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(6,17)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, 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,68*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
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, 0, RTRN)
IF (RTRN.EQ.1) GO TO 14
DO 2 N=1,17
2 X(1,N)=A(1,N)
GO TO 12
C EXECUTE "M.A.F."
3 IF (OP(PTR).EQ.73) GO TO 5
OPCD=OP(PTR)+X(PTR,2)
CALL COMBIN (A, 2, 0, RTRN)
IF (RTRN.EQ.1) GO TO 14
GO TO 10
C ** START 2 - SINGLE ARGUMENT FUNCTIONS
4 IF (OP(2).LT.71) GO TO 6
5 CALL ARGMNT (3, RTRN)
RETURN
C SAVE X(1,N) IN "LST X"; EXECUTE "S.A.F."
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, 0, RTRN)
IF (RTRN.EQ.1) GO TO 14
10 DO 11 N=1,17
11 X(1,N)=A(1,N)
IF (PTR.EQ.0) GO TO 13
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
C DROP STACK APPROPRIATE AMOUNT
12 CALL DROP (2)
IF (PTR.LT.3) GO TO 13
PTR=PTR-1
GO TO 12
C CHECK FOR "-0"
13 IF (X(1,2).EQ.0) X(1,1)=15
14 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 COMBIN (A, NARGS, ESHIFT, RTRN)
C DATE OF LAST CHANGE - 750701
C PURPOSE: EXECUTE- "A(2,N) OPCD A(1,N) → A(1,N)"
C "SAF [A(1,N)] → A(1,N)"
C "[A(2,N)] SAF → A(1,N)"
C "MAF [A(2,N); A(1,N)] → A(1,N)"
IMPLICIT INTEGER (A-Z)
DOUBLE PRECISION RX, DABS, DLOG10, DMAX1
DIMENSION A(6,17), EXP(6), RX(6)
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)
II=2
IF (OPCD.EQ.121) II=PTR-1
DO 2 I=1,II
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 22
IF (OPCD.EQ.60) GO TO 14
IF (OPCD.GT.31) GO TO 10
IF (OPCD.GT.23) GO TO 9
IF (OPCD.GT.10) GO TO 3
CALL MESAGE (2, 38, RTRN)
RETURN
C RELATIONALS
3 VALUE=0
RX(1)=-RX(1)
CALL ADD (RX, EXP)
GO TO (4, 5, 6, 7), OPCD-19
4 IF (RX(1) .EQ. 0.0) VALUE=1
GO TO 8
5 IF (RX(1) .NE. 0.0) VALUE=1
GO TO 8
6 IF (RX(1) .GT. 0.0) VALUE=1
GO TO 8
7 IF (RX(1) .LT. 0.0) VALUE=1
8 RX(1)=VALUE
GO TO 36
C ADDITION/SUBTRACTION
9 IF (OPCD.EQ.30) RX(1)=-RX(1)
CALL ADD (RX, EXP)
GO TO 36
C MULTIPLICATION/DIVISION
10 IF (OPCD.EQ.40) GO TO 11
RX(1)=RX(2)*RX(1)
EXP(1)=EXP(2)+EXP(1)
GO TO 36
11 IF (RX(1).NE.0.0) GO TO 13
ERROR=31
12 KK=9
C- "EXP OF A"="+ OVERFLOW"
J=42
GO TO 42
13 RX(1)=RX(2)/RX(1)
EXP(1)=EXP(2)-EXP(1)
GO TO 36
C EXPONENTIATION
14 IF (RX(2)) 15, 16, 17
15 ERROR=32
RX(1)=-RX(1)
GO TO 17
16 RX(1)=0.0
EXP(1)=0
GO TO 36
17 RX(2)=RX(1)*(DLOG10(RX(2))+EXP(2))
S=1
IF (RX(2)) 18, 19, 20
18 RX(2)=-RX(2)
S=-1
GO TO 20
19 RX(1)=1.0
EXP(1)=0
GO TO 36
20 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 21
ERROR=34+ESHIFT
GO TO 12
21 RX(2)=S*RX(2)*10.0**EXP(2)
EXP(1)=RX(2)
RX(1)=10.0**(RX(2)-EXP(1))
GO TO 36
C SINGLE ARGUMENT FUNCTIONS
22 IF (NARGS.NE.1) GO TO 27
GO TO (23, 24, 26), OPCD-115
C "ABS (X)"
23 RX(1)=DABS(RX(1))
GO TO 36
C "SQRT (X)"
24 IF (RX(1).GT.0) GO TO 25
ERROR=32
RX(1)=-RX(1)
25 CALL MYSQRT(RX(1), EXP(1))
GO TO 36
C "(X)↑2"
26 RX(1)=RX(1)*RX(1)
EXP(1)=EXP(1)+EXP(1)
GO TO 36
C MULTIPLE ARGUMENT FUNCTIONS
27 GO TO (28, 32), OPCD-115
C "MAX (X, Y, ...)"
IF (PTR.EQ.3) RX(1)=DMAX1(RX(1), RX(2))
IF (PTR.EQ.4) RX(1)=DMAX1(RX(1), RX(2), RX(3))
IF (PTR.EQ.5) RX(1)=DMAX1(RX(1), RX(2), RX(3), RX(4))
IF (PTR.EQ.6) RX(1)=DMAX1(RX(1), RX(2), RX(3), RX(4),
* RX(5))
IF (PTR.EQ.7) RX(1)=DMAX1(RX(1), RX(2), RX(3), RX(4),
* RX(5), RX(6))
GO TO 36
C "MAG (X,Y)"
28 KK=EXP(2)-EXP(1)
IF (IABS(KK).LT.15) GO TO 30
IF (KK) 36, 30, 29
29 RX(1)=RX(2)
EXP(1)=EXP(2)
GO TO 36
30 DO 31 I=1,2
31 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 36
C "ARG (X,Y)"
32 IF (RX(2).NE.0.0) GO TO 34
33 RX(1)=9.0
EXP(1)=1
GO TO 36
34 EXP(2)=EXP(1)-EXP(2)
IF (EXP(2).GT.30) GO TO 33
EXP(1)=0
IF (EXP(2).GT.-30) GO TO 35
RX(1)=0.0
GO TO 36
35 RX(1)=DATAN((RX(1)/RX(2))*10.0**EXP(2))*57.29577951D0
C (3) EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
36 IF (RX(1).NE.0.0) GO TO 37
KK=0
GO TO 39
37 IF (DABS(RX(1)).GE.1.0) GO TO 38
RX(1)=RX(1)*10.0
EXP(1)=EXP(1)-1
GO TO 37
38 IF (DABS(RX(1)).LT.10.0) GO TO 39
RX(1)=RX(1)/10.0
EXP(1)=EXP(1)+1
GO TO 38
39 IF (EXP(1).GE.0) GO TO 40
EXP(1)=-EXP(1)
A(1,15)=13
GO TO 41
40 A(1,15)=15
41 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 44
ERROR=34+ESHIFT
IF (A(1,15).NE.13) GO TO 12
ERROR=33+ESHIFT
KK=0
A(1,1)=15
C- "EXP OF A"="+"
J=15
42 A(1,1)=A(2,1)
DO 43 I=2,17
43 A(1,I)=KK
A(1,15)=J
GO TO 48
C (5) CONVERT RX(1)=RX(1) TO A(1,N), N=1, ..., 14
44 IF (RX(1).GE.0.0) GO TO 45
A(1,1)=13
RX(1)=-RX(1)
GO TO 46
45 A(1,1)=15
46 A(1,2)=RX(1)
DO 47 I=3,14
J=I-1
RX(1)=10.*(RX(1)-A(1,J))
47 A(1,I)=RX(1)
48 ERR=ERROR
IF (ERROR.NE.0) CALL MESAGE (6, ERR, RTRN)
RETURN
END
SUBROUTINE ENTRY
C DATE OF LAST CHANGE - 750628
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, NEXT, TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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) GO TO 7
IF (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
IF (D(14).EQ.14) D(14)=15
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 - 750714
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 (L.EQ.14) RETURN
IF (M.EQ.16) RETURN
IF (D(13).NE.12) GO TO 2
IF (M.GT.11) RETURN
2 M=M+1
D(M)=CODE
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 - 750714
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, 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
IF (M.EQ.16) RETURN
IF (D(13).NE.12) GO TO 2
IF (M.GT.11) RETURN
2 DP=.TRUE.
M=M+1
D(M)=11
RETURN
END
SUBROUTINE ENTEXP
C DATE OF LAST CHANGE - 750828
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, 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 5
IF (D(13).NE.12) GO TO 1
CALL ADEXPD (RTRN)
IF (RTRN.EQ.1) GO TO 5
1 OP(1)=50
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 5
CALL ENTRUP
D(1)=15
X(1,1)=15
GO TO 3
2 IF (X(1,16).NE.0) RETURN
3 IF (M.NE.1) GO TO 4
M=2
L=2
X(1,2)=1
D(2)=1
CALL DECPT
4 D(13)=12
D(14)=15
D(15)=0
D(16)=15
EEX=.TRUE.
5 RETURN
END
SUBROUTINE CLEARX (START)
C DATE OF LAST BHANGE - 750104
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), 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 - 750712
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP, TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, 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 14
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.
GO TO 12
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 IF (D(13).NE.12) GO TO 12
IF (M.GT.12) GO TO 13
12 D(M)=15
13 M=M-1
RETURN
C ** START 2 - ENTRY POINT FROM "LOOK-UP"
14 IF (OP(1).EQ.0) GO TO 16
IF (OP(1).LT.70) GO TO 15
TEMP=X(1,1)
CALL CLEARX (3)
X(1,1)=TEMP
15 OP(1)=0
RETURN
16 IF (X(1,2).EQ.15) GO TO 18
17 CALL MESAGE (2, 14, RTRN)
RETURN
18 IF (X(1,1).NE.13) GO TO 19
CALL CLEARX (3)
RETURN
19 IF (P(1).NE.0) CALL RPAREN (2)
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(10), X(10,17), OP(10), 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 3
CALL MESAGE (7, 37, RTRN)
IF (RTRN.EQ.1) GO TO 6
IF (TEMPF) RETURN
IF (N.GT.0) GO TO 1
CALL CLEARX (3)
X(1,2)=0
RETURN
1 DO 2 I=2,17
2 X(1,I)=9
C- "EXP OF X(1)" = "+ OVERFLOW"
X(1,15)=42
RETURN
3 IF (N.GE.0) GO TO 4
N=-N
X(1,15)=13
GO TO 5
4 X(1,15)=15
5 X(1,16)=N/10
X(1,17)=N-X(1,16)*10
6 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(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, 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, 43, 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(6,17)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 (X(1,2).EQ.15) GO TO 2
IF (OP(1).LT.70) GO TO 3
2 CALL MESAGE (2, 13, RTRN)
RETURN
3 OPCD=0
4 LFRC=2
CODE=31
5 CALL FINDN (2, RTRN)
IF (RTRN.EQ.1) GO TO 20
IF (K.NE.0) GO TO 11
IF (CODE.NE.25) GO TO 6
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 20
IF (.NOT.TEMPF) GO TO 11
IF (OPCD.EQ.0) GO TO 4
CODE=OPCD
GO TO 5
6 IF (CODE.NE.23) GO TO 7
N=-3
RN=-3
GO TO 13
7 IF (CODE.NE.51) GO TO 8
LFRC=5
CALL FDIGIT (1, RTRN)
IF (RTRN.EQ.1) GO TO 20
IF (TEMPF) GO TO 3
GO TO 21
8 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
GO TO 3
9 CALL MESAGE (4, 51, RTRN)
IF (RTRN.EQ.1) GO TO 20
GO TO 3
10 OPCD=OPCODE(CODE-12)
GO TO 5
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
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, 45, 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)
IF (A(2,I).EQ.15) A(2,I)=0
15 CONTINUE
IF (A(2,15).EQ.0) A(2,15)=15
CALL COMBIN (A, 2, 2, RTRN)
IF (RTRN.EQ.1) GO TO 20
IF (A(1,1).EQ.0) A(1,1)=15
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(10), X(10,17), OP(10), 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(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 (4, 51, 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
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, OLD, LSTK
* /MISC3/ CNT, S(17), T(17)
DO 1 I=1,16
T(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 STPNUM (1)
CALL OUTIN (2)
IF (CODE.NE.27) GO TO 7
DO 6 I=1,16
6 DSP(I)=T(I)
RETURN
7 IF (CODE.EQ.30) GO TO 4
NEXT=.TRUE.
RETURN
END
SUBROUTINE STPNUM (START)
C DATE OF LAST CHANGE - 741231
IMPLICIT INTEGER (A-Z)
LOGICAL STEPNO
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
GO TO (1, 2, 3), START+1
C ** START 0 - COMPLEMENT "STEPNO"
1 STEPNO=.NOT.STEPNO
RETURN
C ** START 1 - DISPLAY PROGRAM POINTER?
2 IF (.NOT.STEPNO) 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(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, 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
GO TO (1, 2, 3), START
C ** START 1 - FIND FLAG NUMBER
1 LFRC=6
C ** START 2 - FIND FLAG NUMBER FOR "IF"
2 CALL FDIGIT (1, RTRN)
IF (RTRN.EQ.1) GO TO 4
IF (TEMPF) RETURN
C ** START 3 - FLAG NUMBER KNOWN (HELD IN N)
3 RN=N
CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
X(1,2)=UFLAG(RN+1)
4 RETURN
END
SUBROUTINE DCODER (CODE)
C DATE OF LAST CHANGE - 750716
IMPLICIT INTEGER (A-Z)
DIMENSION KEYS (53)
DATA KEYS /'1', '2', '3', '4', '5', '6', '7', '8', '9', '0',
* '.', 'E', '-', '+', ' ', '/', '*', '(', '↑', ')',
* ' ', '=', 'A', 'P', 'R', 'C', 'D', 'O', 'V', 'L',
* 'Z', 'J', 'N', 'I', 'H', ';', ',', 'X', 'Y', '?',
* '#', '>', '<', 'M', 'G', 'B', 'T', 'Q', 'W', 'S',
* 'F', 'K', ':'/
C 15-TH KEY IS "SHOW DISPLAY & REGISTERS" (I.E. CODE = 100)
C 53-RD KEY IS "SHOW FULL STACK" (I.E. CODE = 101)
DATA MAXKEY /53/
TYPE 4
ACCEPT 5, KEY
DO 1 I=1,MAXKEY
IF (KEY.EQ.KEYS(I)) GO TO 3
1 CONTINUE
2 CODE=99
RETURN
3 CODE=I
IF (CODE.EQ.15) CODE=100
IF (CODE.EQ.53) CODE=101
RETURN
4 FORMAT (' A?'/)
5 FORMAT (A1)
END
SUBROUTINE SETUP (RTRN)
C DATE OF LAST CHANGE - 750610
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, 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, 52, RTRN)
RETURN
3 IF (X(SMAX,2).EQ.15) GO TO 1
CALL MESAGE (2, 91, RTRN)
4 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(10), X(10,17), OP(10), 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 (2, 91, RTRN)
2 RETURN
END
SUBROUTINE FTSTUP (RTRN)
C DATE OF LAST CHANGE - 751020
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, OLD, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
DO 1 I=1,SMAX
J=SMAX-I+1
IF (X(J,2).NE.15) GO TO 2
1 CONTINUE
RETURN
2 I=I-1
K=PTR+1
IF (I.GE.K) GO TO 6
IF (X(1,2).EQ.15) GO TO 5
IF (OP(1).NE.1) GO TO 3
IF (CODE.LT.80) GO TO 5
GO TO 4
3 IF (OP(2).LT.50) GO TO 4
IF (P(1).EQ.0) GO TO 5
4 CALL MESAGE (2, 93, RTRN)
RETURN
5 I=I+1
IF (I.LT.K) GO TO 4
6 CALL SETUP (RTRN)
RETURN
END
SUBROUTINE ENTRUP
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), 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(10), X(10,17), OP(10), 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=2
GO TO 4
C ** START 2 - DROP S(3), ..., S(SMAX)
2 P(1)=P(2)
J=3
GO TO 4
C ** START 3 - DROP S(PTR), ..., S(SMAX)
3 J=PTR
4 DO 5 I=J,SMAX
K=I-1
IF (K.GT.2 .AND. X(K,2).EQ.15) GO TO 6
P(K)=P(I)
OP(K)=OP(I)
DO 5 N=1,17
5 X(K,N)=X(I,N)
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 - 750716
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 6
C ** START 1 - FIND A NUMBER (0-9)
1 IF (LFRC.EQ.0) GO TO 2
CALL CONTRL (3, 2)
GO TO 3
2 CALL CONTRL (1, 2)
3 IF (CODE.GT.9) GO TO 4
W(2)=CODE
RETURN
4 IF (LFRC.NE.0) GO TO 5
NEXT=.TRUE.
RTRN=1
RETURN
5 CALL ARGMNT (1, RTRN)
IF (RTRN.EQ.1) GO TO 12
GO TO 1
C ** START 2 - NUMBER FOUND FROM EXPRESSION (HELD IN W)
6 IF (W(1).NE.13) GO TO 7
CALL MESAGE (5, 42, RTRN)
IF (RTRN.EQ.1) GO TO 12
W(1)=15
7 IF (W(15).NE.13) GO TO 8
W(2)=0
GO TO 9
8 IF (W(17).EQ.0 .AND. W(16).EQ.0) GO TO 9
CALL MESAGE (2, 41, RTRN)
RETURN
C-
9 TYPE 10
10 FORMAT (10X, 'GOT TO "NUMBER AT "START 2" SOMEHOW!'/)
RTRN=1
C-
C- 9 GO TO (10, 11), CODE-7
C- 10 CALL P (2)
C- RETURN
C- 11 CALL STORE (2)
12 RETURN
END
SUBROUTINE FINDN (START, RTRN)
C DATE OF LAST CHANGE - 750104
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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
W(1)=15
5 CALL CONTRL (3, 2)
IF (CODE.GT.9) GO TO 6
W(17)=K
K=K+1
W(K+1)=CODE
IF (K.EQ.KMAX) RETURN
GO TO 5
6 IF (K.NE.0) GO TO 7
IF (CODE.NE.18) RETURN
CALL ARGMNT (2, RTRN)
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
RETURN
9 IF (CODE.NE.26) GO TO 10
K=0
10 NEXT=.TRUE.
RETURN
END
SUBROUTINE REG (RTRN)
C DATE OF LAST CHANGE - 750801
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, TEMPF
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, 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 18
IF (K.NE.0) GO TO 11
IF (CODE.NE.25) GO TO 3
IF (IND.NE.15) GO TO 2
CALL MESAGE (4, 46, RTRN)
IF (RTRN.EQ.1) GO TO 18
GO TO 1
2 IND=IND+1
LFRC=0
GO TO 1
3 IF (CODE.NE.23) GO TO 7
IF (R(2,2).NE.15) GO TO 5
CALL MESAGE (5, 44, RTRN)
IF (RTRN.EQ.1) GO TO 18
DO 4 I=1,17
4 W(I)=0
GO TO 11
5 DO 6 I=1,17
6 W(I)=R(2,I)
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 16
IF (CODE.EQ.27) GO TO 17
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 (4, 51, RTRN)
IF (RTRN.EQ.1) GO TO 18
GO TO 1
11 IF (IND.EQ.0) GO TO 18
CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 18
RN=RN+5
IF (R(RN,2).NE.15) GO TO 13
CALL MESAGE (5, 44, RTRN)
IF (RTRN.EQ.1) GO TO 18
DO 12 I=1,17
12 W(I)=0
GO TO 15
13 DO 14 I=1,17
14 W(I)=R(RN,I)
15 IND=IND-1
GO TO 11
16 NEXT=.TRUE.
17 RTRN=1
18 RETURN
END
SUBROUTINE RANGE (RTRN)
C DATE OF LAST CHANGE - 750225
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), 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
* /MISC3/ CNT, S(17), T(17)
RTRN=0
TEMPF=.TRUE.
1 CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 6
IF (RN.NE.16) GO TO 2
CALL MESAGE (2, 41, 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)=T(I)
W(14)=0
DO 4 I=14,16
4 W(I+1)=T(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 - 751126
C PURPOSE: CONVERT W TO INTEGER IN RN; CHECK FOR RN TOO BIG
IMPLICIT INTEGER (A-Z)
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
IF (W(1).NE.13) GO TO 1
CALL MESAGE (5, 42, RTRN)
IF (RTRN.EQ.1) GO TO 2
W(1)=15
1 K=21
CALL INTGER
KMAX=RN
K=0
CALL INTGER
IF (RN.LE.KMAX+1) GO TO 2
CALL MESAGE (2, 41, RTRN)
2 RETURN
END
SUBROUTINE ARGMNT (START, RTRN)
C DATE OF LAST CHANGE - 750225
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, 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
* /MISC3/ CNT, S(17), T(17)
RTRN=0
GO TO (1, 2, 6), START
C ** START 1 - FORM GENERAL ARGUMENT?
1 IF (CODE.EQ.18) GO TO 2
CALL MESAGE (4, 51, RTRN)
RETURN
C ** START 2 - FORM GENERAL ARGUMENT!
2 IF (LFRC.NE.0) GO TO 3
CALL MESAGE (4, 55, RTRN)
RETURN
3 CODE=LFRC+80
C PTR = MINIMUM NO. OF ARGUMENTS FOR "LANGUAGE FUNCTION"
C TEMP = MAXIMUM NO. OF ARGUMENTS FOR "LANGUAGE FUNCTION"
4 PTR=1
TEMP=1
IF (CODE.GT.81 .AND. CODE.LT.86) TEMP=2
5 CALL FUNCTN (5)
RTRN=1
RETURN
C ** START 3 - RETURN ARGUMENT(S) TO "LANGUAGE FUNCTION" IN W ([&D] & T)
6 TEMP=1
7 PTR=PTR-1
IF (X(1,15).NE.13) GO TO 9
DO 8 I=1,17
8 W(I)=0
GO TO 10
9 K=6
CALL ROUND
10 CALL DROP (1)
IF (OP(1).GT.70) GO TO 16
TEMP=TEMP+1
IF (TEMP.NE.2) GO TO 13
DO 11 I=1,13
11 T(I)=W(I)
DO 12 I=14,16
12 T(I)=W(I+1)
GO TO 7
13 DO 14 I=1,13
14 D(I)=W(I)
DO 15 I=14,16
15 D(I)=W(I)
GO TO 7
16 PTR=X(1,2)-80
IF (PTR.EQ.2) OPCD=X(1,5)
IF (P(1).EQ.0) GO TO 17
CALL CLEARX (2)
GO TO 18
17 CALL DROP (1)
18 GO TO (21, 22, 23, 24, 24, 24, 19, 25, 25), PTR
19 TYPE 20, PTR
20 FORMAT (10X,'*** ERROR: RETURN CODE =',I3,' IN ARGMNT')
RETURN
21 CALL RECALL (3)
RETURN
22 CALL STORE (2)
RETURN
23 CALL SCR (2)
RETURN
24 CALL FDIGIT (2, RTRN)
RETURN
25 CALL NUMBER (2, RTRN)
RETURN
END
SUBROUTINE INTGER
C DATE OF LAST CHANGE - 750731
IMPLICIT INTEGER (A-Z)
COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, S(17), T(17)
RN=0
IF (K.GT.0) GO TO 3
1 DO 2 I=1,17
2 S(I)=W(I)
GO TO 5
3 IF (R(K,2).EQ.15) RETURN
DO 4 I=1,17
4 S(I)=R(K,I)
5 IF (S(15).EQ.13) RETURN
K=S(16)*10+S(17)+1
IF (K.LT.13) GO TO 6
RN=99999
RETURN
6 DO 7 I=1,K
7 RN=RN*10+S(I+1)
IF (S(1).EQ.13) RN=-RN
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(10), X(10,17), OP(10), 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
* /MISC3/ CNT, S(17), T(17)
1 DO 2 I=1,17
2 W(I)=X(1,I)
IF (K.NE.15) GO TO 3
W(15)=42
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
KMAX=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 - 750716
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /INPUT/ CODE, DECODE, EXPR(50), KEY, OLD, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
IF (START.EQ.2) GO TO 6
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.28) GO TO 5
TEMPF=.TRUE.
RETURN
5 CALL ARGMNT (1, RTRN)
IF (RTRN.EQ.1) GO TO 12
GO TO 1
C ** START 2 - DIGIT HAS BEEN FOUND FROM EXPRESSION
6 CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 12
IF (RN.GT.11) GO TO 7
IF (N.LT.11) GO TO 8
7 CALL MESAGE (2, 41, RTRN)
RETURN
8 GO TO (9, 10, 11), PTR-3
9 CALL SCR (3)
RETURN
10 CALL STORE (3)
RETURN
11 CALL FLAG (3)
12 RETURN
END