perm filename CHS3.F4[1,VDS]1 blob sn#099237 filedate 1974-04-23 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00022 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	C     MAIN PROGRAM -- 'LOOK-UP'
C00014 00003	      BLOCK DATA
C00016 00004	      SUBROUTINE OUTPUT (SKIP, PRINT)
C00023 00005	      SUBROUTINE MESAGE
C00027 00006	      SUBROUTINE UPDATE
C00032 00007	      SUBROUTINE LPAREN
C00037 00008	      SUBROUTINE EQUAL
C00040 00009	      SUBROUTINE CLEAR
C00043 00010	      SUBROUTINE DROP
C00047 00011	      SUBROUTINE MULT
C00050 00012	      SUBROUTINE COLAPS (*)
C00052 00013	      SUBROUTINE COMBIN (*)
C00056 00014	      SUBROUTINE CLEARX
C00057 00015	      SUBROUTINE ENTRY
C00061 00016	      SUBROUTINE DIGIT
C00064 00017	      SUBROUTINE DECPT
C00067 00018	      SUBROUTINE CORECT
C00069 00019	      SUBROUTINE RECALL
C00073 00020	      SUBROUTINE STORE
C00077 00021	      SUBROUTINE REG (RN)
C00081 00022	      SUBROUTINE FIXN
C00084 ENDMK
CāŠ—;
C     MAIN PROGRAM -- 'LOOK-UP'
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          REAL Y
          REAL*8 DATE
          LOGICAL EEX,DP,START,JUMP,READ,NEXT,JMP,FIXFLG,CONTNU,PRINT
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          DO 1 I=2,21
            DO 1 J=1,17
                R(I,J)=0
    1           R(I,2)=15
          R(21,2)=1
          R(21,3)=5
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     SIZE = NO. OF KEYS ON KEYBOARD (SEE DECODER BELOW)
          SIZE=39
C *** READ CONTROL DATA
C     NEQNS = NO. OF TESTS TO BE RUN
C     READ = SWITCH FOR INPUT MODE (F = RANDOM)
C     SWITCH = OUTPUT CONTROL (0 -> NORMAL, 1 -> SHORT)
C     CONTNU = CONTROL AFTER AN ERROR (T = CONTINUE, F = STOP THIS TEST)
C     FIXFLG = 'DISPLAY' CONTROL (T = FIX MODE)
C     FIX = NUMBER OF DECIMAL DIGITS IN FIX MODE (0-9)
C     SCI = NUMBER OF DECIMAL DIGITS IN SCI MODE (0-9)
C     DATE = DATE OF RUN ('MO/DY/YR')
C     NKEYS = NO. OF KEY-STROKES PER TEST
C     IY = RANDOM NO.
C
          NEQNS=99
          CONTNU=.FALSE.
          PRINT=.FALSE.
          TYPE 1000
          ACCEPT 1010, START
          IF (START) GO TO 12
             TYPE 1001
             ACCEPT 1011, NEQNS
             TYPE 1002
             ACCEPT 1010, READ
                READ=.NOT.READ
                IF (READ) GO TO 11
                   TYPE 1003
                   ACCEPT 1012, NKEYS, IY
   11        TYPE 1004
             ACCEPT 1010, START
                IF (START) SWITCH=1
             TYPE 1005
             ACCEPT 1010, CONTNU
             TYPE 1006
             ACCEPT 1010, START
                IF (START) GO TO 12
                   TYPE 1007
                   ACCEPT 1010, FIXFLG
                   TYPE 1008
                   ACCEPT 1012, FIX, SCI
C     CONSIDER 'NEQNS' EQUATIONS
   12     DO 160 TEST=1,NEQNS
             ERROR=0
             OLD=1
             DO 2 II=1,50
                INPUT(II)=15
    2           EXPR(II)=15
             CALL CLEAR
             TYPE 1013, TEST
             IF (READ) GO TO 6
    3        DO 5 II=1,NKEYS
    4           CALL RANDOM (IY, Y, 0)
                JJ=(SIZE-1)*Y+1.5
                IF (JJ.EQ.15.OR.JJ.EQ.29.OR.JJ.EQ.30) GO TO 4
    5              INPUT(II)=JJ
    6        CALL OUTPUT (-1, PRINT)
             KEY=0
    7        KEY=KEY+1
C     OBTAIN NEXT KEY-CODE
                CALL CONTRL
