perm filename CALC.F4[2,VDS]3 blob sn#167653 filedate 1975-07-06 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00035 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00004 00002	C     MAIN PROGRAM -- "LOOK-UP"
C00016 00003	      SUBROUTINE OUTPUT (PRINT)
C00026 00004	      SUBROUTINE CONTRL (START, PRINT)
C00029 00005	      SUBROUTINE UPDATE (START)
C00039 00006	      SUBROUTINE MESAGE (ERR, RTRN)
C00046 00007	      SUBROUTINE CLEAR
C00049 00008	      SUBROUTINE RPAREN
C00053 00009	      SUBROUTINE EQUAL
C00057 00010	      SUBROUTINE SIGN
C00060 00011	      SUBROUTINE FUNCTN (START)
C00064 00012	      SUBROUTINE SEMI
C00067 00013	      SUBROUTINE IMEDEX
C00070 00014	      SUBROUTINE COLAPS (RTRN)
C00075 00015	      SUBROUTINE COMBIN (A, NARGS, RTRN)
C00085 00016	      SUBROUTINE ADD (X, K)
C00088 00017	      SUBROUTINE ENTRY
C00091 00018	      SUBROUTINE DIGIT
C00094 00019	      SUBROUTINE ENTEXP
C00097 00020	      SUBROUTINE CORECT (START)
C00101 00021	      SUBROUTINE ADEXPD (RTRN)
C00104 00022	      SUBROUTINE RECALL (START)
C00107 00023	      SUBROUTINE STORE (START)
C00114 00024	      SUBROUTINE SCR (START)
C00117 00025	      SUBROUTINE LSTKEY
C00120 00026	      SUBROUTINE FLAG (START)
C00122 00027	      SUBROUTINE SETUP (RTRN)
C00125 00028	      SUBROUTINE ENTRUP
C00128 00029	      SUBROUTINE NUMBER (START, RTRN)
C00131 00030	      SUBROUTINE FINDN (START, RTRN)
C00134 00031	      SUBROUTINE REG (RTRN)
C00138 00032	      SUBROUTINE RANGE (RTRN)
C00141 00033	      SUBROUTINE ARGMNT (START)
C00147 00034	      SUBROUTINE ROUND
C00150 00035	      SUBROUTINE FDIGIT (START, RTRN)
C00153 ENDMK
C⊗;
C     MAIN PROGRAM -- "LOOK-UP"
C         DATE OF LAST CHANGE - 750104
          IMPLICIT INTEGER (A-Z)
          LOGICAL START, NEXT, FIXFLG, TRUE
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
   10     DO 20 II=2,21
             DO 20 JJ=1,17
                IF (JJ.LT.12) UFLAG(JJ)=0
   20           R(II,JJ)=15
          R(21,2)=1
          R(21,3)=5
          DO 30 II=4,16
   30        R(21,II)=0
          R(21,17)=1
C
C      REGISTERS ARE ALLOCATED AS FOLLOWS:  R(1)="PI", R(2)="A",
C         R(3)="LST X", R(4)="LST Y", R(5)="R0", ..., R(20)="R15",
C         R(21)="HIGHEST REG NUMBER AVAILABLE"
C
C ** CONTROL PARAMETERS
C
C      SKIP   = OUTPUT CONTROL (0 -> FULL STACK, 1 -> SHORT STACK,
C                               2 -> DISPLAY, 3 -> DISPLAY & REGISTERS)
C      FIXFLG = "DISPLAY" CONTROL (T -> "FIX" MODE)
C      FIX    = NUMBER OF DECIMAL DIGITS IN "FIX" MODE (0-9)
C      SCI    = NUMBER OF DIGITS IN "SCI" MODE (1-10)
C      SMAX   = NUMBER OF REGISTERS IN THE "STACK"
C
          SKIP=3
          FIXFLG=.TRUE.
          FIX=2
          SCI=5
          SMAX=7
C
          TYPE 1000
          ACCEPT 1600, START
          IF (START) GO TO 50
             TYPE 1100
             ACCEPT 1700, SKIP
             TYPE 1200
             ACCEPT 1600, START
             IF (START) GO TO 40
                TYPE 1300
                ACCEPT 1600, FIXFLG
                TYPE 1400
                ACCEPT 1800, FIX, SCI
                SCI=SCI+1
   40        TYPE 1500
             ACCEPT 1700, SMAX
C      CONSIDER 100 TEST EQUATIONS
   50     DO 340 TEST=1,100
             ERROR=0
             CODE=-1
             OLD=1
             DO 60 II=1,50
   60           EXPR(II)=15
             CALL CLEAR
             TYPE 1900, TEST
             CALL OUTPUT (-1)
             KEY=0
C      OUTPUT CURRENT INFO & OBTAIN NEXT KEY-CODE
   70        CALL CONTRL (1, SKIP)
C      DECODE KEY-CODE
                IF (NEXT) NEXT=.FALSE.
                IF (CODE.LE.12) GO TO 80
                IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 90
                IF (CODE.EQ.15) GO TO 330
                IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 100
                IF (CODE.EQ.18) GO TO 110
                IF (CODE.EQ.20) GO TO 120
                IF (CODE.EQ.22) GO TO 130
                IF (CODE.GT.22 .AND. CODE.LT.25 .OR.
     *              CODE.EQ.38 .OR. CODE.EQ.39) GO TO 170
                IF (CODE.EQ.25) GO TO 180
                IF (CODE.EQ.26) GO TO 190
                IF (CODE.EQ.27) GO TO 200
                IF (CODE.EQ.28) GO TO 210
                IF (CODE.EQ.29) GO TO 220
                IF (CODE.EQ.31) GO TO 230
                IF (CODE.EQ.32) GO TO 240
                IF (CODE.EQ.33) GO TO 250
                IF (CODE.EQ.34) GO TO 260
                IF (CODE.EQ.35) GO TO 270
                IF (CODE.EQ.36) GO TO 280
                IF (CODE.EQ.37) GO TO 290
                IF (CODE.GT.39 .AND. CODE.LT.44) GO TO 100
                IF (CODE.EQ.44 .OR. CODE.EQ.45)  GO TO 140
                IF (CODE.EQ.46 .OR. CODE.EQ.47)  GO TO 150
                IF (CODE.EQ.48) GO TO 160
C-              IF (CODE.EQ.49) GO TO ???
                IF (CODE.EQ.50) GO TO 300
                IF (CODE.EQ.51) GO TO 310
                IF (CODE.EQ.52) GO TO 320
C      KEY-CODE ERROR?
                IF (CODE.EQ.99) GO TO 10
                   CALL MESAGE (81, RTRN)
                   GO TO 330
C      CALL KEY ROUTINE
   80           CALL ENTRY
                   GO TO 330
   90           CALL SIGN
                   GO TO 330
  100           CALL OPRATR
                   GO TO 330
  110           CALL LPAREN
                   GO TO 330
  120           CALL RPAREN
                   GO TO 330
  130           CALL EQUAL
                   GO TO 330
  140           CALL FUNCTN (1)
                   GO TO 330
  150           CALL FUNCTN (3)
                   GO TO 330
  160           CALL FUNCTN (4)
                   GO TO 330
  170           CALL RECALL (1)
                   GO TO 330
  180           CALL RECALL (2)
                   GO TO 330
  190           CALL CLEAR
                   GO TO 340
  200           CALL CLEARX (2)
                   GO TO 330
  210           CALL CORECT (2)
                   GO TO 330
  220           CALL DRPSTK
                   GO TO 330
  230           CALL STORE (1)
                   GO TO 330
  240           CALL FIXN
                   GO TO 330
  250           CALL SCIN
                   GO TO 330
  260           CALL IMEDEX
                   GO TO 330
  270           CALL EXCH
                   GO TO 330
  280           CALL SEMI
                   GO TO 330
  290           CALL COMMA
                   GO TO 330
  300           CALL SCR (1)
                   GO TO 330
  310           CALL FLAG (1)
                   GO TO 330
  320           CALL KYMODE (0)
C         GO BACK AND GET ANOTHER KEY-STROKE, MAYBE
  330           IF (KEY.LT.50) GO TO 70
  340        CONTINUE
          STOP
 1000     FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'   
     *              /'     PRODUCE "DISPLAY & REGISTERS" OUTPUT'
     *              /'     DISPLAY IN FIX MODE W/ FIX=2 & SCI=4'
     *              /'     USE A 7 LEVEL "STACK"'
     *             //' THESE ARE OKAY. ("T" OR "F")'/)
 1100     FORMAT (/' ENTER CODE FOR DESIRED OUTPUT:  0 = LONG STACK'
     *            /33X,'1 = SHORT STACK'/33X,'2 = DISPLAY ONLY'
     *            /33X,'3 = DISPLAY (& REGISTERS)'/)
 1200     FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
     *             ' ("T" OR "F")'/)
 1300     FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. ("T"/"F")'/)
 1400     FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
     *            /' AND SCI MODES, RESPECTIVELY. ("N <SP> M")'/)
 1500     FORMAT (/' ENTER NUMBER OF STACK REGISTERS WANTED (MAX = 7)'/)
 1600     FORMAT (L1)
 1700     FORMAT (I)
 1800     FORMAT (2I)
 1900     FORMAT ('1 TEST NO.',I3/)
          END







      BLOCK DATA
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT, STEP
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA NEXT /.FALSE./, STEP /.FALSE./, UFLAG /11*0/, 
     *         PGMPTR /0/, W /17*0/, LFRC /0/, TEMP/0/,
     *         R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8),
     *         R(1,9),R(1,10),R(1,11),R(1,12),R(1,13),R(1,14),R(1,15),
     *         R(1,16),R(1,17) /15,3,1,4,1,5,9,2,6,5,3,5,9,0,15,0,0/
          END
      SUBROUTINE OUTPUT (PRINT)
C         DATE OF LAST CHANGE - 741118
          IMPLICIT INTEGER (A-Z)
          DIMENSION CHAR(56), STROKE(50), SIGN(7), ESN(7), REG(17),
     *              DISP(32), DISP2(16)
          LOGICAL EEX, DP, FIXFLG, STEP
          REAL*8 NAME(3)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     2           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     3           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     4           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     5           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
          DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
     2         CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
     3         CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .',' E'/,
     4         CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +','  ',' /'/,
     5         CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
     6         CHAR(21),CHAR(22),CHAR(23),CHAR(24)/' O',' =',' A','PI'/,
     7         CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CD','CO'/,
     8         CHAR(29),CHAR(30),CHAR(31),CHAR(32)/'DS','LK','->','FX'/,
     9         CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SI','IX','XC',' ;'/,
     A         CHAR(37),CHAR(38),CHAR(39),CHAR(40)/' ,','LX','LY','=?'/,
     B         CHAR(41),CHAR(42),CHAR(43),CHAR(44)/' ≠',' >',' <','MG'/,
     C         CHAR(45),CHAR(46),CHAR(47),CHAR(48)/'AG','AB','SR','↑2'/,
     D         CHAR(49),CHAR(50),CHAR(51),CHAR(52)/' %','SC','FL','KL'/,
     E         CHAR(53),CHAR(54),CHAR(55),CHAR(56)/'XX','XX','XX','XX'/
          DATA NAME /'     A =', 'LAST X =','LAST Y ='/
