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