C     DECODE KEY-CODE
    8           IF (JUMP) JUMP=.FALSE.
                IF (CODE.EQ.99) GO TO 160
                IF (CODE.EQ.999) GO TO 170
                IF (CODE.GT.SIZE) GO TO 9
                IF (CODE.LE.12) GO TO 10
                IF (CODE.EQ.13.OR.CODE.EQ.14) GO TO 20
                IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 30
                IF (CODE.EQ.18) GO TO 40
                IF (CODE.EQ.20) GO TO 50
                IF (CODE.EQ.22) GO TO 60
                IF (CODE.GT.22.AND.CODE.LT.26 .OR. CODE.EQ.38 .OR.
     *              CODE.EQ.39) GO TO 70
                IF (CODE.EQ.26) GO TO 80
                IF (CODE.EQ.27) GO TO 90
                IF (CODE.EQ.28) GO TO 10
                IF (CODE.EQ.21) GO TO 100
                IF (CODE.EQ.31) GO TO 110
                IF (CODE.EQ.32) GO TO 111
                IF (CODE.EQ.33) GO TO 112
                IF (CODE.EQ.34) GO TO 113
                IF (CODE.EQ.35) GO TO 114
                IF (CODE.EQ.36 .OR. CODE.EQ.37) GO TO 120
                IF (CODE.EQ.15.OR.CODE.EQ.29.OR.CODE.EQ.30) GO TO 140
C     KEY-CODE ERROR
    9           ERROR=17
                GO TO 120
C     CALL KEY ROUTINE
   10           CALL ENTRY
                   GO TO 120
   20           CALL SIGN
                   GO TO 120
   30           CALL MULT
                   GO TO 120
   40           CALL LPAREN
                   GO TO 120
   50           CALL RPAREN
                   GO TO 120
   60           CALL EQUAL
                   GO TO 120
   70           CALL RECALL
                   GO TO 120
   80           CALL CLEAR
                   GO TO 120
   90           CALL CLEARX
                   GO TO 120
  100           CALL ABSFCN
                   GO TO 120
  110           CALL STORE
                   GO TO 120
  111           CALL FIXN
                   GO TO 120
  112           CALL SCIN
                   GO TO 120
  113           CALL IMEDEX
                   GO TO 120
  114           CALL EXCH
C     PRINT EXPRESSION, STACK, VARIABLES
  120           IF (ERROR.GT.0) CALL MESAGE
                CALL OUTPUT (SWITCH, PRINT)