C         VARIOUS VALUES OF "SKIP" GIVE:  -1 → CLEAR EXPRESSION
C                                          0 → LONG OUTPUT
C                                          1 → SHORT OUTPUT
C                                          2 → DISPLAY ONLY
C                                          3 → DISPLAY (& REGISTERS)
C
C     IF "PRINT" < "SKIP", SET "SKIP2" TO "PRINT"
          SKIP2=SKIP
          IF (PRINT.LT.SKIP) SKIP2=PRINT
          IF (SKIP2.GE.0) GO TO 20
             DO 10 II=1,50
   10           STROKE(II)=CHAR(15)
             RETURN
   20     DO 30 II=OLD,KEY
             JJ=EXPR(II)
             IF (JJ.EQ.0) JJ=10
   30        STROKE(II)=CHAR(JJ)
          TYPE 1000, (STROKE(II),II=1,KEY)
          OLD=KEY+1
          IF (SKIP2.EQ.2) GO TO 50
             KK=SMAX
             IF (SKIP2.EQ.1) KK=2
             DO 40 II=1,KK
                JJ=X(II,1)
                IF (JJ.EQ.0) JJ=10
                SIGN(II)=CHAR(JJ)
                JJ=X(II,15)
                IF (JJ.EQ.0) JJ=10
                IF (JJ.EQ.12) JJ=42
   40           ESN(II)=CHAR(JJ)
   50     DO 60 II=1,32
             JJ=DISPLY(II)
             IF (JJ.EQ.0) JJ=10
   60        DISP(II)=CHAR(JJ)
          DO 70 II=1,16
             JJ=DSP(II)
             IF (JJ.EQ.0) JJ=10
   70        DISP2(II)=CHAR(JJ)
          IF (SKIP2.GT.1) GO TO 100
          IF (SKIP2.EQ.1) GO TO 90
          TYPE 1100, DP, L, EEX, M, FIXFLG, FIX, NEXT, SCI, STEP, ERROR
          IF (SMAX.LT.3) GO TO 90
             TYPE 1200, SMAX, P(SMAX), SIGN(SMAX), (X(SMAX,NN),NN=2,14),
     2                  ESN(SMAX), X(SMAX,16), X(SMAX,17), OP(SMAX)
             IF (SMAX.EQ.3) GO TO 90
             JJ=SMAX-3
             DO 80 II=1,JJ
                KK=SMAX-II
   80           TYPE 1300, KK, P(KK), SIGN(KK), (X(KK,NN),NN=2,14),
     2                     ESN(KK), X(KK,16), X(KK,17), OP(KK)
   90     TYPE 1400, P(2), SIGN(2), (X(2,NN), NN=2,14), ESN(2), X(2,16),
     2               X(2,17), OP(2), P(1), SIGN(1), (X(1,NN), NN=2,14),
     3               ESN(1), X(1,16), X(1,17), OP(1)
          IF (SKIP2.EQ.0) TYPE 1500, DISP
  100     TYPE 1600, DISP2
          IF (SKIP2.EQ.2) RETURN
          DO 120 II=2,4
             IF (R(II,2).EQ.15) GO TO 120
                DO 110 JJ=1,17
                   KK=R(II,JJ)
                   IF (KK.EQ.0)  KK=10
                   IF (KK.EQ.12) KK=42
  110              REG(JJ)=CHAR(KK)
                TYPE 1700, NAME(II-1), (REG(NN), NN=1,17)
  120        CONTINUE
          DO 140 II=5,20
             IF (R(II,2).EQ.15) GO TO 140
                JJ=II-5
                DO 130 KK=1,17
                   LL=R(II,KK)
                   IF (LL.EQ.0)  LL=10
                   IF (LL.EQ.12) LL=42
  130              REG(KK)=CHAR(LL)
                TYPE 1800, JJ, (REG(NN), NN=1,17)
  140        CONTINUE
          DO 150 II=1,11
             IF (UFLAG(II).EQ.1) GO TO 160
  150        CONTINUE
          RETURN
  160        TYPE 1900, UFLAG
             RETURN
 1000     FORMAT (/6X, 'EXPRESSION: ', 21A3, (/18X, 21A3))
 1100     FORMAT (//14X,'FLAGS:  DP    -',L2,20X,'INDICES:  L     -',
     2            I2/22X,'EEX   -',L2,30X,'M     -',I2/22X,'FIXFLG-',
     3            L2,30X,'FIX   -',I2/22X,'NEXT  -',L2,30X,'SCI   -',
     4            I2/22X,'STEP  -',L2,30X,'ERROR -',I2)
 1200     FORMAT (//14X, 'STACK:  S(', I2, ') -', 4X, I2, ' / ', A2,
     2            I2, ' .', 12I2, A2, 2I2, ' /', I3)
 1300     FORMAT (22X, 'S(', I2, ') -', 4X, I2, ' / ', A2, I2, ' .',
     2            12I2, A2, 2I2, ' /', I3)
 1400     FORMAT (/22X, 'S( 2) -', 4X, I2, ' / ', A2, I2, ' .', 12I2,
     2            A2, 2I2, ' /', I3/22X, 'S( 1) -', 4X, I2, ' / ',
     3            A2, I2, ' .', 12I2, A2, 2I2, ' /', I3/)
 1500     FORMAT (2(/14X, 'DISPLAY:', 9X, 16A2/)//)
 1600     FORMAT (/14X, 'DISPLAY:', 9X, 16A2///)
 1700     FORMAT (15X, A8, 1X, 2A2, ' .', 15A2)
 1800     FORMAT (14X, 'REG(', I2, ') =', 1X, 2A2, ' .', 15A2)
 1900     FORMAT (/14X, 'USER FLAGS:', 6X, I2, 2X, 5I2, 2X, 4I2, I4/)
          END
      SUBROUTINE CONTRL (START, PRINT)
C         DATE OF LAST CHANGE - 750318
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
             IF (NEXT) RETURN
             GO TO (1, 2, 3, 6, 6), START
C ** START 1 - UPDATE & FORMAT "DISPLAY"
    1        CALL UPDATE (1)
             GO TO 5
C ** START 2 - FORMAT "DISPLAY"
    2        CALL UPDATE (2)
             GO TO 5
C ** START 3 - DASHES → "DISPLAY"
    3        DO 4 I=1,16
    4           DSP(I)=13
             DSP(8)=0
             DSP(9)=CODE/10
             DSP(10)=CODE-10*DSP(9)
    5        CALL KYMODE (1)
C ** START 4 - USE "DISPLAY" AS IS
    6        CALL OUTIN (PRINT)
             IF (CODE.NE.30) GO TO 7
                CALL LSTKEY
                IF (.NOT.NEXT) GO TO 6
                   NEXT=.FALSE.
    7        RETURN
             END







      SUBROUTINE OUTIN (PRINT)
C         DATE OF LAST CHANGE - 750312
          IMPLICIT INTEGER (A-Z)
          COMMON /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
             CALL OUTPUT (PRINT)
             LSTK=CODE
    1        TYPE 4
             ACCEPT 5, CODE
             IF (CODE.NE.100) GO TO 2
                CALL OUTPUT (0)
                GO TO 1
    2        KEY=KEY+1
             IF (KEY.LT.51) GO TO 3
                KEY=1
                OLD=1
                CALL OUTPUT (-1)
    3        EXPR(KEY)=CODE
             IF (CODE.EQ.10) CODE=0
             PGMPTR=PGMPTR+1
             RETURN
    4        FORMAT (' ?'/)
    5        FORMAT (I)
             END
      SUBROUTINE UPDATE (START)
C         DATE OF LAST CHANGE - 750124
C         PURPOSE:  1  - COPY X(1) TO D USING CURRENT DISPLAY FORMAT
C                        (W CONTAINS X(1) ROUNDED TO RIGHT NO. OF DIGITS)
C                   2A - COPY D TO DSP INSERTING SPACING BLANKS
C                   2B - COPY DSP TO DSP RIGHT JUSTIFYING MANTISSA
          IMPLICIT INTEGER (A-Z)
          LOGICAL FIXFLG, STEP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (START.EQ.2) GO TO 19
C ** START1 - UPDATE DISPLAY CONTENTS 
             D(1)=X(1,1)
             IF (OP(1).GE.70) GO TO 19
             IF (.NOT.FIXFLG) GO TO 9
C        DISPLAY IN "FIX" FORMAT, IF POSSIBLE
                IF (X(1,16).GT.0 .AND. X(1,15).NE.13) GO TO 9
                   N=FIX
                   K=FIX+1
                   KMAX=10*X(1,16)+X(1,17)
                   IF (X(1,15).NE.13) GO TO 1
                      K=K-KMAX
                      IF (K.LT.0) GO TO 4
                         GO TO 2
    1              K=K+KMAX
                   IF (K.LE.10) GO TO 2
                      N=9-KMAX
                      K=10
    2              CALL ROUND
                   IF (W(16).GT.0 .AND. W(15).NE.13) GO TO 9
                      K=10*W(16)+W(17)+1
                      IF (W(15).EQ.13) GO TO 5
                         DO 3 I=1,K
    3                       D(I+1)=W(I+1)
                         J=K
                         K=K+1
                         KMAX=K+N
                         D(K+1)=11
                         GO TO 7
    4                       K=N+2
    5                 D(2)=0
                      D(3)=11
                      DO 6 I=3,K
    6                    D(I+1)=0
                      J=0
                      KMAX=N+2
    7                 K=K+1
                      IF (K.GT.KMAX) GO TO 8
                         J=J+1
                         D(K+1)=W(J+1)
                         GO TO 7
    8                 KMAX=15
                      GO TO 15
C        DISPLAY IN "SCI" FORMAT
    9        IF (.NOT.STEP) GO TO 10
                IF (SCI.LT.7) GO TO 10
                   N=6
                   GO TO 11
   10        N=SCI
   11        K=N
             CALL ROUND
             D(2)=W(2)
             D(3)=11
             IF (W(15).NE.12) GO TO 12
                IF (.NOT.STEP) N=10
                IF (STEP) N=6
                W(15)=15
   12        DO 13 I=2,N
   13           D(I+2)=W(I+1)
             D(13)=12
             DO 14 I=13,15
   14           D(I+1)=W(I+2)
             K=N+2
             IF (K.GT.11) GO TO 17
                KMAX=11
   15           DO 16 I=K,KMAX
   16              D(I+1)=15
C        X(0) ≡ 0 ?
   17        IF (X(1,2).NE.0) GO TO 19
                DO 18 I=2,12
                   IF (D(I).NE.11) GO TO 18
                      D(I)=15
                      GO TO 19
   18              CONTINUE
C ** START 2 - FORMAT DISPLAY CONTENTS
   19        DO 20 II=1,16
                DSP(II)=15
   20           DISPLY(II)=D(II)
             DSP(1)=D(1)
C        DISPLAY FUNCTION?
             IF (OP(1).LT.70) GO TO 21
                DSP(3)=11
                DSP(4)=0
                DSP(5)=X(1,2)/10
                DSP(6)=X(1,2)-10*DSP(5)
                DSP(7)=11
                IF (X(1,3).EQ.X(1,4)) GO TO 35
                   DSP(8)=X(1,3)
                   DSP(9)=13
                   DSP(10)=X(1,4)
                   DSP(11)=11
                   GO TO 35
C        X(0) = "NULL" ?
   21        IF (X(1,2).NE.15) GO TO 22
                IF (M.EQ.1) GO TO 35
C        DISPLAY PROGRAM POINTER?
   22        IF (STEP) GO TO 32
C        COPY D TO DSP, INSERTING SPACING BLANKS
             I=1
             K=0
             J=0
             N=0
   23        N=N+1
             IF (D(N+1).GT.9) GO TO 24
                K=K+1
                IF (K.NE.3) GO TO 23
                   K=0
                   J=J+1
                   GO TO 23
   24        N=1
   25        IF (K.EQ.0) GO TO 27
                IF (D(N+1).GT.11) GO TO 30
   26              IF (I.GT.15) GO TO 32
                      DSP(I+1)=D(N+1)
                      I=I+1
                      N=N+1
                      K=K-1
                      GO TO 25
   27        IF (J.EQ.0) GO TO 29
                IF (I.EQ.1) GO TO 28
                   DSP(I+1)=15
                   I=I+1
   28           K=3
                J=J-1
                GO TO 25
   29        IF (D(N+1).EQ.12) GO TO 31
                K=4
                J=10
                GO TO 26
   30        IF (D(13).NE.12) GO TO 35
   31           K=13
                IF (I.LT.13) GO TO 33
   32              K=1
   33           DO 34 II=K,16
   34              DSP(II)=D(II)
             IF (DSP(13).NE.12) GO TO 35
                IF (DSP(15).NE.0) GO TO 35
                   DSP(15)=DSP(16)
                   DSP(16)=15
C
   35        DO 36 II=1,16
   36           DISPLY(II+16)=DSP(II)
C
C        COPY DSP TO DSP, RIGHT JUSTIFYING MANTISSA
             K=11
   37        IF (DSP(K+1).NE.15) GO TO 38
                K=K-1
                IF (K.GE.0) GO TO 37
                   RETURN
   38        IF (.NOT.STEP) GO TO 40
                IF (DSP(13).NE.12) GO TO 39
                   N=11
                   GO TO 41
   39           N=15
                GO TO 41
   40        IF (K.GT.9) RETURN
                N=10
   41           DSP(N+1)=DSP(K+1)
                N=N-1
                IF (K.EQ.0) GO TO 42
                   K=K-1
                   GO TO 41
   42           N=N+1
                DO 43 I=1,N
   43              DSP(I)=15
                RETURN
             END
      SUBROUTINE MESAGE (ERR, RTRN)
C         DATE OF LAST CHANGE - 750706
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT, RUNPGM, TEMPF2
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA RUNPGM /.FALSE./
             RTRN=0
             GO TO (1, 1, 2, 1, 3, 4, 4, 6), ERR
C       ERRORS 1, 2, 4, 9, ...
    1        TEMP=0
             GO TO 8
C       ERROR 3
    2        IF (CODE.EQ.28) GO TO 20
             IF (CODE.EQ.27) GO TO 20
             IF (CODE.EQ.26) GO TO 19
                TEMP=1
                GO TO 8
C       ERROR 5
    3        TEMPF2=NEXT
             GO TO 5
C       ERRORS 6 & 7
    4        TEMPF2=.FALSE.
    5        TEMP=2
             GO TO 7
C       ERROR 8
    6        TEMPF2=.FALSE.
             TEMP=3
    7        UFLAG(11)=1
             IF (UFLAG(10).EQ.1) RETURN
C       DISPLAY ERROR
    8        ERROR=ERR
             NEXT= .FALSE.
             DO 9 I=1,16
    9           DSP(I)=13
C          KEYBOARD ERROR MESSAGE → "DSP"
             DO 10 I=4,13
   10           DSP(I)=15
             DSP(5)=12
             DO 11 I=6,9
   11           DSP(I)=25
             DSP(8)=21
             DSP(11)=ERROR/10
             DSP(12)=ERROR-10*DSP(11)
             IF (ERROR.NE.7) GO TO 12
                IF (X(1,15).EQ.13) GO TO 12
                   DSP(13)=21
                   DSP(14)=15
C          MODIFY MESSAGE FOR PROGRAM ERROR, MAYBE
   12        IF (RUNPGM) GO TO 13
                IF (.NOT.STEP) GO TO 15
   13              J=12
                   K=15
   14              DSP(K+1)=DSP(J+1)
                      J=J-1
                      K=K-1
                      IF (J.GT.1) GO TO 14
                   DSP(5)=15
                   CALL KYMODE (2)
   15        ERROR=0
C       LOOK FOR AND ACT ACCORDING TO USER'S RESPONSE
             I=LSTK
             J=CODE
   16        CALL CONTRL (5, 2)
             IF (CODE.NE.27) GO TO 18
                CODE=I
                IF (TEMP.EQ.0) RETURN
                   IF (TEMP.EQ.1) GO TO 17
                      CODE=J
                      NEXT=TEMPF2
                      RETURN
   17               CODE=-1
                    GO TO 20
   18        IF (CODE.NE.28) GO TO 19
                CODE=I
                IF (TEMP.EQ.2) GO TO 17
                   IF (TEMP.EQ.3) TEMPF=.TRUE.
                   RETURN
   19        IF (CODE.NE.26) GO TO 16
                NEXT=.TRUE.
   20           RTRN=1
                RETURN
             END


      SUBROUTINE RESET
C         DATE OF LAST CHANGE - 741024
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             L=1
             M=1
             DP=.FALSE.
             EEX=.FALSE.
             RETURN
             END


      SUBROUTINE FIXN
C         DATE OF LAST CHANGE - 741108
          IMPLICIT INTEGER (A-Z)
          LOGICAL FIXFLG
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             FIXFLG=.TRUE.
             CALL NUMBER (1, RTRN)
                IF (RTRN.EQ.1) GO TO 1
             FIX=W(2)
    1        RETURN
             END


      SUBROUTINE SCIN
C         DATE OF LAST CHANGE - 741108
          IMPLICIT INTEGER (A-Z)
          LOGICAL FIXFLG
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             FIXFLG=.FALSE.
             CALL NUMBER (1, RTRN)
                IF (RTRN.EQ.1) GO TO 1
             SCI=W(2)+1
    1        RETURN
             END
      SUBROUTINE CLEAR
C         DATE OF LAST CHANGE - 740920
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             CALL CLEARX (1)
             DO 1 I=2,SMAX
                J=I-1
                P(I)=P(J)
                OP(I)=OP(J)
                DO 1 K=1,17
    1              X(I,K)=X(J,K)
             RETURN
             END






















      SUBROUTINE LPAREN
C         DATE OF LAST CHANGE - 750616
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             TEMPF=.FALSE.
             IF (X(1,2).NE.15) GO TO 2
                IF (X(1,1).EQ.13) GO TO 1
                   IF (P(1).NE.7) GO TO 3
                      CALL MESAGE (9, RTRN)
                      RETURN
    1           CALL TESTUP (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
                X(1,2)=1
                TEMPF=.TRUE.
    2        CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 4
             IF (.NOT.TEMPF) GO TO 3
                IF (OP(2).EQ.50) OP(2)=51
    3        P(1)=P(1)+1
    4        RETURN
             END
      SUBROUTINE RPAREN
C         DATE OF LAST CHANGE - 750616
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (OP(1).LT.2) GO TO 2
    1           CALL MESAGE (1, RTRN)
                RETURN
    2        DO 3 I=1,SMAX
                IF (P(I).NE.0) GO TO 4
    3              CONTINUE
                CALL MESAGE (2, RTRN)
                RETURN
    4        IF (P(I).NE.1) GO TO 7
                IF (OP(I+1).LT.72) GO TO 7
                   K=1
                   IF (I.EQ.1) GO TO 6
                      J=I
    5                 IF (OP(J).NE.10) GO TO 6
                         K=K+1
                         J=J-1
                         IF (J.NE.1) GO TO 5
    6              IF (X(I+1,3).LE.K) GO TO 7
                      CALL MESAGE (10, RTRN)
                      RETURN
    7        IF (P(1).NE.0) GO TO 10
                IF (X(1,2).EQ.15) GO TO 1
                IF (OP(2).EQ.10) GO TO 8
                   PTR=2
                   CALL EXECUT (1, RTRN)
                      IF (RTRN.EQ.1) GO TO 13
                   GO TO 7
    8           DO 9 I=3,SMAX
                   IF (OP(I).LT.72) GO TO 9
                      PTR=I
                      CALL EXECUT (1, RTRN)
                         IF (RTRN.EQ.1) GO TO 13
                      RETURN
    9              CONTINUE
                GO TO 1
   10        P(1)=P(1)-1
             IF (P(1).NE.0) RETURN
                IF (X(1,2).NE.15) GO TO 12
C                  HERE TO STATEMENT 12 FIXES UP "()"
                   IF (OP(2)/10.NE.5) GO TO 11
                      IF (OP(2).EQ.51) X(2,2)=15
                      OP(2)=0
   11              CALL DROP (1)
                   RETURN
   12           IF (OP(2).LT.70) RETURN
                   PTR=2
                   CALL EXECUT (2, RTRN)
   13              RETURN
             END
      SUBROUTINE EQUAL
C         DATE OF LAST CHANGE - 741024
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (X(1,2).EQ.15) GO TO 1
                IF (OP(1).LT.10) GO TO 2
    1              CALL MESAGE (1, RTRN)
                   RETURN
    2        DO 3 I=1,SMAX
                IF (P(I).EQ.0) GO TO 3
                   CALL MESAGE (2, RTRN)
                   RETURN
    3           CONTINUE
    4        IF (OP(2).EQ.0) GO TO 5
                PTR=2
                CALL EXECUT (1, RTRN)
                   IF (RTRN.EQ.1) GO TO 6
                GO TO 4
    5        OP(1)=1
C-           RN="RESULT REGISTER NUMBER"
C-           CALL TRANS (.TRUE.)
    6        RETURN
             END



      SUBROUTINE EXCH
C         DATE OF LAST CHANGE - 750416
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             DO 1 I=1,17
    1           W(I)=X(1,I)
             DO 2 I=1,17
    2           X(1,I)=X(2,I)
             DO 3 I=1,17
    3           X(2,I)=W(I)
             IF (OP(1).GT.60) GO TO 4
                IF (OP(2).LT.70) GO TO 5
    4        W(1)=OP(1)
             OP(1)=OP(2)
             OP(2)=W(1)
    5        RETURN
             END



      SUBROUTINE DRPSTK
C         DATE OF LAST CHANGE - 750220
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
             IF (OP(1).EQ.0) GO TO 2
    1           CALL MESAGE (1, RTRN)
                RETURN
    2        IF (X(1,2).NE.15) GO TO 1
                IF (P(1).NE.0) GO TO 1
                   CALL DROP (1)
                   RETURN
              END
      SUBROUTINE SIGN
C         DATE OF LAST CHANGE - 750416
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
             IF (OP(1).NE.0) GO TO 2
                IF (X(1,2).EQ.15) GO TO 5
    1              OP(1)=CODE+17
                   CALL COLAPS (RTRN)
                      IF (RTRN.EQ.1) GO TO 6
                   RETURN
    2        IF (OP(1).EQ.1) GO TO 1
                IF (OP(1).LT.72) GO TO 3
                   CALL MESAGE (1, RTRN)
                   RETURN
    3           IF (X(SMAX,2).EQ.15) GO TO 4
                   CALL MESAGE (9, RTRN)
                   RETURN
    4        CALL ENTRUP
    5        IF (CODE.NE.13) GO TO 6
                IF (X(1,1).EQ.13) D(1)=15
                IF (X(1,1).NE.13) D(1)=13
                X(1,1)=D(1)
    6        RETURN
             END

















      SUBROUTINE OPRATR
C         DATE OF LAST CHANGE - 740925
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (X(1,2).EQ.15) GO TO 1
                IF (OP(1).LT.10) GO TO 2
    1              CALL MESAGE (1, RTRN)
                   RETURN
    2        IF (CODE.LT.19) OP(1)=CODE+24
             IF (CODE.EQ.19) OP(1)=60
             IF (CODE.EQ.36) OP(1)=10
             IF (CODE.EQ.37) OP(1)=10
             IF (CODE.GT.37) OP(1)=CODE-20
             CALL COLAPS (RTRN)
             RETURN
             END
      SUBROUTINE FUNCTN (START)
C         DATE OF LAST CHANGE - 750612
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT, TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO ( 1, 2, 3, 9, 13), START
C ** START 1 - MULTIPLE VARIABLE FUNCTION
    1        PTR=2
             TEMP=2
C ** START 2 - VARIABLE ARGUMENT M.V.F. (PTR & TEMP SET)
    2        NEXT=.TRUE.
             GO TO 4
C ** START 3 - SINGLE VARIABLE FUNCTION
    3        PTR=1
             TEMP=1
             NEXT =.FALSE.
    4        TEMPF=.FALSE.
    5        CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 12
             X(1,2)=CODE
             X(1,3)=PTR
             X(1,4)=TEMP
             D(1)=15
             IF (TEMPF) GO TO 14
                IF (NEXT) GO TO 6
                   OP(1)=70
                   RETURN
C         CONTINUE MULTIPLE VARIABLE FUNCTION
    6           OP(1)=72
    7           NEXT=.FALSE.
C-              FOLLOWING 8 LINES CHECK FOR VALID INPUT AFTER "M.V.O."
                CALL CONTRL (2,2)
                NEXT=.TRUE.
                IF (CODE.EQ.18) RETURN
                IF (CODE.EQ.34) RETURN
                IF (CODE.GT.28) GO TO 8
                IF (CODE.GT.25) RETURN
    8              CALL MESAGE (1,RTRN)
                      IF (RTRN.EQ.1) GO TO 12
                   GO TO 7
C-              FOLLOWING LINE USED IN PLACE OF ABOVE WHEN CHECKING NOT DONE
C-              RETURN
C ** START 4 - "IMMEDIATE" SINGLE VARIABLE FUNCTION
    9        IF (X(1,2).EQ.15) GO TO 10
             IF (OP(1).LT.2) GO TO 11
   10           CALL MESAGE (1, RTRN)
                RETURN
   11        OP(1)=70
             CALL COLAPS (RTRN)
                IF (RTRN.EQ.1) GO TO 12
             OP(1)=0
             PTR=0
             CALL EXECUT (2, RTRN)
   12        RETURN
C ** START 5 - "LANGUAGE FUNCTION"
   13        TEMPF=.TRUE.
             GO TO 5
   14           IF (TEMP.EQ.1) GO TO 15
                   OP(1)=73
                   X(1,5)=OPCD
                   GO TO 16
   15           OP(1)=71
   16           CODE=18
                IF (OP(2).NE.50) GO TO 17
                   IF (P(1).EQ.0) OP(2)=0
   17           CALL LPAREN
                RETURN
             END
      SUBROUTINE SEMI
C         DATE OF LAST CHANGE - 750104
          LOGICAL IF
          DATA IF /.FALSE./
             IF (.NOT.IF) GO TO 1
C      TREAT AS STRING SEPARATOR FOR "IF"
                IF=.FALSE.
                RETURN
C      TREAT AS GENERAL ARGUMENT SEPARATOR 
    1        CALL OPRATR
             RETURN
             END





















      SUBROUTINE COMMA
C         DATE OF LAST CHANGE - 750701
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C      TREAT AS ARGUMENT SEPARATOR FOR "MVO"?
             K=1
             DO 3 I=2,SMAX
                IF (OP(I).LT.72) GO TO 2
                   IF (P(I-1).EQ.1) GO TO 4
    1                 CALL MESAGE (2, RTRN)
                      RETURN
    2           IF (P(I-1).NE.0) GO TO 1
                   IF (OP(I).EQ.10) K=K+1
    3              CONTINUE
             GO TO 6
    4           IF (X(I,4).GT.K) GO TO 5
                   CALL MESAGE (11, RTRN)
                   RETURN
    5           CALL OPRATR
                RETURN
C      TREAT AS "NO-OP"
    6        RETURN
             END
      SUBROUTINE IMEDEX
C         DATE OF LAST CHANGE - 750608
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C-        NOTE:  FOLLOWING 5 LINES ARE BASED ON MVO'S CALLING "LPAREN"
C-           IF (OP(2).LT.72) GO TO 2
C-              IF (OP(1).NE.0) GO TO 3
C-              CALL DROP (1)
C-        NOTE:  FOLLOWING LINE NOT USED WHEN MVO'S CALL "LPAREN"
             IF (OP(1).LT.72) GO TO 2
                OP(3)=OP(1)
                OP(1)=0
                DO 1 I=1,17
                   TEMP=X(1,I)
                   X(1,I)=X(2,I)
                   X(2,I)=X(3,I)
    1              X(3,I)=TEMP
                PTR=3
                GO TO 9
    2        IF (X(1,2).EQ.15) GO TO 3
             IF (X(2,2).EQ.15) GO TO 3
             IF (P(1).EQ.0) GO TO 4
    3           CALL MESAGE (1, RTRN)
                RETURN
    4        IF (OP(1).LT.20) GO TO 8
                IF (OP(2).LT.20) GO TO 5
                   IF (OP(2).NE.50) GO TO 3
    5           IF (OP(1).NE.70) GO TO 6
                   CALL EXCH
                   GO TO 7
    6           OP(2)=OP(1)
    7           OP(1)=0
                PTR=2
                GO TO 9
    8        IF (OP(2).LT.20) GO TO 3
    9           CALL EXECUT (1, RTRN)
                RETURN
             END
      SUBROUTINE COLAPS (RTRN)
C         DATE OF LAST CHANGE - 740809
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
    1        IF (P(1).NE.0) RETURN
             IF (OP(2).EQ.10) RETURN
             IF (OP(1)/10 .GT. OP(2)/10) RETURN
                PTR=2
                CALL EXECUT (1, RTRN)
                   IF (RTRN.EQ.1) GO TO 2
                GO TO 1
    2        RTRN=1
             RETURN
             END
























      SUBROUTINE EXECUT (START, RTRN)
C         DATE OF LAST CHANGE - 741218
          IMPLICIT INTEGER (A-Z)
          DIMENSION A(2,17)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA A/34*0/
             RTRN=0
             IF (START.EQ.2) GO TO 4
C ** START 1 - BINARY OPERATORS & MULTIPLE ARGUMENT FUNCTIONS
             IF (OP(2).EQ.70) GO TO 6
C       SAVE X(2,N) IN "LST X" & X(1,N) IN "LST Y"
             DO 1 N=1,17
                R(4,N)=X(1,N)
                R(3,N)=X(2,N)
                DO 1 I=1,2
C?                 IF (X(I,2).EQ.15) X(I,2)=0
    1              A(I,N)=X(I,N)
             IF (OP(PTR).GT.71) GO TO 3
C       EXECUTE BINARY FUNCTION 
                OPCD=OP(2)
                CALL COMBIN (A, 2, RTRN)
                   IF (RTRN.EQ.1) GO TO 13
                DO 2 N=1,17
    2              X(1,N)=A(1,N)
                GO TO 12
C       EXECUTE "MVO"
    3        IF (OP(PTR).EQ.73) GO TO 5
                OPCD=OP(PTR)+X(PTR,2)
                CALL COMBIN (A, 2, RTRN)
                   IF (RTRN.EQ.1) GO TO 13
                GO TO 10
C ** START 2 - SINGLE ARGUMENT FUNCTIONS
    4        IF (OP(2).LT.71) GO TO 6
    5           CALL ARGMNT (2)
                RETURN
C       SAVE X(1,N) IN "LST X"; EXECUTE "SVO"
C?  6        IF (X(1,2).EQ.15) X(1,2)=0
    6        RN=-2
             CALL TRANS (.TRUE.)
             DO 7 N=1,17
    7           A(1,N)=X(1,N)
             IF (PTR.NE.0) GO TO 8
                OPCD=70+CODE
                GO TO 9
    8        OPCD=OP(2)+X(2,2)
    9        CALL COMBIN (A, 1, RTRN)
                IF (RTRN.EQ.1) GO TO 13
   10        DO 11 N=1,17
   11           X(1,N)=A(1,N)
             IF (X(1,2).EQ.0) X(1,1)=15
             IF (PTR.EQ.0) RETURN
C       CONSIDER SIGN PRECEEDING FUNCTION
             IF (X(PTR,1).NE.13) GO TO 12
                SIGN=X(1,1)
                IF (SIGN.EQ.13) X(1,1)=15
                IF (SIGN.NE.13) X(1,1)=13
   12        IF (X(1,2).EQ.0) X(1,1)=15
C       DROP STACK APPROPRIATE AMOUNT
             CALL DROP (2)
                IF (PTR.LT.3) GO TO 13
                   PTR=PTR-1
                   GO TO 12
   13        RETURN 
             END
      SUBROUTINE COMBIN (A, NARGS, RTRN)
C         DATE OF LAST CHANGE - 750701
C         PURPOSE:  EXECUTE- "A(2,N) OPCD A(1,N) → A(1,N)"
C                            "SVO [A(1,N)] → A(1,N)"
C                            "[A(2,N)] SVO → A(1,N)"
C                            "MVO [A(2,N); A(1,N)] → A(1,N)"
          IMPLICIT INTEGER (A-Z)
          REAL*8 RX(2), DABS, DLOG10
          DIMENSION A(2,17), EXP(2)
          COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
C  (1) CONVERT A(I,N) TO RX(I)
             DO 2 I=1,2
                RX(I)=A(I,14)
                DO 1 J=1,12
                   KK=14-J
    1              RX(I)=0.1*RX(I)+A(I,KK)
                IF (A(I,1).EQ.13) RX(I)=-RX(I)
                EXP(I)=10*A(I,16)+A(I,17)
                IF (A(I,15).EQ.13) EXP(I)=-EXP(I)
    2           CONTINUE
C  (2) NOW EXECUTE RX(2), OPCD, RX(1) -> RX(1)=RX1
             IF (OPCD.GT.60) GO TO 21
             IF (OPCD.EQ.60) GO TO 14
             IF (OPCD.GT.31) GO TO 9
             IF (OPCD.GT.23) GO TO 8
C         RELATIONALS
             VALUE=0
             RX(1)=-RX(1)
             CALL ADD (RX, EXP)
             GO TO (3, 4, 5, 6), OPCD-19
    3           IF (RX(1) .EQ. 0.0) VALUE=1
                   GO TO 7
    4           IF (RX(1) .NE. 0.0) VALUE=1
                   GO TO 7
    5           IF (RX(1) .GT. 0.0) VALUE=1
                   GO TO 7
    6           IF (RX(1) .LT. 0.0) VALUE=1
    7        RX(1)=VALUE
             GO TO 35
C         ADDITION/SUBTRACTION
    8        IF (OPCD.EQ.30) RX(1)=-RX(1)
             CALL ADD (RX, EXP)
             GO TO 35
C         MULTIPLICATION/DIVISION
    9        IF (OPCD.EQ.40)  GO TO 10
                RX(1)=RX(2)*RX(1)
                EXP(1)=EXP(2)+EXP(1)
                GO TO 35
   10        IF (RX(1).NE.0.0) GO TO 13
   11           ERROR=6
   12           KK=9
C-              "EXP OF A"="+ OVERFLOW"
                J=12
                GO TO 41
   13        RX(1)=RX(2)/RX(1)
             EXP(1)=EXP(2)-EXP(1)
             GO TO 35
C         EXPONENTIATION
   14        IF (RX(2)) 11, 15, 16
   15           RX(1)=0.0
                EXP(1)=0
                GO TO 35
   16        RX(2)=RX(1)*(DLOG10(RX(2))+EXP(2))
             S=1
             IF (RX(2)) 17, 18, 19
   17           RX(2)=-RX(2)
                S=-1
                GO TO 19
   18        RX(1)=1.0
             EXP(1)=0
             GO TO 35
   19           RX(2)=DLOG10(RX(2))
                EXP(2)=RX(2)
                RX(2)=10.0**(RX(2)-EXP(2))
                EXP(2)=EXP(1)+EXP(2)
                IF (EXP(2).LT.2) GO TO 20
                   ERROR=7
                   GO TO 12
   20           RX(2)=S*RX(2)*10.0**EXP(2)
                EXP(1)=RX(2)
                RX(1)=10.0**(RX(2)-EXP(1))
                GO TO 35
C         SINGLE VARIABLE FUNCTIONS
   21        IF (NARGS.NE.1) GO TO 26
                GO TO (22, 23, 25), OPCD-115
C               "ABS (X)"
   22              RX(1)=DABS(RX(1))
                      GO TO 35
C               "SQRT (X)"
   23              IF (RX(1).GT.0) GO TO 24
                      ERROR=6
                      RX(1)=-RX(1)
   24              CALL MYSQRT(RX(1), EXP(1))
                      GO TO 35
C               "(X)↑2"
   25              RX(1)=RX(1)*RX(1)
                   EXP(1)=EXP(1)+EXP(1)
                      GO TO 35
C         MULTIPLE VARIABLE FUNCTIONS
   26           GO TO (27, 31), OPCD-115
C               "MAG (X,Y)"
   27              KK=EXP(2)-EXP(1)
                   IF (IABS(KK).LT.15) GO TO 29
                      IF (KK) 35, 29, 28
   28                    RX(1)=RX(2)
                         EXP(1)=EXP(2)
                         GO TO 35
   29              DO 30 I=1,2
   30                 RX(I)=RX(I)*RX(I)
                   EXP(2)=KK*2
                   KK=EXP(1)
                   EXP(1)=0
                   CALL ADD (RX, EXP)
                   CALL MYSQRT (RX(1), EXP(1))
                   EXP(1)=EXP(1)+KK
                   GO TO 35
C               "ARG (X,Y)"
   31              IF (RX(2).NE.0.0) GO TO 33
   32                 RX(1)=9.0
                      EXP(1)=1
                      GO TO 35
   33              EXP(2)=EXP(1)-EXP(2)
                   IF (EXP(2).GT.30) GO TO 32
                      EXP(1)=0
                      IF (EXP(2).GT.-30) GO TO 34
                         RX(1)=0.0
                         GO TO 35
   34              RX(1)=DATAN((RX(1)/RX(2))*10.0**EXP(2))*57.29577951D0
C  (3) EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
   35        IF (RX(1).NE.0.0) GO TO 36
                KK=0
                GO TO 38
   36        IF (DABS(RX(1)).GE.1.0) GO TO 37
                RX(1)=RX(1)*10.0
                EXP(1)=EXP(1)-1
                GO TO 36
   37        IF (DABS(RX(1)).LT.10.0) GO TO 38
                RX(1)=RX(1)/10.0
                EXP(1)=EXP(1)+1
                GO TO 37
   38        IF (EXP(1).GE.0) GO TO 39
                EXP(1)=-EXP(1)
                A(1,15)=13
                GO TO 40
   39        A(1,15)=15
   40        A(1,16)=EXP(1)/10
             A(1,17)=EXP(1)-10*A(1,16)
C  (4) CHECK FOR OVER/UNDER-FLOW
             IF (A(1,16).LT.10) GO TO 43
                ERROR=7
                IF (A(1,15).NE.13) GO TO 12
                   KK=0
                   A(1,1)=15
C-                 "EXP OF A"="+"
                   J=15
   41              A(1,1)=A(2,1)
                   DO 42 I=2,17
   42                 A(1,I)=KK
                   A(1,15)=J
                   GO TO 47
C  (5) CONVERT RX(1)=RX(1) TO A(1,N), N=1, ..., 14
   43        IF (RX(1).GE.0.0) GO TO 44
                A(1,1)=13
                RX(1)=-RX(1)
                GO TO 45
   44        A(1,1)=15
   45        A(1,2)=RX(1)
             DO 46 I=3,14
                J=I-1
                RX(1)=10.*(RX(1)-A(1,J))
   46           A(1,I)=RX(1)
   47        IF (ERROR.NE.0) CALL MESAGE (ERROR, RTRN)
             RETURN
             END
      SUBROUTINE ADD (X, K)
C         DATE OF LAST CHANGE - 750701
C         PURPOSE:  ADD TOGETHER TWO NUMBERS IN SCIENTIFIC NOTATION
          DOUBLE PRECISION X, DABS, DLOG10
          DIMENSION X(2), K(2)
             J=K(1)-K(2)
             IF (J.LT.15) GO TO 1
                X(2)=0.0
                GO TO 3
    1        IF (J.GT.-15) GO TO 2
                X(1)=0.0
                K(1)=K(2)
                GO TO 3
    2        X(1)=X(1)*10.0**J
             K(1)=K(1)-J
    3        X(1)=X(1)+X(2)
             IF (X(1).NE.0.0) GO TO 4
                K(1)=0
                GO TO 6
    4        IF (DABS(X(1)).GE.1.0) GO TO 5
                X(1)=X(1)*10.0
                K(1)=K(1)-1
                GO TO 4
    5        KK=DLOG10(DABS(X(1)))+0.00001
             X(1)=X(1)/10.0**KK
             K(1)=K(1)+KK
    6        RETURN
             END

























      SUBROUTINE MYSQRT (X, K)
C         DATE OF LAST CHANGE - 750701
C         PURPOSE:  TAKE SQUARE ROOT OF NUMBER IN SCIENTIFIC NOTATION
          DOUBLE PRECISION X, DSQRT
             IF (2*(K/2).EQ.K) GO TO 1
                K=K-1
                X=X*10.0
    1        X=DSQRT (X)
             K=K/2
             RETURN
             END
      SUBROUTINE ENTRY
C         DATE OF LAST CHANGE - 750628
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, NEXT, TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 11
             DO 1 I=2,16
    1           D(I)=15
    2        IF (CODE.GT.9) GO TO 3
                CALL DIGIT
                GO TO 12
    3        IF (CODE.NE.11) GO TO 4
                CALL DECPT
                GO TO 12
    4        IF (CODE.NE.12) GO TO 5
                CALL ENTEXP
                IF (ERROR.NE.0) RETURN
                GO TO 12
    5        IF (CODE.NE.28) GO TO 6
                CALL CORECT (1)
                IF (.NOT.TEMPF) GO TO 12
                   RETURN
    6        IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 7
                IF (D(15).NE.0) GO TO 7
                   IF (D(16).NE.15) GO TO 7
                      D(14)=CODE
                      GO TO 12
    7        IF (X(1,2).EQ.15) GO TO 8
                IF (D(13).NE.12) GO TO 9
                   IF (CODE.EQ.26) GO TO 10
                      IF (CODE.EQ.27) GO TO 10
                         CALL ADEXPD (RTRN)
                            IF (RTRN.EQ.1) GO TO 11
                            IF (TEMPF) GO TO 12
                         GO TO 9
    8        X(1,2)=0
    9        CALL RESET
   10        NEXT=.TRUE.
   11        RETURN
C        FORMAT "DISPLAY" & GET NEXT KEYSTROKE
   12        CALL CONTRL (2, 2)
             GO TO 2
                END
      SUBROUTINE DIGIT
C         DATE OF LAST CHANGE - 750130
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (.NOT.EEX) GO TO 1
                D(15)=D(16)
                IF (D(15).EQ.15) D(15)=0
                D(16)=CODE
                RETURN
    1        IF (M.GT.14) RETURN
             IF (DP) GO TO 2
                IF (M.EQ.14) RETURN
    2        M=M+1
             D(M)=CODE
             IF (L.GT.13) RETURN
             IF (DP) GO TO 3
                IF (L.EQ.1) GO TO 4
                   CALL EXPON (X(1,15),X(1,16),X(1,17),1)
                   GO TO 5
    3        IF (L.NE.1) GO TO 5
                CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
    4           IF (CODE.EQ.0) RETURN
    5        L=L+1
             X(1,L)=CODE
             RETURN
             END














      SUBROUTINE DECPT
C         DATE OF LAST CHANGE - 741004
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (.NOT.EEX) GO TO 1
                EEX=.FALSE.
                RETURN
    1        IF (DP) RETURN
             DP=.TRUE.
             IF (M.GT.13) RETURN
                M=M+1
                D(M)=11
             RETURN
             END
      SUBROUTINE ENTEXP
C         DATE OF LAST CHANGE - 750125
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             IF (.NOT.EEX) GO TO 2
                CALL TESTUP (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
                IF (D(13).NE.12) GO TO 1
                   CALL ADEXPD (RTRN)
                      IF (RTRN.EQ.1) GO TO 4
    1           OP(1)=50
                CALL COLAPS (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
                CALL ENTRUP
                D(1)=15
                X(1,1)=15
                GO TO 3
    2        IF (X(1,16).NE.0) RETURN
    3           D(13)=12
                D(14)=15
                D(15)=0
                D(16)=15
                EEX=.TRUE.
                IF (M.NE.1) RETURN
                   D(2)=1
                   D(3)=11
                   X(1,2)=1
                   M=3
                   L=2
                   DP=.TRUE.
    4              RETURN
             END






      SUBROUTINE CLEARX (START)
C         DATE OF LAST BHANGE - 750104
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 2, 3), START
C ** START 1 - CLEAR S(1)
    1        P(1)=0
C ** START 2 - "CLEAR X"
    2        OP(1)=0
C ** START 3 - CLEAR X(1)
    3        D(1)=15
             X(1,1)=15
             X(1,2)=15
             DO 4 I=3,17
    4           X(1,I)=0
             X(1,15)=15
             CALL RESET
             RETURN
             END
      SUBROUTINE CORECT (START)
C         DATE OF LAST CHANGE - 750608
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP, TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (START.EQ.2) GO TO 12
C ** START 1 - ENTRY POINT FROM "ENTRY"
             TEMPF=.FALSE.
             IF (.NOT.EEX) GO TO 2
                EEX=.FALSE.
                DO 1 I=13,16
    1              D(I)=15
                RETURN
    2        IF (M.GT.2) GO TO 4
                IF (M.EQ.1) GO TO 3
                IF (X(1,1).EQ.13) GO TO 4
    3              CALL CLEARX (3)
                   TEMPF=.TRUE.
                   RETURN
    4        IF (.NOT.DP) GO TO 6
                IF (D(M).NE.11) GO TO 5
                   DP=.FALSE.
                   IF (M.EQ.2) TEMPF=.TRUE.
                   GO TO 11
    5           IF (L.GT.2) GO TO 7
                   CALL EXPON (X(1,15),X(1,16),X(1,17),1)
                   IF (L.EQ.2) GO TO 9
                      GO TO 11
    6        IF (L.EQ.1) GO TO 11
                IF (L.EQ.2) GO TO 8
                   CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
    7              X(1,L)=0
                   GO TO 10
    8           TEMPF=.TRUE.
    9           X(1,L)=15
   10           L=L-1
   11        D(M)=15
             M=M-1
             RETURN
C ** START 2 - ENTRY POINT FROM "LOOK-UP"
   12        IF (OP(1).EQ.0) GO TO 14
                IF (OP(1).LT.70) GO TO 13
                   CALL CLEARX (2)
                   RETURN
   13           OP(1)=0
                RETURN
   14        IF (X(1,2).EQ.15) GO TO 16
   15           CALL MESAGE (1, RTRN)
                RETURN
   16        IF (X(1,1).NE.13) GO TO 17
                CALL CLEARX (3)
                RETURN
   17        IF (P(1).EQ.0) RETURN
                IF (P(1).GT.1) GO TO 18
                   IF (OP(2).EQ.71) GO TO 15
                   IF (OP(2).EQ.73) GO TO 15
   18           P(1)=P(1)-1
                IF (P(1).NE.0) RETURN
                   IF (OP(2).GT.60) CALL DROP (1)
                RETURN
             END
      SUBROUTINE ADEXPD (RTRN)
C         DATE OF LAST CHANGE - 750702
C         PURPOSE:  ADD EXPONENT OF D TO THAT OF X(1)
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             TEMPF=.FALSE.
             N=10*X(1,16)+X(1,17)
             IF (X(1,15).EQ.13) N=-N
             IF (D(15).EQ.15) D(15)=0
             IF (D(16).EQ.15) D(16)=0
             K=10*D(15)+D(16)
             IF (D(14).EQ.13) K=-K
             N=N+K
             IF (IABS(N).LT.100) GO TO 4
                CALL MESAGE (8, RTRN)
                   IF (RTRN.EQ.1) GO TO 7
                IF (TEMPF) GO TO 7
                IF (N.LT.0) GO TO 1
                   K=9
C-                 "EXP OF A"="+ OVERFLOW"
                   N=12
                   GO TO 2
    1           K=0
                X(1,1)=15
C-              "EXP OF A"="+"
                N=15
    2           DO 3 I=2,17
    3              X(1,I)=K
                X(1,15)=N
                GO TO 7
    4        IF (N.GE.0) GO TO 5
                N=-N
                X(1,15)=13
                GO TO 6
    5        X(1,15)=15
    6        X(1,16)=N/10
             X(1,17)=N-X(1,16)*10
    7        RETURN
             END



      SUBROUTINE EXPON (A,B,C,N)
C         DATE OF LAST CHANGE - 740210
C         ADD "N" TO THE EXPONENT "ABC" (I.E. SIGN, DIGIT, DIGIT)
          IMPLICIT INTEGER (A-Z)
             IF (B.EQ.15) B=0
             IF (C.EQ.15) C=0
             K=10*B+C
             IF (A.EQ.13) K=-K
             K=K+N
             IF (K.GE.0) GO TO 1
                K=-K
                A=13
                GO TO 2
    1        A=15
    2        B=K/10
             C=K-10*B
             RETURN
             END
      SUBROUTINE RECALL (START)
C         DATE OF LAST CHANGE - 750314
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 5, 6), START
C ** START 1 - EXPLICIT REGISTERS (A, PI, LST X, LST Y)
    1           IF (CODE-24) 2, 3, 4
    2           RN=-3
                   GO TO 7
    3           RN=-4
                   GO TO 8
    4           RN=CODE-40
                   GO TO 7
C ** START 2 - "R" REGISTERS
    5        LFRC=1
             CALL REG (RTRN)
                IF (RTRN.EQ.1) GO TO 11
             IF (TEMPF) RETURN
C ** START 3 - RECALL INDICATED REGISTER (RN IN W)
    6        CALL REGNO (RTRN)
                IF (RTRN.EQ.1) GO TO 11
    7        IF (R(RN+5,2).NE.15) GO TO 8
                CALL MESAGE (5, RTRN)
                   IF (RTRN.EQ.1) GO TO 11
    8        CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 11
             IF (X(1,1).EQ.13) GO TO 9
                CALL TRANS (.FALSE.)
                RETURN
    9        CALL TRANS (.FALSE.)
             IF (X(1,1).EQ.13) GO TO 10
                X(1,1)=13
                RETURN
   10        X(1,1)=15
   11        RETURN
             END
      SUBROUTINE STORE (START)
C         DATE OF LAST CHANGE - 750612
          IMPLICIT INTEGER (A-Z)
          DIMENSION OPCODE(7), A(2,17)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
          DATA OPCODE /30, 31, 0, 40, 41, 0, 60/
             GO TO (1, 12, 21), START
C ** START 1 - LOOK FOR DESTINATION
    1        IF (OP(1).LT.70) GO TO 2
                CALL MESAGE (1, RTRN)
                RETURN
    2        OPCD=0
             TEMP=0
    3        LFRC=2
             CODE=31
    4        CALL FINDN (2, RTRN)
                IF (RTRN.EQ.1) GO TO 20
             IF (K.NE.0) GO TO 11
                IF (CODE.NE.25) GO TO 5
                   CALL REG (RTRN)
                      IF (RTRN.EQ.1) GO TO 20
                   IF (.NOT.TEMPF) GO TO 11
                      IF (OPCD.NE.0) GO TO 8
                         GO TO 3
    5           IF (CODE.NE.23) GO TO 6
                   N=-3
                   RN=-3
                   GO TO 13
    6           IF (CODE.NE.51) GO TO 7
                   LFRC=5
                   CALL FDIGIT (1, RTRN)
                      IF (RTRN.EQ.1) GO TO 20
                   IF (TEMPF) GO TO 2
                      GO TO 21
    7           IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
     *              CODE.EQ.17 .OR. CODE.EQ.19) GO TO 10
                   IF (CODE.NE.28) GO TO 9
                      IF (OPCD.EQ.0) RETURN
                         IF (TEMP.EQ.1) GO TO 2
                            IF (LSTK.EQ.OPCD) GO TO 2
    8                          CODE=OPCD
                               TEMP=1
                               GO TO 4
    9              CALL MESAGE (3, RTRN)
                      IF (RTRN.EQ.1) GO TO 20
                   GO TO 2
   10           OPCD=CODE
                GO TO 4
   11        TEMP=1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
   12        CALL RANGE (RTRN)
                IF (RTRN.EQ.1) GO TO 20
   13        KMAX=RN
             IF (OPCD.NE.0) OPCD=OPCODE(OPCD-12)
             DO 18 RN=N,KMAX
                IF (OPCD.EQ.0) GO TO 17
                   K=RN+5
                   IF (R(K,2).NE.15) GO TO 14
                      CALL MESAGE (5, RTRN)
                         IF (RTRN.EQ.1) GO TO 20
   14              DO 15 I=1,17
                      A(1,I)=X(1,I)
                      A(2,I)=R(K,I)
   15                 IF (A(2,I).EQ.15) A(2,I)=0
                   IF (A(1,2).EQ.15) A(1,2)=0
                   CALL COMBIN (A, 2, RTRN)
                      IF (RTRN.EQ.1) GO TO 20
                   DO 16 I=1,17
   16                 R(K,I)=A(1,I)
                   GO TO 18
   17           CALL TRANS (.TRUE.)
   18           CONTINUE
   19        IF (OP(1).EQ.0) OP(1)=1
   20           RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
   21        TEMP=1
             IF (X(1,1).EQ.13 .OR. X(1,2).EQ.0 .OR.
     *          X(1,15).EQ.13 .OR. X(1,2).EQ.15) TEMP=0
             DO 22 I=N,RN
                K=I+1
   22           UFLAG(K)=TEMP
             GO TO 19
             END













      SUBROUTINE TRANS (STORE)
C         DATE OF LAST CHANGE - 740715
          IMPLICIT INTEGER (A-Z)
          LOGICAL STORE
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             K=RN+5
             IF (STORE) GO TO 4
                DO 1 I=1,17
    1              X(1,I)=R(K,I)
                IF (X(1,2).NE.15) GO TO 3
                   DO 2 I=2,17
    2                 X(1,I)=0
                   X(1,15)=15
    3           RETURN
    4        DO 5 I=1,17
    5           R(K,I)=X(1,I)
             IF (R(K,2).EQ.15) R(K,2)=0
             IF (R(K,1).EQ.13 .AND. R(K,2).EQ.0) R(K,1)=15
             RETURN
             END
      SUBROUTINE SCR (START)
C         DATE OF LAST CHANGE - 750303
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 5, 8), START
C ** START 1 - FIND ARGUMENT
    1        CODE=50
             CALL CONTRL (3, 2)
             IF (CODE.NE.25) GO TO 2
                LFRC=3
                CALL REG (RTRN)
                   IF (RTRN.EQ.1) GO TO 10
                IF (TEMPF) GO TO 1
                   TEMP=1
                   GO TO 5
    2        IF (CODE.NE.23) GO TO 3
                N=-3
                RN=-3
                GO TO 6
    3        IF (CODE.NE.51) GO TO 4
                LFRC=4
                CALL FDIGIT (1, RTRN)
                   IF (RTRN.EQ.1) GO TO 10
                IF (TEMPF) GO TO 1
                   GO TO 8
    4        CALL MESAGE (3, RTRN)
                IF (RTRN.EQ.1) GO TO 10
             GO TO 1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W [&DSP])
    5        CALL RANGE (RTRN)
                IF (RTRN.EQ.1) GO TO 10
    6        DO 7 I=N,RN
                K=I+5
                DO 7 J=1,17
    7              R(K,J)=15
             RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N [& RN])
    8        DO 9 I=N,RN
                K=I+1
    9           UFLAG(K)=0
   10        RETURN
             END
      SUBROUTINE LSTKEY
