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