C     IF ERROR HAS OCCURRED PRINT MESSAGE & START NEW EXPRESSION
                IF (ERROR.EQ.0) GO TO 140
                   ERROR=0
                   IF (.NOT.CONTNU) GO TO 160
  140           IF(JUMP) GO TO 8
                IF(JMP) GO TO 10
  150           IF (KEY.LT.NKEYS) GO TO 7
  160        CONTINUE
  170     STOP
 1000     FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'   
     *              /'     CONSIDER 99 EQUATIONS'
     *              /'     ACCEPT KEYSTROKES FROM TTY'
     *              /'     PRODUCE SHORT OUTPUT'
     *              /'     STOP EQUATION AFTER AN ERROR'
     *              /'     DISPLAY IN FIX MODE W/ FIX=2 & SCI=5'
     *             //' THESE ARE OKAY. (T OR F)'/)
 1001     FORMAT (/' HOW MANY EQUATIONS ARE YOU GOING TO TRY? (NN)'/)
 1002     FORMAT (/' THE KEYSTROKES ARE TO BE GENERATED RANDOMLY.',
     *             ' (T OR F)'/)
 1003     FORMAT (/' ENTER THE NUMBER OF KEYSTROKES TO BE GENERATED '
     *            /' AND AN INITIAL RANDOM NUMBER. (NN <SP> MM)'/)
 1004     FORMAT (/' ABBREVIATED OUTPUT IS DESIRED. (T OR F)'/)
 1005     FORMAT (/' THE SAME EQUATION SHOULD BE CONTINUED AFTER AN '
     *            /' ERROR. (T OR F)'/)
 1006     FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
     *             ' (T OR F)'/)
 1007     FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. (T OR F)'/)
 1008     FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
     *            /' AND SCI MODES, RESPECTIVELY. (N <SP> M)'/)
 1010     FORMAT (L1)
 1011     FORMAT (I)
 1012     FORMAT (2I)
 1013     FORMAT ('1 TEST NO.',I3/)
          END
      BLOCK DATA
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          LOGICAL JUMP, NEXT, JMP, FIXFLG, READ
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          DATA P /6*0/, OP /6*0/, D /16*13/, X /102*13/,
     *         JUMP, JMP, NEXT /3*.FALSE./, NKEYS, SWITCH /50, 1/,
     *         FIXFLG, READ, FIX, SCI /2*.TRUE., 2, 5/,
     *         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, PRINT)
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          INTEGER*2 CHAR(39),STROKE(50),SIGN(6),ESN(6),DISPLY(16)
          LOGICAL EEX, DP, START, FIXFLG, PRINT
          REAL*8 NAME(3)
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     2           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     3           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     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)/'AB',' =',' 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)         /' ,','LX','LY'/
          DATA NAME /'     A =', 'LAST X =','LAST Y ='/
          IF (SKIP.LT.0) GO TO 30
   10        DO 20 I=OLD,KEY
                J=EXPR(I)
                IF (J.EQ.0) J=10
   20           STROKE(I)=CHAR(J)
             TYPE 100, (STROKE(I),I=1,KEY)
             OLD=KEY+1
             IF (SKIP.EQ.2) GO TO 75
             GO TO 60
   30     DO 50 I=1,50
   50        STROKE(I)=CHAR(15)
          TYPE 100, STROKE(1)
   60     DO 70 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
   70        ESN(I)=CHAR(K)
   75     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 95
          IF (SKIP.EQ.1) GO TO 90
          TYPE 200, P(6),SIGN(6),(X(6,N),N=2,14),ESN(6),X(6,16),
     2              X(6,17),OP(6),START,L,
     3              P(5),SIGN(5),(X(5,N),N=2,14),ESN(5),X(5,16),
     4              X(5,17),OP(5),DP,M,
     5              P(4),SIGN(4),(X(4,N),N=2,14),ESN(4),X(4,16),
     6              X(4,17),OP(4),EEX,FIX,
     7              P(3),SIGN(3),(X(3,N),N=2,14),ESN(3),X(3,16),
     8              X(3,17),OP(3),FIXFLG,SCI
   90     TYPE 300, P(2),SIGN(2),(X(2,N),N=2,14),ESN(2),X(2,16),
     2              X(2,17),OP(2),ERROR
          TYPE 400, P(1),SIGN(1),(X(1,N),N=2,14),ESN(1),X(1,16),
     2              X(1,17),OP(1)
   95     TYPE 500, DISPLY
          IF (SKIP.EQ.2) RETURN
          DO 96 I=2,4
             IF (R(I,2).NE.15) TYPE 600, NAME(I-1), (R(I,N), N=1,17)
   96        CONTINUE
          DO 97 I=5,20
             IF (R(I,2).EQ.15) GO TO 97
                J=I-5
                TYPE 700, J, (R(I,N), N=1,17)
   97        CONTINUE
          RETURN
  100     FORMAT (6X,'EXPRESSION: ',39A3/30X,11A3)
  200     FORMAT (//14X,'STACK:  S(6) -',4X,I2,' / ',A2,I2,' .',12I2,
     2            A2,2I2,' /',I3,10X,'FLAGS:  START - ',L2,10X,
     3            'INDICES:  L -',I3//
     4            22X,'S(5) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
     5            I3,18X,'DP    - ',L2,20X,'M -',I3//
     6            22X,'S(4) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
     7            I3,18X,'EEX   - ',L2,20X,'FIX-',I3//
     8            22X,'S(3) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
     9            I3,18X,'FIXFLG- ',L2,20X,'SCI-'I3)
  300     FORMAT (/22X,'S(2) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
     2            I3,18X,'ERROR - ',I2/)
  400     FORMAT (22X,'S(1) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
     2            I3/)
  500     FORMAT (/14X,'DISPLAY:',9X,16A3///)
  600     FORMAT (22X,A8,I3,I2,' .',15I2)
  700     FORMAT (22X,'REG(',I2,') =',I3,I2,' .',15I2)
          END
      SUBROUTINE MESAGE
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          DO 1 I=1,17
    1        R(3,I)=X(1,I)
          OP(1)=1
          D(1)=15
          DO 2 I=2,16
    2        D(I)=13
          D(8)=29
          D(9)=ERROR/10
          D(10)=ERROR-10*D(9)
          IF (ERROR.GT.1) GO TO 3
             D(15)=CODE/10
             D(16)=CODE-10*D(15)
    3     RETURN
          END
C
C
C
C
C
      SUBROUTINE CONTRL
C         DATE OF LAST CHANGE - 740101
          IMPLICIT INTEGER (A-Z)
          DIMENSION INPUT(50), EXPR(50)
          COMMON /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
          TYPE 1
          ACCEPT 2, CODE
          EXPR(KEY)=CODE
          IF (CODE.EQ.10) CODE=0
          RETURN
    1     FORMAT (' ?'/)
    2     FORMAT (I)
          END
C
C
C
C
C
      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, START, JUMP, NEXT, JMP, FIXFLG
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          L=1
          M=1
          DP=.FALSE.
          EEX=.FALSE.
          CALL UPDATE
          RETURN
          END
      SUBROUTINE UPDATE
C         DATE OF LAST CHANGE - 740209
          IMPLICIT INTEGER (A-Z)
          LOGICAL FIXFLG
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /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
          D(2)=X(1,2)
             IF (X(1,2).EQ.15) D(2)=0
             IF (D(1).EQ.13 .AND. D(2).EQ.0) D(1)=15
          IF (.NOT.FIXFLG) GO TO 12
C     DISPLAY IN "FIX" FORMAT
             IF (X(1,16).GT.0) GO TO 12
             EXPX=X(1,17)
             IF (X(1,15).EQ.13) GO TO 5
                K=EXPX+FIX+1
                IF (K.GT.10) GO TO 12
                   DO 1 I=13,16
    1                 D(I)=15
                   CALL ROUND (K)
                   K=EXPX+2
                   DO 2 I=3,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=K+FIX+1
                   GO TO 15
    5        D(2)=10
             D(3)=11
             K=FIX-EXPX+1
             IF (K.LE.0) GO TO 8
                CALL ROUND (K)
                J=EXPX+2
                DO 6 I=4,J
    6              D(I)=10
                DO 7 I=1,K
    7              D(J+I)=W(I+1)
                GO TO 10
    8        J=FIX+3
             DO 9 I=4,J
    9           D(I)=10
   10        K=FIX+4
             DO 11 I=13,16
   11           D(I)=15
             GO TO 15
C     DISPLAY IN "SCI" FORMAT
   12     CALL ROUND (SCI)
          D(13)=29
          DO 13 I=14,16
   13        D(I)=W(I+1)
          D(3)=11
          K=SCI+3
          DO 14 I=5,K
   14        D(I-1)=W(I-2)
   15     DO 16 I=K,12
   16        D(I)=15
          RETURN
          END
C
C
C
C
C
C
C
C
C
C
      SUBROUTINE ROUND (N)
C         DATE OF LAST CHANGE - 740209
          IMPLICIT INTEGER (A-Z)
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              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(N+2)-5) 6,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 6
    4     K=N+1
          W(K)=W(K)+1
          DO 5 I=3,K
             J=N+4-I
             IF (W(J).LT.10) GO TO 6
                W(J)=W(J)-10
    5           W(J-1)=W(J-1)+1
    6     RETURN
          END
      SUBROUTINE LPAREN
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          LOGICAL START
          DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (P(1).NE.3) GO TO 1
             ERROR=2
             RETURN
    1     IF (START) GO TO 6
          IF (X(1,2).NE.15) GO TO 2
             IF (X(1,1).NE.13) GO TO 6
                X(1,2)=1
                GO TO 3
    2     IF (OP(1).NE.0) GO TO 4
    3        OP(1)=50
             GO TO 5
    4     IF (OP(1).NE.1) GO TO 5
             CALL CLEARX
             GO TO 6
    5     CALL ENTRUP (&7)
    6     P(1)=P(1)+1
    7     RETURN
          END