C         DATE OF LAST CHANGE - 750704
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          DIMENSION W2(16)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
             DO 1 I=1,16
                W2(I)=DSP(I)
    1           DSP(I)=11
             DSP(1)=15
    2        IF (LSTK.GE.0) GO TO 4
                DO 3 I=8,10
    3              DSP(I)=13
                   GO TO 5
    4        DSP(8)=0
             DSP(9)=LSTK/10
             DSP(10)=LSTK-10*DSP(9)
    5        CALL KYMODE (1)
             CALL OUTIN (2)
             IF (CODE.NE.27) GO TO 7
                DO 6 I=1,16
    6              DSP(I)=W2(I)
                RETURN
    7        IF (CODE.EQ.30) GO TO 2
                NEXT=.TRUE.
                RETURN
             END














      SUBROUTINE KYMODE (START)
C         DATE OF LAST CHANGE - 741231
          IMPLICIT INTEGER (A-Z)
          LOGICAL STEP
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /OUTPT/ SKIP, DISPLY(32), PGMPTR
             GO TO (1, 2, 3), START+1
C ** START 0 - COMPLEMENT "STEP"
    1           STEP=.NOT.STEP
                RETURN
C ** START 1 - DISPLAY PROGRAM POINTER?
    2        IF (.NOT.STEP) RETURN
