perm filename CHS.F4[1,VDS]1 blob
sn#118824 filedate 1974-09-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00027 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 C MAIN PROGRAM -- 'LOOK-UP'
C00016 00003 SUBROUTINE OUTPUT (SKIP)
C00024 00004 SUBROUTINE UPDATE
C00031 00005 SUBROUTINE MESAGE
C00034 00006 SUBROUTINE RESET
C00037 00007 SUBROUTINE CLEARS
C00040 00008 SUBROUTINE SETUP (*)
C00042 00009 SUBROUTINE CLEAR
C00045 00010 SUBROUTINE RPAREN
C00048 00011 SUBROUTINE EQUAL
C00050 00012 SUBROUTINE SEMI
C00053 00013 SUBROUTINE SIGN
C00056 00014 SUBROUTINE FUNCTN
C00058 00015 SUBROUTINE IMEDEX
C00060 00016 SUBROUTINE EXECUT (PTR, *)
C00064 00017 SUBROUTINE COMBIN (A, NARGS, OPER, *)
C00071 00018 SUBROUTINE CLEARX
C00074 00019 SUBROUTINE ENTRY
C00078 00020 SUBROUTINE DIGIT
C00081 00021 SUBROUTINE DECPT
C00084 00022 SUBROUTINE CORECT
C00088 00023 SUBROUTINE RECALL
C00090 00024 SUBROUTINE STORE
C00094 00025 SUBROUTINE REG (RN)
C00097 00026 SUBROUTINE FINDN (K, KMAX, RN)
C00100 00027 SUBROUTINE FIXN
C00108 ENDMK
C⊗;
C MAIN PROGRAM -- 'LOOK-UP'
C DATE OF LAST CHANGE - 740814
IMPLICIT INTEGER (A-Z)
LOGICAL START, NEXT, FIXFLG, TRUE
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA TRUE/.TRUE./
10 DO 20 I=2,21
DO 20 J=1,17
R(I,J)=0
20 R(I,2)=15
R(21,1)=15
R(21,2)=1
R(21,3)=5
R(21,17)=1
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 NO. AVAILABLE"
C ** CONTROL PARAMETERS
C SIZE = NO. OF KEYS ON KEYBOARD (SEE DECODER BELOW)
C SWITCH = OUTPUT CONTROL (0 -> NORMAL, 1 -> SHORT, 2 -> DISPLAY)
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 (0-9)
C
SIZE=48
SWITCH=1
FIXFLG=.TRUE.
FIX=2
SCI=5
C
TYPE 1000
ACCEPT 1005, START
IF (START) GO TO 30
TYPE 1001
ACCEPT 1006, SWITCH
TYPE 1002
ACCEPT 1005, START
IF (START) GO TO 30
TYPE 1003
ACCEPT 1005, FIXFLG
TYPE 1004
ACCEPT 1007, FIX, SCI
SCI=SCI+1
C CONSIDER 100 TEST EQUATIONS
30 DO 270 TEST=1,100
ERROR=0
OLD=1
DO 40 I=1,50
40 EXPR(I)=15
CALL CLEAR
TYPE 1008, TEST
CALL OUTPUT (-1)
KEY=0
C OBTAIN NEXT KEY-CODE
50 CALL CONTRL (TRUE)
C DECODE KEY-CODE
IF (NEXT) NEXT=.FALSE.
IF (CODE.GT.SIZE) GO TO 60
IF (CODE.LE.12) GO TO 70
IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 80
IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 90
IF (CODE.EQ.18) GO TO 100
IF (CODE.EQ.20) GO TO 110
IF (CODE.EQ.22) GO TO 130
IF (CODE.GT.22 .AND. CODE.LT.26 .OR.
* CODE.EQ.38 .OR. CODE.EQ.39) GO TO 140
IF (CODE.EQ.26) GO TO 150
IF (CODE.EQ.27) GO TO 160
IF (CODE.EQ.28) GO TO 170
IF (CODE.EQ.31) GO TO 180
IF (CODE.EQ.32) GO TO 190
IF (CODE.EQ.33) GO TO 200
IF (CODE.EQ.34) GO TO 210
IF (CODE.EQ.35) GO TO 220
IF (CODE.EQ.36) GO TO 230
IF (CODE.EQ.37) GO TO 240
IF (CODE.GT.39 .AND. CODE.LT.44) GO TO 90
IF (CODE.GT.43 .AND. CODE.LT.49) GO TO 120
IF (CODE.EQ.15.OR.CODE.EQ.29.OR.CODE.EQ.30) GO TO 260
C KEY-CODE ERROR?
60 IF (CODE.EQ.99) GO TO 10
ERROR=17
GO TO 250
C CALL KEY ROUTINE
70 CALL ENTRY
GO TO 250
80 CALL SIGN
GO TO 250
90 CALL OPRATR
GO TO 250
100 CALL LPAREN
GO TO 250
110 CALL RPAREN
GO TO 250
120 CALL FUNCTN
GO TO 250
130 CALL EQUAL
GO TO 250
140 CALL RECALL
GO TO 250
150 CALL CLEAR
GO TO 270
160 CALL CLEARX
GO TO 250
170 CALL CORECT
GO TO 250
180 CALL STORE
GO TO 250
190 CALL FIXN
GO TO 250
200 CALL SCIN
GO TO 250
210 CALL IMEDEX
GO TO 250
220 CALL EXCH
GO TO 250
230 CALL SEMI
GO TO 250
240 CALL COMMA
C PRINT EXPRESSION, STACK, VARIABLES
250 IF (ERROR.NE.0) CALL MESAGE
260 IF (KEY.LT.50) GO TO 50
270 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' PRODUCE "SHORT STACK" OUTPUT'
* /' DISPLAY IN FIX MODE W/ FIX=2 & SCI=5'
* //' THESE ARE OKAY. (T OR F)'/)
1001 FORMAT (/' ENTER CODE FOR DESIRED OUTPUT: 0 = LONG'/32X,
* ' 1 = SHORT'/33X,'2 = DISPLAY ONLY'/)
1002 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' (T OR F)'/)
1003 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. (T OR F)'/)
1004 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. (N <SP> M)'/)
1005 FORMAT (L1)
1006 FORMAT (I)
1007 FORMAT (2I)
1008 FORMAT ('1 TEST NO.',I3/)
END
C
C
C
C
C
C
C
C
C
C
BLOCK DATA
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
LOGICAL JUMP, NEXT, MVO, SUM
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA P /6*0/, OP /6*0/, D /16*13/, X /102*13/,
* JUMP, NEXT, MVO, SUM /4*.FALSE./,
* 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 (SKIP)
C DATE OF LAST CHANGE - 740814
IMPLICIT INTEGER (A-Z)
INTEGER*2 CHAR(48), STROKE(50), SIGN(6), ESN(6),
* DISPLY(16), REG(17)
LOGICAL EEX, DP, FIXFLG, MVO, SUM
REAL*8 NAME(3)
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
2 /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
3 /INPUTS/ CODE, EXPR, KEY
4 /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
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',' .','EE'/,
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)/'XX',' =',' A','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CX','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/' E','SV','->','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SN','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'/
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
IF (SKIP.GE.0) GO TO 20
DO 10 I=1,50
10 STROKE(I)=CHAR(15)
RETURN
20 DO 30 I=OLD,KEY
J=EXPR(I)
IF (J.EQ.0) J=10
30 STROKE(I)=CHAR(J)
TYPE 1000, (STROKE(I),I=1,KEY)
OLD=KEY+1
IF (SKIP.EQ.2) GO TO 70
DO 60 I=1,6
J=X(I,1)
IF (J.EQ.0) J=15
SIGN(I)=CHAR(J)
K=X(I,15)
IF (K.EQ.0) K=15
60 ESN(I)=CHAR(K)
70 DO 80 I=1,16
J=D(I)
IF (J.EQ.0) J=10
80 DISPLY(I)=CHAR(J)
IF (SKIP.EQ.2) GO TO 100
IF (SKIP.EQ.1) GO TO 90
TYPE 2000, DP, L, EEX, M, FIXFLG, FIX, MVO, SCI, SUM, ERROR
TYPE 3000, P(6),SIGN(6),(X(6,N),N=2,14),ESN(6),X(6,16),
2 X(6,17),OP(6),P(5),SIGN(5),(X(5,N),N=2,14),
3 ESN(5),X(5,16),X(5,17),OP(5),P(4),SIGN(4),
4 (X(4,N),N=2,14),ESN(4),X(4,16),X(4,17),OP(4),
5 P(3),SIGN(3),(X(3,N),N=2,14),ESN(3),X(3,16),
6 X(3,17),OP(3)
90 TYPE 4000, P(2),SIGN(2),(X(2,N),N=2,14),ESN(2),X(2,16),
2 X(2,17),OP(2),P(1),SIGN(1),(X(1,N),N=2,14),
3 ESN(1),X(1,16),X(1,17),OP(1)
100 TYPE 5000, DISPLY
IF (SKIP.EQ.2) RETURN
DO 120 I=2,4
IF (R(I,2).EQ.15) GO TO 120
DO 110 J=1,17
K=R(I,J)
IF (K.EQ.0) K=10
110 REG(J)=CHAR(K)
TYPE 6000, NAME(I-1), (REG(N), N=1,17)
120 CONTINUE
DO 140 I=5,20
IF (R(I,2).EQ.15) GO TO 140
J=I-5
DO 130 K=1,17
KK=R(I,K)
IF (KK.EQ.0) KK=10
130 REG(K)=CHAR(KK)
TYPE 7000, J, (REG(N), N=1,17)
140 CONTINUE
RETURN
1000 FORMAT (/6X,'EXPRESSION: ',39A3/30X,11A3)
2000 FORMAT (//14X,'FLAGS: DP -',L2,20X,'INDICES: L -',
2 I2/22X,'EEX -',L2,30X,'M -',I2/22X,
3 'FIXFLG-',L2,30X,'FIX -',I2/22X,'MVO -',L2,30X,
4 'SCI -',I2/22X,'SUM -',L2,30X,'ERROR -',I2)
3000 FORMAT (//14X,'STACK: S(6) -',4X,I2,' / ',A2,I2,' .',12I2,
2 A2,2I2,' /',I3/22X,'S(5) -',4X,I2,' / ',A2,I2,' .',
3 12I2,A2,2I2,' /',I3/22X,'S(4) -',4X,I2,' / ',A2,I2,
4 ' .',12I2,A2,2I2,' /',I3/22X,'S(3) -',4X,I2,' / ',
5 A2,I2,' .',12I2,A2,2I2,' /',I3)
4000 FORMAT (/22X,'S(2) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
2 I3/22X,'S(1) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,
3 ' /',I3/)
5000 FORMAT (/14X,'DISPLAY:',9X,16A3///)
6000 FORMAT (15X,A8,1X,2A3,' .',15A3)
7000 FORMAT (14X,'REG(',I2,') =',1X,2A3,' .',15A3)
END
SUBROUTINE UPDATE
C DATE OF LAST CHANGE - 740810
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).GT.15) RETURN
D(1)=X(1,1)
IF (D(1).EQ.14) D(1)=15
IF (.NOT.FIXFLG) GO TO 15
C DISPLAY IN "FIX" FORMAT
IF (X(1,16).GT.0) GO TO 15
IF (X(1,15).EQ.13) GO TO 5
N=X(1,17)+FIX+1
IF (N.GT.10) GO TO 15
CALL ROUND (N)
K=W(17)+2
DO 2 I=2,K
2 D(I)=W(I)
K=K+1
D(K)=11
IF (FIX.EQ.0) GO TO 4
DO 3 I=1,FIX
3 D(I+K)=W(I+K-1)
4 K=N+3
GO TO 13
5 D(2)=10
D(3)=11
K=FIX-X(1,17)+1
IF (K.LE.0) GO TO 8
CALL ROUND (K)
J=W(17)+2
DO 6 I=4,J
6 D(I)=10
DO 7 I=1,K
7 D(J+I)=W(I+1)
GO TO 12
8 IF (K.NE.0) GO TO 9
N=1
CALL ROUND (N)
IF (N.EQ.1) GO TO 9
D(FIX+3)=1
J=FIX+2
GO TO 10
9 J=FIX+3
10 DO 11 I=4,J
11 D(I)=10
12 K=FIX+4
13 DO 14 I=13,16
14 D(I)=15
GO TO 18
C DISPLAY IN "SCI" FORMAT
15 N=SCI
CALL ROUND (N)
D(13)=29
DO 16 I=14,16
16 D(I)=W(I+1)
D(2)=W(2)
D(3)=11
K=SCI+3
DO 17 I=5,K
17 D(I-1)=W(I-2)
18 DO 19 I=K,12
19 D(I)=15
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ROUND (N)
C DATE OF LAST CHANGE - 740809
C PURPOSE: ROUND X(1,I) TO N DIGITS & PUT RESULT IN W(I)
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DO 1 I=1,17
1 W(I)=X(1,I)
IF (W(2).EQ.15) W(2)=0
IF (W(N+2)-5) 9,2,4
2 K=N+3
DO 3 I=K,14
IF (W(I).GT.0) GO TO 4
3 CONTINUE
K=N+1
IF (2*(W(K)/2) .EQ. W(K)) GO TO 9
4 K=N+1
W(K)=W(K)+1
5 IF (W(K).LT.10) GO TO 9
W(K)=W(K)-10
IF (K.EQ.2) GO TO 6
K=K-1
W(K)=W(K)+1
GO TO 5
6 K=N+1
7 W(K+1)=W(K)
IF (K.EQ.2) GO TO 8
K=K-1
GO TO 7
8 W(2)=1
N=N+1
CALL EXPON (W(15), W(16), W(17), 1)
9 RETURN
END
SUBROUTINE MESAGE
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
NEXT=.FALSE.
D(1)=15
DO 1 I=2,16
1 D(I)=13
D(8)=29
D(9)=ERROR/10
D(10)=ERROR-10*D(9)
IF (ERROR.NE.17) GO TO 2
D(15)=CODE/10
D(16)=CODE-10*D(15)
2 CALL CONTRL (.TRUE.)
IF (CODE.EQ.26) GO TO 3
IF (CODE.NE.27) GO TO 2
CALL UPDATE
GO TO 4
3 CALL CLEAR
4 ERROR=0
RETURN
END
C
C
C
C
C
C
C
SUBROUTINE CONTRL (PRINT)
C DATE OF LAST CHANGE - 740704
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, PRINT
DIMENSION EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (PRINT) CALL OUTPUT (SWITCH)
IF (NEXT) RETURN
1 TYPE 3
ACCEPT 4, CODE
IF (CODE.NE.100) GO TO 2
CALL OUTPUT (0)
GO TO 1
2 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
RETURN
3 FORMAT (' ?'/)
4 FORMAT (I)
END
SUBROUTINE RESET
C DATE OF LAST CHANGE - 740210
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
L=1
M=1
DP=.FALSE.
EEX=.FALSE.
CALL UPDATE
RETURN
END
C
C
C
C
C
C
C
C
C
SUBROUTINE TESTUP (*)
C DATE OF LAST CHANGE - 740625
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
IF (X(6,2).EQ.15) RETURN
IF (OP(2).LT.50) GO TO 1
IF (P(1).EQ.0) RETURN
1 ERROR=3
RETURN 1
END
C
C
C
C
C
C
C
C
C
SUBROUTINE ENTRUP
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
DO 1 I=1,5
J=6-I
K=J+1
P(K)=P(J)
OP(K)=OP(J)
DO 1 L=1,17
1 X(K,L)=X(J,L)
CALL CLEARS
RETURN
END
SUBROUTINE CLEARS
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
P(1)=0
CALL CLEARX
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE DROP
C DATE OF LAST CHANGE - 740725
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
1 P(1)=P(2)
C USUALLY DROP 3 -> 2, ETC.; AFTER 'CLEAR X' DROP 2 -> 1, ETC.
J=2
IF (X(1,2).EQ.15) J=1
DO 2 I=J,5
JJ=I+1
P(I)=P(JJ)
OP(I)=OP(JJ)
DO 2 K=1,17
2 X(I,K)=X(JJ,K)
IF (OP(6).EQ.0) GO TO 4
OP(6)=0
P(6)=0
DO 3 I=1,17
3 X(6,I)=0
X(6,2)=15
4 RETURN
END
SUBROUTINE SETUP (*)
C DATE OF LAST CHANGE - 740806
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).EQ.15) RETURN
IF (OP(1).NE.0) GO TO 2
CALL TESTUP (&3)
OP(1)=50
CALL COLAPS (&3)
1 CALL ENTRUP
RETURN
2 IF (OP(1).EQ.1) GO TO 4
IF (X(6,2).EQ.15) GO TO 1
ERROR=3
3 RETURN 1
4 DO 5 I=1,17
5 R(3,I)=X(1,I)
CALL CLEARX
RETURN
END
SUBROUTINE CLEAR
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
CALL CLEARS
DO 1 I=2,6
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
C
C
C
C
C
C
C
C
C
C
SUBROUTINE LPAREN
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (P(1).NE.4) GO TO 1
ERROR=2
RETURN
1 IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).NE.13) GO TO 8
CALL TESTUP (&9)
X(1,2)=1
GO TO 3
2 IF (OP(1).NE.0) GO TO 4
CALL TESTUP (&9)
3 OP(1)=50
CALL COLAPS (&9)
GO TO 7
4 IF (OP(1).NE.1) GO TO 6
DO 5 I=1,17
5 R(3,I)=X(1,I)
CALL CLEARX
GO TO 8
6 IF (X(6,2).EQ.15) GO TO 7
ERROR=3
RETURN
7 CALL ENTRUP
8 P(1)=P(1)+1
9 RETURN
END
SUBROUTINE RPAREN
C DATE OF LAST CHANGE - 740806
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(1).LT.2) GO TO 2
1 ERROR=1
RETURN
2 DO 3 I=1,6
IF (P(I).NE.0) GO TO 4
3 CONTINUE
ERROR=4
RETURN
4 IF (P(1).NE.0) GO TO 7
IF (OP(2).EQ.0) GO TO 1
IF (OP(2).NE.10) GO TO 6
DO 5 I=3,6
IF (OP(I).NE.71) GO TO 5
PTR=I
GO TO 11
5 CONTINUE
GO TO 1
6 CALL EXECUT (2, &13)
GO TO 4
7 P(1)=P(1)-1
IF (P(1).NE.0) GO TO 12
IF (X(1,2).NE.15) GO TO 10
IF (OP(2).NE.50) GO TO 12
C HERE TO STATEMENT 10 FIXES UP "-()"
OP(2)=0
IF (X(2,2).NE.1) GO TO 9
DO 8 I=3,14
IF (X(2,I).NE.0) GO TO 9
8 CONTINUE
IF (X(2,16).NE.0) GO TO 9
IF (X(2,17).NE.0) GO TO 9
X(2,2)=15
9 CALL DROP
GO TO 12
10 IF (OP(2).NE.70) GO TO 12
PTR=2
11 CALL EXECUT (PTR, &13)
RETURN
12 CALL UPDATE
13 RETURN
END
SUBROUTINE EQUAL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(1).EQ.0) GO TO 1
IF (OP(1).EQ.1) RETURN
ERROR=1
RETURN
1 DO 2 I=1,6
IF (P(I).EQ.0) GO TO 2
ERROR=4
RETURN
2 CONTINUE
3 IF (OP(2).EQ.0) GO TO 4
CALL EXECUT (2, &5)
GO TO 3
4 OP(1)=1
CALL UPDATE
5 RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXCH
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
DO 1 I=1,17
W=X(1,I)
X(1,I)=X(2,I)
1 X(2,I)=W
CALL UPDATE
RETURN
END
SUBROUTINE SEMI
C DATE OF LAST CHANGE - 740730
IMPLICIT INTEGER (A-Z)
LOGICAL MVO, SUM, IF
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA IF /.FALSE./
IF (.NOT.MVO) GO TO 3
C TREAT AS ARGUMENT SEPARATOR FOR "MVO"
DO 1 I=2,6
IF (OP(I).NE.71) GO TO 1
IF (P(I-1).EQ.1) GO TO 2
ERROR=4
RETURN
1 CONTINUE
2 CALL OPRATR
RETURN
3 IF (.NOT.SUM) GO TO 4
C TREAT AS ARGUMENT SEPARATOR FOR "SIGMA"
C- CALL SIGMA (3)
RETURN
4 IF (.NOT.IF) GO TO 5
C TREAT AS STRING SEPARATOR FOR "IF"
C- CALL IF (2)
C RETURN
C TREAT AS GENERAL ARGUMENT SEPARATOR
5 IF (X(1,2).EQ.15) GO TO 6
IF (OP(1).LT.2) GO TO 7
6 ERROR=1
RETURN
7 OP(1)=10
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE COMMA
C DATE OF LAST CHANGE - 740723
LOGICAL SUM
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
C- IF (SUM) CALL SIGMA (2)
RETURN
END
SUBROUTINE SIGN
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
IF (OP(1).NE.0) GO TO 2
IF (X(1,2).EQ.15) GO TO 4
1 OP(1)=CODE+17
CALL COLAPS (&5)
RETURN
2 IF (OP(1).EQ.1) GO TO 1
IF (X(6,2).EQ.15) GO TO 3
ERROR=3
RETURN
3 CALL ENTRUP
4 IF (CODE.NE.13) RETURN
IF (X(1,1).EQ.13) D(1)=15
IF (X(1,1).NE.13) D(1)=13
X(1,1)=D(1)
5 RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE OPRATR
C DATE OF LAST CHANGE - 740722
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).LT.2) GO TO 2
1 ERROR=1
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.GT.36) OP(1)=CODE-20
CALL COLAPS (&3)
3 RETURN
END
SUBROUTINE FUNCTN
C DATE OF LAST CHANGE - 740902
IMPLICIT INTEGER (A-Z)
LOGICAL MVO, NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (CODE.EQ.48) GO TO 4
C ** START 1 - MULTIPLE VARIABLE FUNCTION
IF (CODE.EQ.44 .OR. CODE.EQ.45) MVO=.TRUE.
C ** START 2 - SINGLE VARIABLE FUNCTION
CALL SETUP (&5)
X(1,2)=CODE
D(1)=15
IF (.NOT.MVO) GO TO 3
OP(1)=71
CALL CONTRL (.FALSE.)
IF (CODE.EQ.18) GO TO 2
1 ERROR=1
RETURN
2 NEXT=.TRUE.
RETURN
3 OP(1)=70
RETURN
C ** START 3 - "IMMEDIATE" SINGLE VARIABLE FUNCTION
4 IF (OP(1).GT.1) GO TO 1
OP(1)=0
PTR=0
CALL EXECUT (PTR, &5)
5 RETURN
END
SUBROUTINE IMEDEX
C DATE OF LAST CHANGE - 740730
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(1).EQ.1) RETURN
IF (OP(1).EQ.0) GO TO 1
IF (X(1,2).EQ.15) GO TO 1
IF (OP(2).LT.20 .OR. OP(2).EQ.50) GO TO 2
1 ERROR=1
RETURN
2 OP(2)=OP(1)
OP(1)=0
PTR=2
IF (OP(2).EQ.70) CALL EXCH
CALL EXECUT (PTR, &3)
3 RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE COLAPS (*)
C DATE OF LAST CHANGE - 740809
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
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 (PTR, &2)
GO TO 1
2 RETURN 1
END
SUBROUTINE EXECUT (PTR, *)
C DATE OF LAST CHANGE - 740903
IMPLICIT INTEGER (A-Z)
LOGICAL MVO
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17), A(2,17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA A/34*0/
IF (OP(2).EQ.70 .OR. PTR.EQ.0) GO TO 4
C ** START 1
C SAVE X(2,N) IN "LST X" & X(1,N) IN "LST Y"
DO 1 I=1,2
DO 1 N=1,17
R(5-I,N)=X(I,N)
1 A(I,N)=X(I,N)
IF (OP(PTR).EQ.71) GO TO 3
C EXECUTE BINARY FUNCTION
CALL COMBIN (A, 2, OP(2), &12)
DO 2 N=1,17
2 X(1,N)=A(1,N)
GO TO 10
C EXECUTE "MVO"
3 OPER=OP(PTR)+X(PTR,2)
CALL COMBIN (A, 2, OPER, &12)
MVO=.FALSE.
GO TO 8
C ** START 2
C SAVE X(1,N) IN "LST X"; EXECUTE "SVO"
4 DO 5 N=1,17
R(3,N)=X(1,N)
5 A(1,N)=X(1,N)
IF (PTR.NE.0) GO TO 6
OPER=70+CODE
GO TO 7
6 OPER=OP(2)+X(2,2)
7 CALL COMBIN (A, 1, OPER, &12)
8 DO 9 N=1,17
9 X(1,N)=A(1,N)
IF (PTR.EQ.0) GO TO 11
C CONSIDER SIGN PRECEEDING FUNCTION
IF (X(PTR,1).NE.13) GO TO 10
SIGN=X(1,1)
IF (SIGN.EQ.13) X(1,1)=14
IF (SIGN.NE.13) X(1,1)=13
C DROP STACK APPROPRIATE AMOUNT
10 CALL DROP
IF (PTR.LT.3) GO TO 11
PTR=PTR-1
GO TO 10
11 CALL UPDATE
RETURN
12 RETURN 1
END
SUBROUTINE COMBIN (A, NARGS, OPER, *)
C DATE OF LAST CHANGE - 740814
C PURPOSE: EXECUTE- "A(2,N) OPER 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 RX(2), X1, ALOG10, ABS, ALOG, EXP, E
DIMENSION R(21,17), W(17), A(2,17)
COMMON /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
C CONVERT A(I,N) TO RX(I)
DO 2 I=1,2
RX(I)=A(I,14)
DO 1 J=1,12
K=14-J
1 RX(I)=0.1*RX(I)+A(I,K)
IF (A(I,1).EQ.13) RX(I)=-RX(I)
J=10*A(I,16)+A(I,17)
IF (J.GT.30) J=30
IF (A(I,15).EQ.13) J=-J
2 RX(I)=RX(I)*10.0**J
X1=RX(1)
IF (OPER.GT.60) GO TO 14
C NOW EXECUTE RX(2), OPER, RX(1) -> RX(1)=X1
IF (OPER.GT.31) GO TO 3
IF (OPER.LT.30) GO TO 8
C ADDITION/SUBTRACTION
IF (OPER.EQ.30) X1=-X1
X1=RX(2)+X1
GO TO 22
3 IF (OPER.GT.50) GO TO 7
IF (OPER.EQ.40) GO TO 4
C MULTIPLICATION/DIVISION
X1=RX(2)*X1
GO TO 22
4 IF (X1.GT.1.0E-30) GO TO 6
5 ERROR=7
RETURN 1
6 X1=RX(2)/X1
GO TO 22
C EXPONENTIATION
7 IF (RX(2).LE.0.0) GO TO 5
X1=X1*ALOG(RX(2))
IF (ABS(X1).GT.174) ERROR=8
IF (ABS(X1).GT.174.) X1=174.*X1/ABS(X1)
X1=EXP(X1)
GO TO 22
C RELATIONALS
8 VALUE=0
GO TO (9, 10, 11, 12), OPER-19
9 IF (RX(2) .EQ. X1) VALUE=1
GO TO 13
10 IF (RX(2) .NE. X1) VALUE=1
GO TO 13
11 IF (RX(2) .GT. X1) VALUE=1
GO TO 13
12 IF (RX(2) .LT. X1) VALUE=1
13 X1=VALUE
GO TO 22
C EXECUTE SPECIAL FUNCTIONS
14 IF (NARGS.NE.1) GO TO 18
C SINGLE VARIABLE FUNCTIONS
GO TO (15, 16, 17) OPER-115
15 X1=ABS(X1)
GO TO 22
16 X1=SQRT(X1)
GO TO 22
17 X1=RX(1)*RX(1)
GO TO 22
C MULTIPLE VARIABLE FUNCTIONS
18 IF (OPER.LT.75) GO TO 5
GO TO (19, 20) OPER-114
19 X1=SQRT(X1*X1+RX(2)*RX(2))
GO TO 22
20 IF (ABS(X1).GT.1.E-20) GO TO 21
ERROR=8
RETURN 1
21 X1=ATAN(X1/RX(2))*180./3.14159
C EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
22 IF (X1.EQ.0.) GO TO 23
E=ALOG10(ABS(X1))+.00001
GO TO 24
23 K=0
GO TO 26
24 IF (E.GE.0.0) GO TO 25
K=-E+1
X1=X1*10.0**K
A(1,15)=13
GO TO 27
25 K=E
X1=X1/10.0**K
26 A(1,15)=14
27 A(1,16)=K/10
A(1,17)=K-10*A(1,16)
C CONVERT X1=RX(1) TO A(1,N), N=1, ..., 14
IF (X1.GE.0.0) GO TO 28
A(1,1)=13
X1=-X1
GO TO 29
28 A(1,1)=14
29 A(1,2)=X1
DO 30 I=3,14
J=I-1
X1=10.*(X1-A(1,J))
30 A(1,I)=X1
RETURN
END
SUBROUTINE CLEARX
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
OP(1)=0
C THIS STATEMENT IS NUMBERED FOR REFERENCE IN 'CORECT'
1 X(1,1)=15
X(1,2)=15
DO 2 I=3,17
2 X(1,I)=0
CALL RESET
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ADEXPD (*)
C DATE OF LAST CHANGE - 740717
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
C ADD EXPONENT OF D TO THAT OF X(1)
J=10*X(1,16)+X(1,17)
IF (X(1,15).EQ.13) J=-J
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
J=J+K
IF (J.GE.0) GO TO 1
J=-J
X(1,15)=13
GO TO 2
1 X(1,15)=14
2 X(1,16)=J/10
X(1,17)=J-X(1,16)*10
IF (X(1,16).LT.10) RETURN
ERROR=8
RETURN 1
END
SUBROUTINE ENTRY
C DATE OF LAST CHANGE - 740809
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, JUMP, NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
CALL SETUP (&11)
DO 1 I=2,16
1 D(I)=15
2 IF (CODE.GT.10) 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
GO TO 12
5 IF (CODE.NE.28) GO TO 6
JUMP=.TRUE.
CALL CORECT
IF (.NOT.JUMP) GO TO 12
JUMP=.FALSE.
RETURN
GO TO 12
6 IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 7
J=10*D(15)+D(16)
IF (J.NE.0 .AND. J.NE.165) GO TO 8
D(14)=CODE
GO TO 12
C? TREATMENT OF COMMA DURING DATA ENTRY
C? (1) IGNORE IT
7 IF (CODE.EQ.37) GO TO 12
C? (2) CONSIDER AS SYNTAX ERROR
C? 7 IF (CODE.NE.37) GO TO 8
C? ERROR=1
C? CALL MESAGE
C? GO TO 8
C? (3) ACCEPT AND DISPLAY (REQUIRES FURTHER CHANGES, ABOVE & ELSEWHERE)
C? 7 IF (CODE.NE.37) GO TO 8
C? COMMA(M)=1
C? GO TO 12
C? END OF TREATMENT OF COMMA
8 IF (X(1,2).EQ.15) GO TO 9
IF (D(13).EQ.29) CALL ADEXPD (&11)
GO TO 10
9 X(1,2)=0
10 CALL RESET
NEXT=.TRUE.
11 RETURN
12 IF (ERROR.NE.0) RETURN
CALL CONTRL (.TRUE.)
GO TO 2
END
SUBROUTINE DIGIT
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.EEX) GO TO 1
D(15)=D(16)
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
C
C
C
C
C
C
C
C
C
C
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=14
2 B=K/10
C=K-10*B
RETURN
END
SUBROUTINE DECPT
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (DP) GO TO 1
IF (.NOT.EEX) GO TO 3
1 CALL TESTUP (&4)
IF (D(13).EQ.29) CALL ADEXPD (&4)
OP(1)=50
CALL COLAPS (&4)
CALL ENTRUP
DO 2 I=2,16
2 D(I)=15
3 DP=.TRUE.
IF (M.GT.13) RETURN
M=M+1
D(M)=11
4 RETURN
END
C
C
C
C
C
C
SUBROUTINE ENTEXP
C DATE OF LAST CHANGE - 740712
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.EEX) GO TO 1
CALL TESTUP (&2)
IF (D(13).EQ.29) CALL ADEXPD (&2)
OP(1)=50
CALL COLAPS (&2)
CALL ENTRUP
D(1)=15
X(1,1)=14
1 D(13)=29
D(14)=15
D(15)=0
D(16)=0
EEX=.TRUE.
IF (M.GT.1) RETURN
X(1,2)=1
L=2
D(2)=1
D(3)=11
M=3
DP=.TRUE.
2 RETURN
END
SUBROUTINE CORECT
C DATE OF LAST CHANGE - 740725
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP, JUMP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.JUMP) GO TO 10
C START 1: ENTRY POINT FROM "ENTRY"
JUMP=.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
C SHOULD ENTER "CLEARX" AT STATEMENT #1
3 CALL CLEARX
JUMP=.TRUE.
RETURN
4 IF (.NOT.DP) GO TO 6
IF (D(M).NE.11) GO TO 5
DP=.FALSE.
GO TO 9
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 8
IF (L.EQ.1) GO TO 9
GO TO 7
6 IF (L.EQ.1) GO TO 9
IF (L.EQ.2) GO TO 8
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
7 X(1,L)=0
L=L-1
GO TO 9
8 X(1,2)=15
L=L-1
9 D(M)=15
M=M-1
RETURN
C START 2: ENTRY POINT FROM "LOOK-UP"
10 IF (OP(1).EQ.0) GO TO 11
IF (OP(1).NE.1) OP(1)=0
RETURN
11 IF (X(1,2).NE.15 .AND. D(3).NE.15) RETURN
C SHOULD ENTER "CLEARX" AT STATEMENT #1
CALL CLEARX
RETURN
END
SUBROUTINE RECALL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (CODE-24) 1, 2, 3
1 REGNO=-3
GO TO 5
2 REGNO=-4
GO TO 6
3 IF (CODE.EQ.25) GO TO 4
REGNO=CODE-40
GO TO 5
4 CALL REG (REGNO)
IF (ERROR.NE.0) RETURN
5 IF (R(REGNO+5,2).NE.15) GO TO 6
ERROR=6
RETURN
6 CALL SETUP (&10)
IF (X(1,1).EQ.13) GO TO 7
CALL TRANS (REGNO,.FALSE.)
GO TO 9
7 CALL TRANS (REGNO,.FALSE.)
IF (X(1,1).EQ.13) GO TO 8
X(1,1)=13
GO TO 9
8 X(1,1)=14
9 CALL UPDATE
10 RETURN
END
SUBROUTINE STORE
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17), OPCD(19), A(2,17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA OPCD /12*0, 30, 31, 0, 40, 41, 0, 60/
C?
C? SHOULD "→" BE ALLOWED AFTER AN OPERATOR? (YES)
C? IF (OP(1).GT.1) GO TO 4
C?
KMAX=2
OPCODE=0
1 CALL FINDN (K,KMAX,REGNO)
IF (K.NE.0) GO TO 6
IF (CODE.NE.23) GO TO 2
REGNO=-3
NEXT=.FALSE.
GO TO 8
2 IF (CODE.NE.25) GO TO 3
CALL REG (REGNO)
IF (ERROR.NE.0) RETURN
GO TO 6
3 IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
* CODE.EQ.17 .OR. CODE.EQ.19) GO TO 5
4 ERROR=1
RETURN
5 OPCODE=OPCD(CODE)
GO TO 1
6 IF (REGNO.LE.15) GO TO 7
ERROR=5
RETURN
7 IF (REGNO.LT.0 .AND. REGNO.NE.-3) GO TO 4
C?
C? SHOULD "→" BE TREATED AS "=→"? (NO)
C? 8 IF (X(1,2).NE.15) CALL EQUAL
C? IF (ERROR.NE.0) RETURN
C?
8 IF (OP(1).EQ.0) OP(1)=1
IF (OPCODE.EQ.0) GO TO 11
K=REGNO+5
DO 9 I=1,17
A(1,I)=X(1,I)
9 A(2,I)=R(K,I)
CALL COMBIN (A, 2, OPCODE, &12)
DO 10 I=1,17
10 R(K,I)=A(1,I)
RETURN
11 CALL TRANS (REGNO,.TRUE.)
12 RETURN
END
SUBROUTINE REG (RN)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IND=0
KMAX=2
1 CALL FINDN (K,KMAX,RN)
IF (K.NE.0) GO TO 5
IF (CODE.NE.25) GO TO 2
IF (IND.EQ.15) GO TO 6
IND=IND+1
GO TO 1
2 NEXT=.FALSE.
IF (CODE.NE.23) GO TO 3
RN=(R(2,2)+0.1*R(2,3))*10**R(2,17)
GO TO 5
3 IF (CODE.NE.22) GO TO 4
RN=16
OP(1)=1
GO TO 5
4 ERROR=9
RETURN
5 IF (RN.LE.16) GO TO 7
6 ERROR=5
RETURN
7 IF (IND.EQ.0) RETURN
RN=RN+5
IF (R(RN,2).EQ.15) GO TO 8
RN=(R(RN,2)+0.1*R(RN,3))*10**R(RN,17)
IND=IND-1
GO TO 5
8 ERROR=6
RETURN
END
SUBROUTINE FINDN (K, KMAX, RN)
C DATE OF LAST CHANGE - 740227
IMPLICIT INTEGER (A-Z)
INTEGER EXPR(50)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
NEXT=.FALSE.
K=0
RN=0
1 CALL CONTRL (.FALSE.)
IF (CODE.GT.10) GO TO 4
K=K+1
KMAX=KMAX-1
IF (K.GT.1) GO TO 2
RN=CODE
GO TO 3
2 RN=10*RN+CODE
3 IF (KMAX.NE.0) GO TO 1
RETURN
4 NEXT=.TRUE.
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE TRANS (REGNO, STORE)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL STORE
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
K=REGNO+5
IF (STORE) GO TO 2
DO 1 I=1,17
1 X(1,I)=R(K,I)
RETURN
2 DO 3 I=1,17
3 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 FIXN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.TRUE.
CALL NUMBER (&1)
FIX=CODE
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.FALSE.
CALL NUMBER (&1)
SCI=CODE+1
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE NUMBER (*)
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ CODE, EXPR, KEY
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
CALL CONTRL (.FALSE.)
IF (CODE.LT.11) RETURN
NEXT=.TRUE.
CALL UPDATE
RETURN 1
END