C
C
C
C
C
C
C
C
C
C
      SUBROUTINE RPAREN
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          LOGICAL START
          DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (START) GO TO 1
          IF (OP(1).EQ.0) GO TO 2
    1        ERROR=1
             RETURN
    2     IF (P(1).NE.0) GO TO 3
             IF (OP(2).EQ.0) GO TO 1
             CALL EXECUT (&4)
             GO TO 2
    3     P(1)=P(1)-1
          IF (P(1).NE.0) RETURN
          IF (OP(2).NE.71) RETURN
             CALL EXECUT (&4)
    4        RETURN
             END
      SUBROUTINE EQUAL
C         DATE OF LAST CHANGE - 740306
          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 (X(1,2).EQ.15) GO TO 1
          IF (OP(1).EQ.0) GO TO 2
             IF (OP(1).EQ.1) RETURN
    1        ERROR=1
             RETURN
    2     IF (OP(2).EQ.0) GO TO 3
             CALL EXECUT (&5)
             GO TO 2
    3     IF (P(1).EQ.0) GO TO 4
             ERROR=4
             RETURN
    4     OP(1)=1
    5     RETURN
          END
C
C
C
C
C
      SUBROUTINE IMEDEX
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          DIMENSION P(6), X(6,17), OP(6), D(16)
          COMMON /STACK/ P, X, OP, D
          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).EQ.0) GO TO 2
    1        ERROR=1
             RETURN
    2     OP(2)=OP(1)
          CALL EXECUT
          RETURN
          END