C ** START 2 - DISPLAY PROGRAM POINTER!
    3           DSP(1)=PGMPTR/1000
                DSP(2)=PGMPTR/100-10*DSP(1)
                DSP(3)=PGMPTR/10-100*DSP(1) -10*DSP(2)
                DSP(4)=PGMPTR/1-1000*DSP(1)-100*DSP(2)-10*DSP(3)
                RETURN
             END
      SUBROUTINE FLAG (START)
C         DATE OF LAST CHANGE - 750314
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             IF (START.EQ.2) GO TO 1
C ** START 1 - FIND FLAG NUMBER
             LFRC=6
             CALL FDIGIT (1, RTRN)
                IF (RTRN.EQ.1) GO TO 2
             IF (TEMPF) RETURN
C ** START 2 - FLAG NUMBER KNOWN (HELD IN N)
    1        RN=N
             CALL SETUP (RTRN)
                IF (RTRN.EQ.1) GO TO 2
             X(1,2)=UFLAG(RN+1)
    2        RETURN
             END
      SUBROUTINE SETUP (RTRN)
C         DATE OF LAST CHANGE - 750610
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             IF (X(1,2).EQ.15) RETURN
             IF (OP(1).NE.0) GO TO 2
                CALL TESTUP (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
                OP(1)=50
                CALL COLAPS (RTRN)
                   IF (RTRN.EQ.1) GO TO 4
    1           CALL ENTRUP
                RETURN
    2        IF (OP(1).EQ.1) GO TO 5
                IF (OP(1).LT.72) GO TO 3
                   IF (CODE.EQ.18) GO TO 3
                      CALL MESAGE (1, RTRN)
                      RTRN=1
                      RETURN
    3           IF (X(SMAX,2).EQ.15) GO TO 1
                   CALL MESAGE (9, RTRN)
    4              RTRN=1
                   RETURN
C        CODE = 81, 82, ... WHEN "LANGUAGE FUNCTION" BEING FORMED
    5        IF (CODE.GT.79) GO TO 3
                IF (CODE.EQ.38) GO TO 6
                   II=RN
                   RN=-2
                   CALL TRANS (.TRUE.)
                   RN=II
    6           CALL CLEARX (2)
                RETURN
             END













      SUBROUTINE TESTUP (RTRN)
C         DATE OF LAST CHANGE - 740625
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
             RTRN=0
             IF (X(SMAX,2).EQ.15) RETURN
             IF (OP(2).LT.50) GO TO 1
                IF (P(1).EQ.0) GO TO 2
    1              CALL MESAGE (9, RTRN)
                   RTRN=1
    2        RETURN
             END
      SUBROUTINE ENTRUP
C         DATE OF LAST CHANGE - 740630
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             KMAX=SMAX-1
             DO 1 I=1,KMAX
                J=SMAX-I
                K=J+1
                P(K)=P(J)
                OP(K)=OP(J)
                DO 1 N=1,17
    1              X(K,N)=X(J,N)
C-           IF (X(SMAX,2).NE.15) "TURN ON 'STACK FULL' LIGHT"
             CALL CLEARX (1)
             RETURN
             END










      SUBROUTINE DROP (START)
C         DATE OF LAST CHANGE - 750608
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 2, 3), START
C ** START 1 - DROP S(2), ..., S(SMAX)
    1        J=1
             GO TO 4
