perm filename CALC.F4[2,VDS] blob
sn#208022 filedate 1976-03-19 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00033 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 C MAIN PROGRAM -- "SYSTEM MONITOR"
C00017 00003 SUBROUTINE OUTPUT (PRINT)
C00027 00004 SUBROUTINE CONTRL (START, PRINT)
C00031 00005 SUBROUTINE DCODER (CODE)
C00035 00006 SUBROUTINE UPDATE (START)
C00046 00007 SUBROUTINE MESAGE (TYPE, ERR, RTRN)
C00052 00008 SUBROUTINE RESET
C00055 00009 SUBROUTINE RPAREN (START)
C00059 00010 SUBROUTINE EQUAL
C00063 00011 SUBROUTINE SIGN
C00066 00012 SUBROUTINE FUNCTN (START)
C00072 00013 SUBROUTINE IMEDEX
C00076 00014 SUBROUTINE EXECUT (START, RTRN)
C00080 00015 SUBROUTINE COMBIN (A, NARGS, ESHIFT, RTRN)
C00094 00016 SUBROUTINE ENTRY
C00098 00017 SUBROUTINE DIGIT
C00102 00018 SUBROUTINE ENTEXP
C00105 00019 SUBROUTINE CORECT (START)
C00109 00020 SUBROUTINE ADEXPD (RTRN)
C00112 00021 SUBROUTINE RECALL (START)
C00115 00022 SUBROUTINE STORE (START)
C00122 00023 SUBROUTINE SCR (START)
C00125 00024 SUBROUTINE LSTKEY
C00129 00025 SUBROUTINE SETUP (RTRN)
C00132 00026 SUBROUTINE FTSTUP (RTRN)
C00134 00027 SUBROUTINE ENTRUP
C00137 00028 SUBROUTINE NUMBER (START, RTRN)
C00140 00029 SUBROUTINE FINDN (START, RTRN)
C00143 00030 SUBROUTINE REG (RTRN)
C00150 00031 SUBROUTINE ARGMNT (START, RTRN)
C00156 00032 SUBROUTINE ROUND
C00159 00033 SUBROUTINE FDIGIT (RTRN)
C00162 ENDMK
C⊗;
C MAIN PROGRAM -- "SYSTEM MONITOR"
C DATE OF LAST CHANGE - 750104
IMPLICIT INTEGER (A-Z)
LOGICAL START, NEXT, FIXFLG, DECODE
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, 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 & REGISTERS, 3 -> 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 (1-10)
C SMAX = NUMBER OF REGISTERS IN THE "STACK"
C
40 DECODE=.TRUE.
SKIP=3
FIXFLG=.TRUE.
FIX=2
SCI=5
SMAX=10
C
TYPE 1000
ACCEPT 1800, START
IF (START) GO TO 70
TYPE 1100
ACCEPT 1800, DECODE
TYPE 1200
ACCEPT 1900, SKIP
IF (SKIP.GT.1) GO TO 50
TYPE 1300
ACCEPT 1900, KEY
IF (KEY.NE.R(1,11)) GO TO 40
50 TYPE 1400
ACCEPT 1800, START
IF (START) GO TO 60
TYPE 1500
ACCEPT 1800, FIXFLG
TYPE 1600
ACCEPT 1900, FIX, SCI
SCI=SCI+1
60 TYPE 1700
ACCEPT 1900, SMAX
IF (SMAX.EQ.0) SMAX=10
C CONSIDER 100 TEST EQUATIONS
70 DO 380 TEST=1,100
ERROR=0
KEY=0
DO 80 II=1,50
80 EXPR(II)=15
CALL CLEAR
TYPE 2000, TEST
CALL OUTPUT (-1)
C OUTPUT CURRENT INFO & OBTAIN NEXT KEY-CODE
90 CALL CONTRL (1, SKIP)
C DECODE KEY-CODE
IF (NEXT) NEXT=.FALSE.
IF (CODE.LE.12) GO TO 130
IF (CODE.GT.19) GO TO 100
IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 140
IF (CODE.EQ.15) GO TO 90
IF (CODE.EQ.18) GO TO 160
GO TO 150
100 IF (CODE.GT.29) GO TO 110
IF (CODE.EQ.20) GO TO 170
IF (CODE.EQ.22) GO TO 180
IF (CODE.EQ.23 .OR. CODE.EQ.24) GO TO 220
IF (CODE.EQ.25) GO TO 230
IF (CODE.EQ.26) GO TO 240
IF (CODE.EQ.27) GO TO 250
IF (CODE.EQ.28) GO TO 260
GO TO 270
110 IF (CODE.GT.39) GO TO 120
IF (CODE.EQ.31) GO TO 280
IF (CODE.EQ.32) GO TO 290
IF (CODE.EQ.33) GO TO 300
IF (CODE.EQ.34) GO TO 310
IF (CODE.EQ.35) GO TO 320
IF (CODE.EQ.36) GO TO 150
IF (CODE.EQ.37) GO TO 330
GO TO 220
120 IF (CODE.LT.44) GO TO 150
IF (CODE.EQ.44 .OR. CODE.EQ.45) GO TO 190
IF (CODE.EQ.46 .OR. CODE.EQ.47) GO TO 200
IF (CODE.EQ.48) GO TO 210
IF (CODE.EQ.49) GO TO 190
IF (CODE.EQ.50) GO TO 340
IF (CODE.EQ.51) GO TO 350
IF (CODE.EQ.52) GO TO 360
C KEY-CODE ERROR?
IF (CODE.EQ.99) GO TO 10
IF (CODE.EQ.98) STOP
GO TO 90
C CALL KEY ROUTINE
130 CALL ENTRY
GO TO 370
140 CALL SIGN
GO TO 370
150 CALL OPRATR
GO TO 370
160 CALL LPAREN
GO TO 370
170 CALL RPAREN (1)
GO TO 370
180 CALL EQUAL
GO TO 370
190 CALL FUNCTN (1)
GO TO 370
200 CALL FUNCTN (3)
GO TO 370
210 CALL FUNCTN (4)
GO TO 370
220 CALL RECALL (1)
GO TO 370
230 CALL RECALL (2)
GO TO 370
240 CALL CLEAR
GO TO 380
250 CALL CLEARX (1)
GO TO 370
260 CALL CORECT (2)
GO TO 370
270 CALL DRPSTK
GO TO 370
280 CALL STORE (1)
GO TO 370
290 CALL FIXN
GO TO 370
300 CALL SCIN
GO TO 370
310 CALL IMEDEX
GO TO 370
320 CALL EXCH
GO TO 370
330 CALL COMMA
GO TO 370
340 CALL SCR (1)
GO TO 370
350 CALL FLAG (1)
GO TO 370
360 CALL STPNUM (0)
C GO BACK AND GET ANOTHER KEY-STROKE
370 GO TO 90
380 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' ACCEPT "ENCODED" KEY-CODES'
* /' PRODUCE "DISPLAY ONLY" 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 & REGISTERS'
* /33X,'3 = DISPLAY ONLY'/)
1300 FORMAT (/' A KEYWORD IS NEEDED FOR THAT OUTPUT.'/)
1400 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' ("T" OR "F")'/)
1500 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. ("T"/"F")'/)
1600 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. ("N <SP> M")'/)
1700 FORMAT (/' ENTER NUMBER OF STACK REGISTERS WANTED',
* ' (1, 2, ..., 9, 0)'/)
1800 FORMAT (L1)
1900 FORMAT (I1, 1X, I1)
2000 FORMAT (' 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, 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(41), SIGN(10), ESN(10), REG(17),
* DISP(32), DISP2(16), NAME(3)
LOGICAL EEX, DP, NEXT, 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, 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)/'DR','LK','ST','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SI','IX','XC','; '/,
A CHAR(37),CHAR(38),CHAR(39),CHAR(40)/', ','LX','LY','EQ'/,
B CHAR(41),CHAR(42),CHAR(43),CHAR(44)/'NE','GT','LT','MG'/,
C CHAR(45),CHAR(46),CHAR(47),CHAR(48)/'AG','AB','SR','SQ'/,
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 & REGISTERS
C 3 → DISPLAY ONLY
C
SKIP2=SKIP
IF (PRINT.LT.SKIP) SKIP2=PRINT
IF (SKIP2.GE.0) GO TO 20
DO 10 II=1,41
10 STROKE(II)=CHAR(15)
RETURN
20 IF (KEY.EQ.0) GO TO 50
IF (KEY.LT.41) GO TO 40
KEY=21
DO 30 II=1,21
EXPR(II)=EXPR(II+20)
STROKE(II)=STROKE(II+20)
30 STROKE(II+20)=CHAR(15)
40 JJ=EXPR(KEY)
IF (JJ.EQ.0) JJ=10
STROKE(KEY)=CHAR(JJ)
TYPE 1000, (STROKE(II),II=1,KEY)
50 IF (SKIP2.GT.1) 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.3) 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, (/19X, 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, 1X, A2, 2I2, ' /', I3)
1300 FORMAT (14X, 'S(', I2, ') -', 4X, I2, ' / ', A2, I2, ' .',
2 12I2, 1X, A2, 2I2, ' /', I3)
1400 FORMAT (/14X, 'S( 2) -', 4X, I2, ' / ', A2, I2, ' .', 12I2,
2 1X, A2, 2I2, ' /', I3/14X, 'S( 1) -', 4X, I2, ' / ',
3 A2, I2, ' .', 12I2, 1X, 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, 'R (', I2, ') =', 2X, 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, STEPNO
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, 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 & KEY-CODE → "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 IF (STEPNO) CALL STPNUM (2)
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, DECODE
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR
CALL OUTPUT (PRINT)
LSTK=CODE
1 IF (.NOT.DECODE) GO TO 2
CALL DCODER (CODE)
IF (CODE.LT.100) GO TO 3
CALL OUTPUT (CODE-100)
GO TO 1
2 TYPE 4
ACCEPT 5, CODE
IF (CODE.NE.15) GO TO 3
CALL OUTPUT (2)
GO TO 2
3 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
IF (STEPNO) PGMPTR=PGMPTR+1
RETURN
4 FORMAT (//' NN?'/)
5 FORMAT (I2)
END
SUBROUTINE DCODER (CODE)
C DATE OF LAST CHANGE - 760319
IMPLICIT INTEGER (A-Z)
DIMENSION KEYS (90)
DATA KEYS /'1 ','2 ','3 ','4 ','5 ','6 ','7 ','8 ','9 ','0 ',
1 '. ','E ','- ','+ ',' ','/ ','* ','( ','**',') ',
2 'RR','= ','A ','PI','R ','CL','CD','CO','DR','LK',
3 'ST','FX','SI','IX','XC','; ',', ','LX','LY','EQ',
4 'NE','GT','LT','MG','AG','AB','SR','SQ','MX','SC',
5 'FL','KL','LS','U ',') ','XX','= ','A ','P ','R ',
6 'C ','D ','O ','V ','L ','Z ','J ','N ','I ','H ',
7 '; ',', ','X ','Y ','? ','# ','> ','< ','M ','G ',
8 'B ','T ','Q ','W ','S ','F ','K ',': ','SS','RS'/
DATA MAXKEY /90/
1 TYPE 4
ACCEPT 5, KEY
DO 2 I=1,MAXKEY
IF (KEY.EQ.KEYS(I)) GO TO 3
2 CONTINUE
TYPE 6, KEY
GO TO 1
3 CODE=I
IF (CODE.GT.53) CODE=CODE-35
IF (CODE.EQ.15) CODE=102
IF (CODE.EQ.21) CODE=98
IF (CODE.LT.53) RETURN
IF (CODE.EQ.53) CODE=100
IF (CODE.EQ.54) CODE=101
IF (CODE.EQ.55) CODE=99
C CODE = 98 -> TERMINATE EXECUTION
C CODE = 99 -> RESTART EXECUTION
C CODE = 100 + N -> "CALL OUTPUT (N)" UPON RETURN TO "OUTIN"
RETURN
4 FORMAT (//' AA?'/)
5 FORMAT (A2)
6 FORMAT (' "', A2, '" IS NOT A VALID CODE'/)
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
II=START+1
GO TO (1, 2, 3), II
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 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(1) = "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, 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
C SAVE ERROR CODE & RETURN FOR STANDARD FIXUP
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,15)=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, 3)
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
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
CALL CLEARX (3)
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 ARGMNT (4, RTRN)
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
* /INPUT/ CODE, DECODE, EXPR(50), KEY, 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, LSTK
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, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
GO TO ( 1, 2, 3, 9, 13), START
C ** START 1 - MULTIPLE ARGUMENT FUNCTION
1 TMP=2
TEMP=2
IF (CODE.EQ.49) TEMP=6
C ** START 2 - VARIABLE ARGUMENT M.A.F. (TMP & TEMP ALREADY SET)
2 NEXT=.TRUE.
GO TO 4
C ** START 3 - SINGLE ARGUMENT FUNCTION
3 TMP=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)=TMP
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, 3)
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 - 760205
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
DO 1 I=2,SMAX
IF (OP(I).GT.71) GO TO 2
1 CONTINUE
C TREAT AS "NO-OP"
RETURN
C TREAT AS ARGUMENT SEPARATOR FOR "M.A.F."
2 J=I-1
IF (P(J).EQ.1) GO TO 4
3 CALL MESAGE (2, 22, RTRN)
RETURN
4 K=1
5 IF (J.EQ.1) GO TO 6
IF (OP(J).EQ.10) K=K+1
J=J-1
IF (P(J).NE.0) GO TO 3
GO TO 5
6 IF (X(I,4).GT.K) GO TO 7
CALL MESAGE (2, 54, RTRN)
RETURN
7 CALL OPRATR
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 - 760201
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).LT.20) RETURN
IF (OP(1)/10 .GT. OP(2)/10) RETURN
IF (OP(1).GE.70) 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, 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 J=1,17
R(4,J)=X(1,J)
R(3,J)=X(2,J)
DO 1 I=1,2
1 A(I,J)=X(I,J)
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 J=1,17
2 X(1,J)=A(1,J)
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 J=1,17
7 A(1,J)=X(1,J)
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 J=1,17
11 X(1,J)=A(1,J)
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 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, DATAN, 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)
OPCD=OPCD-19
GO TO (4, 5, 6, 7), OPCD
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
JJ=A(2,1)
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 CALL MESAGE (6, 32, RTRN)
IF (RTRN.EQ.1) GO TO 49
RX(2)=-RX(2)
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
JJ=15
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 OPCD=OPCD-115
IF (NARGS.NE.1) GO TO 27
GO TO (23, 24, 26), OPCD
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
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
JJ=14+RX(1)/DABS(RX(1))
IF (A(1,15).NE.13) GO TO 12
ERROR=33+ESHIFT
KK=0
JJ=15
C- "EXP OF A"="+"
J=15
42 A(1,1)=JJ
DO 43 I=2,17
43 A(1,I)=KK
A(1,15)=J
GO TO 48
C (5) CONVERT 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)
49 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(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, 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, 3)
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, 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 CLEARX (START)
C DATE OF LAST CHANGE - 760205
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, 4, 5), START
C ** START 1 - "CLEAR X"
1 OP(1)=0
C ** START 2 - CLEAR X(1) & DROP X(2), ... MAYBE
2 IF (OP(2).LT.50) GO TO 4
IF (OP(2).EQ.60) GO TO 4
IF (P(1).NE.0) GO TO 4
IF (OP(2).LT.70) OP(2)=0
CALL DROP (1)
RETURN
C ** START 3 - CLEAR S(1)
3 P(1)=0
OP(1)=0
C ** START 4 - CLEAR X(1)
4 D(1)=15
X(1,1)=15
C ** START 5 - CLEAR JUST X(1,N), N=2, ..., 17
5 X(1,2)=15
DO 6 I=3,17
6 X(1,I)=0
X(1,15)=15
CALL RESET
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 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 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 (2)
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 17
IF (OP(1).LT.70) GO TO 16
IF (X(1,1).NE.13) GO TO 15
CALL CLEARX (5)
GO TO 16
15 CALL CLEARX (2)
16 OP(1)=0
RETURN
17 IF (X(1,2).EQ.15) GO TO 18
CALL MESAGE (2, 14, RTRN)
RETURN
18 IF (X(1,1).NE.13) GO TO 19
CALL CLEARX (2)
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 (4)
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, 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, 6, 7), START
C ** START 1 - EXPLICIT REGISTERS (A, PI, LST X, LST Y)
1 IF (CODE-24) 2, 3, 4
2 RN=-3
GO TO 8
3 RN=-4
GO TO 9
4 RN=CODE-40
GO TO 8
C ** START 2 - "R" REGISTERS
5 CODE=25
6 LFRC=1
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 12
IF (TEMPF) RETURN
TEMP=1
C ** START 3 - RECALL INDICATED REGISTER (RN IN W)
7 IF (TEMP.EQ.0) GO TO 5
CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 12
8 IF (R(RN+5,2).NE.15) GO TO 9
CALL MESAGE (5, 43, RTRN)
IF (RTRN.EQ.1) GO TO 12
9 CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 12
IF (X(1,1).EQ.13) GO TO 10
CALL TRANS (.FALSE.)
RETURN
10 CALL TRANS (.FALSE.)
IF (X(1,1).EQ.13) GO TO 11
X(1,1)=13
RETURN
11 X(1,1)=15
12 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, 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, 15, 24), 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 23
IF (K.NE.0) GO TO 14
IF (CODE.NE.25) GO TO 8
GO TO 7
6 LFRC=2
CODE=25
7 CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 23
IF (.NOT.TEMPF) GO TO 14
IF (OPCD.EQ.0) GO TO 4
CODE=OPCD
GO TO 5
8 IF (CODE.NE.23) GO TO 9
N=-3
RN=-3
GO TO 16
9 IF (CODE.NE.51) GO TO 11
10 LFRC=5
CODE=51
CALL FDIGIT (RTRN)
IF (RTRN.EQ.1) GO TO 23
IF (TEMPF) GO TO 3
GO TO 25
11 IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
* CODE.EQ.17 .OR. CODE.EQ.19) GO TO 13
IF (CODE.NE.28) GO TO 12
IF (OPCD.EQ.0) RETURN
GO TO 3
12 CALL MESAGE (4, 51, RTRN)
IF (RTRN.EQ.1) GO TO 23
GO TO 3
13 OPCD=OPCODE(CODE-12)
GO TO 5
14 TEMP=1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
15 IF (TEMP.EQ.0) GO TO 6
CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 23
16 KMAX=RN
DO 21 RN=N,KMAX
IF (OPCD.EQ.0) GO TO 20
K=RN+5
IF (R(K,2).NE.15) GO TO 17
CALL MESAGE (5, 45, RTRN)
IF (RTRN.EQ.1) GO TO 23
17 DO 18 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
18 CONTINUE
IF (A(2,15).EQ.0) A(2,15)=15
CALL COMBIN (A, 2, 2, RTRN)
IF (RTRN.EQ.1) GO TO 23
IF (A(1,1).EQ.0) A(1,1)=15
DO 19 I=1,17
19 R(K,I)=A(1,I)
GO TO 21
20 CALL TRANS (.TRUE.)
21 CONTINUE
22 IF (OP(1).EQ.0) OP(1)=1
23 RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
24 IF (TEMP.EQ.0) GO TO 10
25 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 26 I=N,RN
K=I+1
26 UFLAG(K)=TEMP
GO TO 22
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, 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, 7, 10), START
C ** START 1 - FIND ARGUMENT
1 CODE=50
CALL CONTRL (3, 3)
IF (CODE.NE.25) GO TO 3
2 LFRC=3
CODE=25
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 13
IF (TEMPF) GO TO 1
TEMP=1
GO TO 7
3 IF (CODE.NE.23) GO TO 4
N=-3
RN=-3
GO TO 8
4 IF (CODE.NE.51) GO TO 6
5 LFRC=4
CODE=51
CALL FDIGIT (RTRN)
IF (RTRN.EQ.1) GO TO 13
IF (TEMPF) GO TO 1
GO TO 11
6 CALL MESAGE (4, 51, RTRN)
IF (RTRN.EQ.1) GO TO 13
GO TO 1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
7 IF (TEMP.EQ.0) GO TO 2
CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 13
8 DO 9 I=N,RN
K=I+5
DO 9 J=1,17
9 R(K,J)=15
RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
10 IF (TEMP.EQ.0) GO TO 5
11 DO 12 I=N,RN
K=I+1
12 UFLAG(K)=0
13 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, LSTK
* /MISC3/ CNT, TMP, 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 (3)
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 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)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, 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, 2, 3), START
C ** START 1 - FIND FLAG NUMBER
1 LFRC=6
CODE=51
C ** START 2 - FIND FLAG NUMBER FOR "IF"
2 CALL FDIGIT (RTRN)
IF (RTRN.EQ.1) GO TO 4
IF (TEMPF) RETURN
TEMP=1
C ** START 3 - FLAG NUMBER KNOWN (HELD IN N)
3 IF (TEMP.EQ.0) GO TO 1
RN=N
CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
X(1,2)=UFLAG(RN+1)
4 RETURN
END
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, 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
IF (CODE.GT.79) OP(1)=71
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 (1)
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, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
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=TMP+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 (3)
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, 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, 3)
GO TO 3
2 CALL CONTRL (1, 3)
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 DEST=PTR-7
C- GO TO (10, 11), DEST
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, 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
W(15)=15
W(16)=0
5 CALL CONTRL (3, 3)
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, 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, TMP, 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 - 760205
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, 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, TMP, S(17), T(17)
RTRN=0
GO TO (1, 2, 6, 16), 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 TMP = MINIMUM NO. OF ARGUMENTS FOR "LANGUAGE FUNCTION"
C TEMP = MAXIMUM NO. OF ARGUMENTS FOR "LANGUAGE FUNCTION"
4 TMP=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 17
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
C ** START 4 - RETURN TO "LANGUAGE FUNCTION" & TRY AGAIN
16 TEMP=0
17 PTR=X(1,2)-80
IF (PTR.EQ.2) OPCD=X(1,5)
IF (P(1).NE.0) GO TO 18
IF (X(1,1).EQ.13) GO TO 18
CALL DROP (1)
IF (OP(1).LT.70) GO TO 19
IF (X(1,2).LT.16) OP(1)=0
GO TO 19
18 OP(1)=0
CALL CLEARX (5)
19 GO TO (22, 23, 24, 25, 25, 25, 20, 26, 26), PTR
20 TYPE 21, PTR
21 FORMAT (10X,'*** ERROR: RETURN CODE =',I3,' IN ARGMNT')
RETURN
22 CALL RECALL (3)
RETURN
23 CALL STORE (2)
RETURN
24 CALL SCR (2)
RETURN
25 CALL FDGIT2 (RTRN)
RETURN
26 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, TMP, 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, TMP, 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 (RTRN)
C DATE OF LAST CHANGE - 760208
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
C ** START 1 - FIND A DIGIT (0-9, A)
TEMPF=.FALSE.
1 CALL CONTRL (3, 3)
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) RETURN
GO TO 1
END
SUBROUTINE FDGIT2 (RTRN)
C DATE OF LAST CHANGE - 760208
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
C ** START 2 (OF "FDIGIT") - DIGIT HAS BEEN FOUND FROM EXPRESSION
IF (TEMP.EQ.0) GO TO 2
CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 6
IF (RN.GT.11) GO TO 1
IF (N.LT.11) GO TO 2
1 CALL MESAGE (2, 41, RTRN)
RETURN
2 J=PTR-3
GO TO (3, 4, 5), J
3 CALL SCR (3)
RETURN
4 CALL STORE (3)
RETURN
5 CALL FLAG (3)
6 RETURN
END