C
C
C
C
C
      SUBROUTINE EXCH
C         DATE OF LAST CHANGE - 740215
          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 RESET
          RETURN
          END
      SUBROUTINE CLEAR
C         DATE OF LAST CHANGE - 731224
          IMPLICIT INTEGER (A-Z)
          LOGICAL START
          DIMENSION P(6), X(6,17), OP(6), D(16)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
          CALL CLEARS
          DO 1 II=2,6
             JJ=II-1
             P(II)=P(JJ)
             OP(II)=OP(JJ)
             DO 1 KK=1,17
    1           X(II,KK)=X(JJ,KK)
          START=.TRUE.
          RETURN
          END
C
C
C
C
C
      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
      SUBROUTINE ENTRUP (*)
C         DATE OF LAST CHANGE - 740106
          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 (X(6,2).EQ.15) GO TO 1
             ERROR=3
             RETURN 1
    1     DO 2 II=1,5
             JJ=6-II
             KK=JJ+1
             P(KK)=P(JJ)
             OP(KK)=OP(JJ)
             DO 2 LL=1,17
    2           X(KK,LL)=X(JJ,LL)
          CALL CLEARS
          RETURN
          END
      SUBROUTINE DROP
C         DATE OF LAST CHANGE - 731224
          IMPLICIT INTEGER (A-Z)
          DIMENSION P(6), X(6,17), OP(6), D(16)
          COMMON /STACK/ P, X, OP, D
          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 1 II=J,5
             JJ=II+1
             P(II)=P(JJ)
             OP(II)=OP(JJ)
             DO 1 KK=1,17
    1           X(II,KK)=X(JJ,KK)
          IF (OP(6).EQ.0) RETURN
             OP(6)=0
             P(6)=0
             DO 2 II=1,17
    2           X(6,II)=0
             X(6,2)=15
             RETURN
          END
C
C
C
C
C
C
C
C
C
C
      SUBROUTINE SIGN
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          LOGICAL START, JMP
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
          IF (OP(1).NE.0) GO TO 2
             IF (X(1,2).EQ.15) GO TO 3
    1           OP(1)=CODE+17
                CALL COLAPS (&4)
                RETURN
    2     IF (OP(1).EQ.1) GO TO 1
          CALL ENTRUP (&4)
    3     IF (START) START=.FALSE.
          IF (CODE.NE.13) RETURN
             IF (X(1,1).EQ.13) X(1,1)=14
             IF (X(1,1).NE.13) X(1,1)=13
             D(1)=X(1,1)
    4     RETURN
          END
      SUBROUTINE MULT
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /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     OP(1)=CODE+24
          IF (CODE.EQ.19) OP(1)=60
          CALL COLAPS (&3)
    3     RETURN
          END
C
C
C
C
C
C
C
C
C
C
      SUBROUTINE ABSFCN
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          LOGICAL START
          DIMENSION P(6), X(6,17), OP(6), D(16)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
          IF (.NOT.START) GO TO 1
             START=.FALSE.
             GO TO 4
    1     IF (X(1,2).EQ.15) GO TO 4
             IF (OP(1).NE.0) GO TO 2
                OP(1)=50
                GO TO 3
    2        IF (OP(1).NE.1) GO TO 3
                CALL CLEARX
                GO TO 4
    3     CALL ENTRUP (&5)
    4     OP(1)=71
          X(1,2)=21
    5     RETURN
          END
      SUBROUTINE COLAPS (*)
C         DATE OF LAST CHANGE - 740306
          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(1)/10 .GT. OP(2)/10) RETURN
          IF (OP(2).NE.0) GO TO 3
             ERROR=18
    2        RETURN 1
    3     CALL EXECUT (&2)
          GO TO 1
          END