C ** START 2 - DROP S(3), ..., S(SMAX)
    2        P(1)=P(2)
             J=2
             GO TO 4
C ** START 3 - DROP S(PTR+1), ..., S(SMAX)
    3        J=PTR
    4        KMAX=SMAX-1
             DO 5 I=J,KMAX
                IF (I.GT.2 .AND. X(I,2).EQ.15) GO TO 6
                JJ=I+1
                P(I)=P(JJ)
                OP(I)=OP(JJ)
                DO 5 K=1,17
    5              X(I,K)=X(JJ,K)
    6        IF (X(SMAX,2).EQ.15) RETURN
                OP(SMAX)=0
                P(SMAX)=0
                X(SMAX,1)=15
                X(SMAX,2)=15
                DO 7 I=3,17
    7              X(SMAX,I)=0
                X(SMAX,15)=15
C-              "TURN OFF 'STACK FULL' LIGHT"
                RETURN
             END
      SUBROUTINE NUMBER (START, RTRN)
C         DATE OF LAST CHANGE - 750130
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
             RTRN=0
             IF (START.EQ.2) GO TO 5
C ** START 1 - FIND A NUMBER (0-9)
    1        CALL CONTRL (1, 2)
             IF (CODE.GT.9) GO TO 2
                W(2)=CODE
                RETURN
    2        IF (LFRC.NE.0) GO TO 3
                NEXT=.TRUE.
                RTRN=1
                RETURN
    3        IF (CODE.EQ.18) GO TO 4
                CALL MESAGE (3, RTRN)
                   IF (RTRN.EQ.1) GO TO 9
                GO TO 1
    4        CALL ARGMNT (1)
             RTRN=1
             RETURN