C
C
C
C
C
C
C
C
C
C
      SUBROUTINE EXECUT (*)
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          DIMENSION P(6), X(6,17), OP(6), D(16)
          COMMON /STACK/ P, X, OP, D
          IF (OP(2).EQ.71) GO TO 1
             CALL COMBIN (&3)
             GO TO 2
    1     IF (X(1,1).EQ.13) X(1,1)=14
          IF (X(2,1).EQ.13) X(1,1)=13
    2     CALL DROP
          CALL UPDATE
          RETURN
    3     RETURN 1
          END
      SUBROUTINE COMBIN (*)
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          REAL RX(2), X1, ALOG10, ABS, ALOG, EXP
          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     SAVE X(1,N) IN "LST X" & X(2,N) IN "LST Y"
          DO 14 N=1,17
             R(3,N)=X(1,N)
   14        R(4,N)=X(2,N)
C     CONVERT X(I,N) TO RX(I)
          DO 2 I=1,2
             RX(I)=X(I,14)
             DO 1 J=1,12
                K=14-J
    1           RX(I)=0.1*RX(I)+X(I,K)
             IF (X(I,1).EQ.13) RX(I)=-RX(I)
             J=10*X(I,16)+X(I,17)
             IF (J.GT.30) J=30
             IF (X(I,15).EQ.13) J=-J
    2        RX(I)=RX(I)*10**J
          X1=RX(1)
C     NOW EXECUTE RX(2), OP(2), RX(1) -> RX(1)=X1
          IF (OP(2).GT.31) GO TO 3
             IF (OP(2).EQ.30) X1=-X1
             X1=RX(2)+X1
             GO TO 6
    3     IF (OP(2).EQ.40) GO TO 4
          IF (OP(2).EQ.60) GO TO 5
             X1=RX(2)*X1
             GO TO 6
    4     IF (X1.NE.0) GO TO 45
   41        ERROR=7
             RETURN 1
   45     X1=RX(2)/X1
          GO TO 6
    5     IF (RX(2).LE.0.) GO TO 41
             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)
C     EXTRACT EXPONENT, -> X(1,15),..., X(1,17)
    6     IF (X1.EQ.0.) GO TO 7
             K=ALOG10(ABS(X1))
             GO TO 8
    7     K=0
    8     X1=X1/10**K
          IF (K.GE.0) GO TO 9
             X(1,15)=13
             GO TO 10
    9     X(1,15)=14
   10     X(1,16)=K/10
          X(1,17)=K-10*X(1,16)
          IF (X1.GT.0) GO TO 11
             X(1,1)=13
             X1=-X1
             GO TO 12
   11     X(1,1)=14
C     CONVERT X1=RX(1) TO X(1,N)
   12     X(1,2)=X1
          DO 13 I=3,7
             J=I-1
             X1=10.*(X1-X(1,J))
   13        X(1,I)=X1
          RETURN
          END
      SUBROUTINE CLEARX
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
          OP(1)=0
C     THIS STATEMENT IS NUMBERED FOR REFERENCE IN 'CORECT'
          X(1,1)=15
          X(1,2)=15
    1     DO 2 II=3,17
    2        X(1,II)=0
C     UNCLEAR WHETHER SHOULDN'T JUST 'CALL UPDATE' HERE
          CALL RESET
          RETURN
          END
      SUBROUTINE ENTRY
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, START, JUMP, JMP
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (JMP) GO TO 13
          IF (.NOT.START) GO TO 1
             START=.FALSE.
             GO TO 4
    1     IF (X(1,2).EQ.15) GO TO 4
          IF (OP(1).NE.0) GO TO 2
             OP(1)=50
             GO TO 3
    2     IF (OP(1).NE.1) GO TO 3
             CALL CLEARX
             GO TO 4
    3        CALL ENTRUP (&12)
    4     DO 45 I=2,16
   45        D(I)=15
          IF (CODE.GT.10) GO TO 5
             CALL DIGIT
             GO TO 14
    5     IF (CODE.NE.11) GO TO 6
             CALL DECPT
             GO TO 14
    6     IF (CODE.NE.12) GO TO 65
             CALL ENTEXP
             GO TO 14
   65     IF (CODE.NE.28) GO TO 66
             CALL CORECT
             IF (.NOT.JUMP) GO TO 14
                JUMP=.FALSE.
                RETURN
   66     IF (CODE.NE.32 .AND. CODE.NE.33) GO TO 7
             IF (CODE.EQ.32) CALL FIXN
             IF (CODE.EQ.33) CALL SCIN
             GO TO 14
    7     IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 8
             IF (D(15).EQ.15) D(15)=0
             IF (D(16).EQ.15) D(16)=0
             J=10*D(15)+D(16)
             IF (J.NE.0) GO TO 8
                D(14)=CODE
                GO TO 14
    8     IF (X(1,2).EQ.15) GO TO 11
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 9
             J=-J
             X(1,15)=13
             GO TO 10
    9     X(1,15)=14
   10     X(1,16)=J/10
          X(1,17)=J-X(1,16)*10
          IF (X(1,16).LT.10) GO TO 12
             ERROR=3
          GO TO 12
   11     X(1,2)=0
   12     JUMP=.TRUE.
          CALL RESET
          RETURN
   13     JMP=.FALSE.
   14     CALL OUTPUT (2,.FALSE.)
          KEY=KEY+1
          CALL CONTRL
          GO TO 4
          END
      SUBROUTINE DIGIT