C ** START 2 - NUMBER FOUND FROM EXPRESSION (HELD IN W)
    5        IF (W(17).EQ.0 .AND. W(16).EQ.0) GO TO 6
                CALL MESAGE (4, RTRN)
                RTRN=1
                RETURN
C-
    6        TYPE 7
    7        FORMAT (10X, 'GOT TO "NUMBER AT "START 2" SOMEHOW!'/)
             RTRN=1
C-
C-  6        GO TO (7, 8), CODE-7
C-  7        CALL P (2)
C-              RETURN
C-  8        CALL STORE (2)
    9           RETURN
             END
      SUBROUTINE FINDN (START, RTRN)
C         DATE OF LAST CHANGE - 750104
          IMPLICIT INTEGER (A-Z)
          LOGICAL NEXT
          COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEP, UFLAG(11)
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             GO TO (1, 2, 3), START
    1        KMAX=1
                GO TO 4
    2        KMAX=2
                GO TO 4
    3        KMAX=3
    4        NEXT=.FALSE.
             K=0
             I=CODE
    5        CALL CONTRL (3, 2)
             IF (CODE.GT.9) GO TO 6
                W(17)=K
                K=K+1
                W(K+1)=CODE
                IF (K.LT.KMAX) GO TO 5
                   RETURN
    6        IF (K.GT.0) GO TO 7
                IF (CODE.NE.18) GO TO 11
                   CALL ARGMNT (1)
                   RTRN=1
                   RETURN
    7        IF (CODE.NE.28) GO TO 8
                K=K-1
                W(17)=K-1
                CODE=W(K+1)
                IF (K.EQ.0) CODE=I
                GO TO 5
    8        IF (CODE.NE.27) GO TO 9
                K=0
                GO TO 11
    9        IF (CODE.NE.26) GO TO 10
                K=0
   10        NEXT=.TRUE.
   11        RETURN
             END
      SUBROUTINE REG (RTRN)