C         DATE OF LAST CHANGE - 731206
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /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 (L.GT.13) GO TO 7
          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) GO TO 6
    5        L=L+1
             X(1,L)=CODE
    6     IF (M.GT.13) GO TO 7
             M=M+1
             D(M)=CODE
             RETURN
    7     IF (DP) RETURN
             CALL EXPON (D(14),D(15),D(16),1)
             RETURN
          END
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'
          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 - 740404
          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, START, JUMP, NEXT, JMP, FIXFLG
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (EEX) GO TO 4
          IF (.NOT.DP) GO TO 1
             OP(1)=50
             CALL ENTRUP (&3)
             GO TO 2
    1     DP=.TRUE.
    2     M=M+1
          D(M)=11
    3     RETURN
    4     EEX=.FALSE.
          RETURN
          END
C
C
C
C
C
C
C
C
C
C
      SUBROUTINE ENTEXP
C         DATE OF LAST CHANGE - 740404
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX
          DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (.NOT.EEX) GO TO 1
             OP(1)=50
             CALL COLAPS (&4)
             CALL ENTRUP (&4)
             GO TO 3
    1     IF (D(13).EQ.29) GO TO 2
             D(13)=29
             D(14)=15
             D(15)=0
             D(16)=0
    2     EEX=.TRUE.
          IF (M.GT.1) RETURN
    3        X(1,1)=14
             X(1,2)=1
             D(1)=15
             D(2)=1
             D(3)=11
    4        RETURN
          END
      SUBROUTINE CORECT
C         DATE OF LAST CHANGE - 740404
          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, START, JUMP, NEXT, JMP, FIXFLG
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (OP(1).NE.0) GO TO 7
          IF (M.EQ.1) RETURN
          IF (EEX) GO TO 5
          IF (DP) GO TO 3
          IF (L.EQ.2) GO TO 1
             IF (L.EQ.1) GO TO 2
                CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
    1     X(1,L)=0
          L=L-1
    2     D(M)=15
          M=M-1
          IF (M.NE.1) RETURN
C     SHOULD 'GO TO' STATEMENT #1 OF CLEARX, BUT IT'S 'CALLED' FOR CONVENIENCE
             CALL CLEARX
             JUMP=.TRUE.
             RETURN
    3     IF (D(M).NE.11) GO TO 4
             DP=.FALSE.
             GO TO 2
    4     IF (L.GT.2) GO TO 1
             CALL EXPON (X(1,15),X(1,16),X(1,17),1)
             IF (L.EQ.1) GO TO 2
                GO TO 1
    5     DO 6 I=13,16
    6        D(I)=15
          EEX=.FALSE.
          RETURN
    7     OP(1)=0
          RETURN
          END
      SUBROUTINE RECALL
C         DATE OF LAST CHANGE - 740310
          IMPLICIT INTEGER (A-Z)
          LOGICAL START, JUMP, NEXT
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (.NOT.START) GO TO 1
             START=.FALSE.
             GO TO 4
    1     IF (X(1,2).EQ.15) GO TO 4
          IF (OP(1).NE.0) GO TO 2
             OP(1)=50
             GO TO 3
    2     IF (OP(1).NE.1) GO TO 3
             CALL CLEARX
             GO TO 4
    3     CALL ENTRUP (&14)
    4     IF (CODE-24) 5, 6, 7
    5     REGNO=-3
             GO TO 9
    6     REGNO=-4
             GO TO 9
    7     IF (CODE.EQ.25) GO TO 8
             REGNO=CODE-40
             GO TO 9
    8     CALL REG (REGNO)
             IF (ERROR.NE.0) RETURN
    9     IF (X(1,1).EQ.13) GO TO 10
             CALL TRANS (REGNO,.FALSE.)
             GO TO 12
   10     CALL TRANS (REGNO,.FALSE.)
          IF (X(1,1).EQ.13) GO TO 11
             X(1,1)=13
             GO TO 12
   11     X(1,1)=14
   12     IF (X(1,2).NE.15) GO TO 13
             ERROR=6
             RETURN
   13     CALL UPDATE
          IF (NEXT) JUMP=.TRUE.
   14     RETURN
          END
      SUBROUTINE STORE
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          LOGICAL JUMP, NEXT
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17), OPCD(19)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          DATA OPCD /12*0, 30, 31, 0, 40, 41, 0, 60/
          CALL EQUAL
          IF (ERROR.NE.0) RETURN
          KMAX=2
          OPCODE=0
    1     CALL FINDN (K,KMAX,REGNO)
          IF (K.NE.0) GO TO 5
          IF (CODE.EQ.23) GO TO 3
          IF (CODE.EQ.25) GO TO 4
          IF (CODE.GT.12.AND.CODE.LT.18.AND.CODE.NE.15) GO TO 2
             ERROR=1
             RETURN
    2     OPCODE=OPCD(CODE)
          GO TO 1
    3     REGNO=-3
          GO TO 6
    4     CALL REG (REGNO)
    5     IF (REGNO.LE.16) GO TO 6
             ERROR=5
             RETURN
    6     IF (OPCODE.EQ.0) GO TO 8
             OP(1)=OPCODE
             CALL ENTRUP (&9)
             CALL TRANS (REGNO,.FALSE.)
             DO 7 I=1,17
                J=X(1,I)
                X(1,I)=X(2,I)
    7           X(2,I)=J
             CALL EXECUT (&9)
    8     CALL TRANS (REGNO,.TRUE.)
          IF (NEXT) JUMP=.TRUE.
    9     RETURN
          END
C
      SUBROUTINE TRANS (REGNO,STORE)
C         DATE OF LAST CHANGE - 740101
          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)
          RETURN
          END
      SUBROUTINE REG (RN)
C         DATE OF LAST CHANGE - 740306
          IMPLICIT INTEGER (A-Z)
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /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 4
             IF (CODE.EQ.25) GO TO 3
                IF (CODE.EQ.22) GO TO 2
                   ERROR=9
                   RETURN
    2           RN=16
                OP(1)=1
                RETURN
    3        IND=IND+1
             GO TO 1
    4     IF (RN.LE.16) GO TO 5
             ERROR=5
             RETURN
    5     IF (IND.EQ.0) RETURN
          IF (R(RN,2).EQ.15) GO TO 6
             RN=(R(RN,2)+0.1*R(RN,3))*10**R(RN,17)
             IND=IND-1
             GO TO 4
    6     ERROR=6
          RETURN
          END
C
C
C
      SUBROUTINE FINDN (K,KMAX,RN)
C         DATE OF LAST CHANGE - 740227
          IMPLICIT INTEGER (A-Z)
          INTEGER INPUT(50), EXPR(50)
          LOGICAL NEXT
          COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
          NEXT=.FALSE.
          K=0
          RN=0
    1     KEY=KEY+1
          CALL CONTRL
          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
      SUBROUTINE FIXN
          IMPLICIT INTEGER (A-Z)
          LOGICAL JUMP, FIXFLG
          DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
          COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          FIXFLG=.TRUE.
          KEY=KEY+1
          CALL CONTRL
          IF (CODE.LT.11) GO TO 1
             JUMP=.TRUE.
             GO TO 2
    1     FIX=CODE
    2     CALL UPDATE
          RETURN
          END
C
C
C
C
C
C
C
C
C
C
      SUBROUTINE SCIN
C         DATE OF LAST CHANGE - 740225
          IMPLICIT INTEGER (A-Z)
          LOGICAL JUMP, FIXFLG
          DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
          COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          FIXFLG=.FALSE.
          KEY=KEY+1
          CALL CONTRL
          IF (CODE.LT.11) GO TO 1
             JUMP=.TRUE.
             GO TO 2
    1     SCI=CODE+1
          IF (SCI.EQ.11) SCI=1
    2     CALL UPDATE
          RETURN
          END