C         DATE OF LAST CHANGE - 750626
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /INPUT/ CODE, EXPR(50), KEY,  OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             IND=0
             TEMPF=.FALSE.
    1        CALL FINDN (2, RTRN)
                IF (RTRN.EQ.1) GO TO 14
             IF (K.NE.0) GO TO 11
                IF (CODE.NE.25) GO TO 4
                   IF (IND.NE.15) GO TO 3
                      CALL MESAGE (4, RTRN)
    2                 RTRN=1
                      RETURN
    3              IND=IND+1
                   LFRC=0
                   GO TO 1
    4           IF (CODE.NE.23) GO TO 7
                   IF (R(2,2).NE.15) GO TO 5
                      CALL MESAGE (5, RTRN)
                         IF (RTRN.EQ.1) GO TO 14
    5              DO 6 I=1,17
                      W(I)=R(2,I)
                      IF (W(I).EQ.15) W(I)=0
    6                 CONTINUE
                   GO TO 11
    7           IF (CODE.NE.22) GO TO 8
                   W(2)=1
                   W(3)=6
                   W(15)=15
                   W(16)=0
                   W(17)=1
                   GO TO 11
    8           IF (CODE.EQ.26) GO TO 2
                IF (CODE.EQ.27) GO TO 2
                IF (CODE.NE.28) GO TO 10
                   IF (IND.EQ.0) GO TO 9
                      IND=IND-1
                      CODE=25
                      GO TO 1
    9              TEMPF=.TRUE.
                   RETURN
   10           CALL MESAGE (3, RTRN)
                   IF (RTRN.EQ.1) GO TO 14
                CODE=25
                GO TO 1
   11        IF (IND.EQ.0) GO TO 14
                CALL REGNO (RTRN)
                   IF (RTRN.EQ.1) GO TO 14
                RN=RN+5
                IF (R(RN,2).NE.15) GO TO 12
                   CALL MESAGE (5, RTRN)
                      IF (RTRN.EQ.1) GO TO 14
   12           DO 13 I=1,17
                   W(I)=R(RN,I)
                   IF (W(I).EQ.15) W(I)=0
   13              CONTINUE
                IND=IND-1
                GO TO 11
   14        RETURN
             END
      SUBROUTINE RANGE (RTRN)
C         DATE OF LAST CHANGE - 750225
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             TEMPF=.TRUE.
    1        CALL REGNO (RTRN)
                IF (RTRN.EQ.1) GO TO 6
             IF (RN.NE.16) GO TO 2
                CALL MESAGE (4, RTRN)
                RETURN
    2        IF (TEMP.EQ.1) GO TO 5
                N=RN
                TEMPF=.FALSE.
                TEMP=TEMP-1
                DO 3 I=1,13
    3              W(I)=DSP(I)
                W(14)=0
                DO 4 I=14,16
    4              W(I+1)=DSP(I)
                GO TO 1
    5        IF (TEMPF) N=RN
             IF (RN.GE.N) GO TO 6
                TEMP=RN
                RN=N
                N=TEMP
    6        RETURN
             END













      SUBROUTINE REGNO (RTRN)
C         DATE OF LAST CHANGE - 741126
C         PURPOSE: CONVERT W TO INTEGER IN RN; CHECK FOR RN TOO BIG
          IMPLICIT INTEGER (A-Z)
          COMMON /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             K=21
             CALL INTGER
             KMAX=RN
             K=0
             CALL INTGER
             IF (RN.LE.KMAX+1) GO TO 1
                CALL MESAGE (4, RTRN)
                RTRN=1
    1        RETURN
             END
      SUBROUTINE ARGMNT (START)
C         DATE OF LAST CHANGE - 750225
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             GO TO (1, 5), START
C ** START 1 - FORM GENERAL ARGUMENT
    1        IF (LFRC.NE.0) GO TO 2
                CALL MESAGE (3, RTRN)
                RETURN
    2        CODE=LFRC+80
             LFRC=0
C-           FOLLOWING 4 LINES ARE FOR A 2 ARGUMENT "LANGUAGE FUNCTION"
C-           IF (CODE.LT.90) GO TO 3
C-              PTR=2
C-              TEMP=2
C-              GO TO 4
    3        PTR=1
             TEMP=1
             IF (CODE.GT.81 .AND. CODE.LT.86) TEMP=2
    4        CALL FUNCTN (5)
             RETURN
C ** START 2 - RETURN ARGUMENT(S) TO "LANGUAGE FUNCTION" IN W ([&D] &DSP)
    5        TEMP=PTR-1
             N=1
    6        PTR=PTR-1
             IF (X(1,15).NE.13) GO TO 8
                DO 7 I=1,17
    7              W(I)=0
                GO TO 9
    8        K=6
             CALL ROUND
    9        CALL DROP (1)
             IF (OP(1).GT.70) GO TO 15
                N=N+1
                IF (N.GT.2) GO TO 12
                   DO 10 I=1,13
   10                 DSP(I)=W(I)
                   DO 11 I=14,16
   11                 DSP(I)=W(I+1)
                   GO TO 6
   12           DO 13 I=1,13
   13              D(I)=W(I)
                DO 14 I=14,16
   14              D(I)=W(I)
                GO TO 6
   15        PTR=X(1,2)-80
             IF (PTR.EQ.2) OPCD=X(1,5)
             IF (P(1).EQ.0) GO TO 16
                CALL CLEARX (2)
                GO TO 17
   16        CALL DROP (1)
   17        GO TO (19, 20, 21, 22, 22, 22, 18, 23, 23), PTR
   18           CALL MESAGE (82, RTRN)
                RETURN
   19        CALL RECALL (3)
                RETURN
   20        CALL STORE (2)
                RETURN
   21        CALL SCR (2)
                RETURN
   22        CALL FDIGIT (2, RTRN)
                RETURN
   23        CALL NUMBER (2, RTRN)
                RETURN
             END
























      SUBROUTINE INTGER
C         DATE OF LAST CHANGE - 741218
          IMPLICIT INTEGER (A-Z)
          DIMENSION S(17)
          COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RN=0
             IF (K.GT.0) GO TO 3
    1        DO 2 I=1,17
    2           S(I)=W(I)
             GO TO 7
    3           IF (S(2).NE.15) GO TO 5
                   DO 4 I=2,17
    4                 S(I)=0
                   S(15)=15
                   GO TO 7
    5           DO 6 I=1,17
    6              S(I)=R(K,I)
    7        IF (S(15).EQ.13) RETURN
                K=S(16)*10+S(17)+1
                IF (K.LT.13) GO TO 8
                   RN=99999
                   RETURN
    8           DO 9 I=1,K
    9              RN=RN*10+S(I+1)
                RETURN
             END
      SUBROUTINE ROUND
C         DATE OF LAST CHANGE - 750123
C         PURPOSE:  ROUND X(1,I) TO  K  DIGITS & PUT RESULT IN W(I)
          IMPLICIT INTEGER (A-Z)
          COMMON /STACK/ P(7), X(7,17), OP(7), D(16), DSP(16), SMAX
     *           /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
    1        DO 2 I=1,17
    2           W(I)=X(1,I)
             IF (K.NE.15) GO TO 3
                W(15)=12
                RETURN
    3        IF (W(2).EQ.15) W(2)=0
             CNT=K+2
             IF (W(CNT)-5) 11, 4, 7
C        TEST DIGIT = 5 (TEST FURTHER)
    4           CNT=14
                KLAX=K+3
    5           IF (W(CNT).GT.0) GO TO 7
                   IF (CNT.EQ.KMAX) GO TO 6
                      CNT=CNT-1
                      GO TO 5
    6           CNT=K+1
                IF (2*(W(CNT)/2) .EQ. W(CNT)) GO TO 11
C        ROUND UP
    7              CNT=K+1
    8              W(CNT)=W(CNT)+1
                   IF (W(CNT).LT.10) GO TO 11
                      W(CNT)=W(CNT)-10
                      CNT=CNT-1
                      IF (CNT.GT.1) GO TO 8
C            [W(2) OVERFLOWED; SHIFT RIGHT & SET W(2)=1]
                         CNT=K+2
    9                    W(CNT)=W(CNT-1)
                         IF (CNT.LE.3) GO TO 10
                            CNT=CNT-1
                            GO TO 9
   10                    W(2)=1
                         K=K+1
                         CALL EXPON (W(15), W(16), W(17), 1)
                         IF (W(16).LT.10) GO TO 11
                            K=15
                            GO TO 1
C        PUT 0'S IN REMAINDER OF W
   11        KMAX=K+1
             DO 12 I=KMAX,13
   12           W(I+1)=0
             RETURN
             END
      SUBROUTINE FDIGIT (START, RTRN)
C         DATE OF LAST CHANGE - 750315
          IMPLICIT INTEGER (A-Z)
          LOGICAL TEMPF
          COMMON /INPUT/ CODE, EXPR(50), KEY, OLD, LSTK
     *           /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
             RTRN=0
             IF (START.EQ.2) GO TO 7
C ** START 1 - FIND A DIGIT (0-9, A)
             TEMPF=.FALSE.
    1        CALL CONTRL (3, 2)
             IF (CODE.GT.9) GO TO 2
                N=CODE
                GO TO 3
    2        IF (CODE.NE.23) GO TO 4
                N=10
    3           RN=N
                RETURN
    4        IF (CODE.NE.18) GO TO 5
                CALL ARGMNT (1)
                RTRN=1
                RETURN
    5        IF (CODE.NE.28) GO TO 6
                TEMPF=.TRUE.
                RETURN
    6        CALL MESAGE (3, RTRN)
                IF (RTRN.EQ.1) GO TO 13
             GO TO 1
C ** START 2 - DIGIT HAS BEEN FOUND FROM EXPRESSION
    7        CALL RANGE (RTRN)
                IF (RTRN.EQ.1) GO TO 13
             IF (RN.GT.11) GO TO 8
                IF (N.LT.11) GO TO 9
    8              CALL MESAGE (4, RTRN)
                   RTRN=1
                   RETURN
    9        GO TO (10, 11, 12), PTR-3
   10        CALL SCR (3)
                RETURN
   11        CALL STORE (3)
                RETURN
   12        CALL FLAG (2)
   13           RETURN
             END