      PROGRAM CALC

C     Calculator emulator (2-4-84 Greg Janee)

C     The logical name CALC$HELPFILE should contain the file
C     specification of CALC's help file.

      EXTERNAL HANDLER

      PARAMETER CARR_RETURN = '0000000D'X
      PARAMETER DELETE      = '0000007F'X
      PARAMETER CTRL_B      = '00000002'X
      PARAMETER CTRL_E      = '00000005'X
      PARAMETER CTRL_F      = '00000006'X
      PARAMETER CTRL_H      = '00000008'X
      PARAMETER CTRL_I      = '00000009'X
      PARAMETER CTRL_O      = '0000000F'X
      PARAMETER DT$_VT100   = '00000060'X
      PARAMETER DT$_VT52    = '00000040'X

      CHARACTER INPUT*1,MODE*1,STRING*37,B*1,W*1
      INTEGER   IO_CHAN,TT_TYPE,FIX_NUM
      LOGICAL   BLACK,WHITE,DIGIT,ERROR

      COMMON / DISP   / MODE,STRING,ERROR
      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

      CALL LIB$ESTABLISH ( HANDLER )
      CALL INITIALIZE

      IF     ( TT_TYPE .EQ. DT$_VT100 ) THEN
         W = 'W'
         B = 'B'
      ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN
         W = 'L'
         B = 'U'
      END IF

      BLACK = .FALSE.
      WHITE = .FALSE.

1000  CONTINUE

         CALL GET_INPUT ( INPUT )
         IF ( ERROR ) CALL ERR_HAND ( 0 )

         IF ( BLACK ) THEN

            IF     ( INPUT .EQ. 'P' ) THEN
            ELSEIF ( INPUT .EQ. 'Q' ) THEN
               WHITE = .TRUE.
               CALL OUT_CHAR ( 8,68,1,W )
            ELSEIF ( INPUT .EQ. 'R' ) THEN
               CALL LOG_10
            ELSEIF ( INPUT .EQ. 'S' ) THEN
               CALL LOG_E
            ELSEIF ( INPUT .EQ. '7' ) THEN
               CALL SINE
            ELSEIF ( INPUT .EQ. '8' ) THEN
               CALL COSINE
            ELSEIF ( INPUT .EQ. '9' ) THEN
               CALL TANGENT
            ELSEIF ( INPUT .EQ. '-' ) THEN
               CALL CHANGE_TRIG ( 'RAD',1 )
            ELSEIF ( INPUT .EQ. '4' ) THEN
               CALL SQUARE_ROOT
            ELSEIF ( INPUT .EQ. '5' ) THEN
               CALL INVERT
            ELSEIF ( INPUT .EQ. '6' ) THEN
               CALL CHANGE_SIGN
            ELSEIF ( INPUT .EQ. ',' ) THEN
               CALL INTEGER
            ELSEIF ( INPUT .EQ. '1' ) THEN
               CALL ROLL_DOWN
            ELSEIF ( INPUT .EQ. '2' ) THEN
               CALL OUT_CHAR  ( 8,71,1,'Q' )
               CALL ERR_HAND  ( -1 )
               CALL GET_INPUT ( INPUT )
               CALL FIX ( INPUT )
               CALL OUT_CHAR ( 8,71,1,' ' )
            ELSEIF ( INPUT .EQ. '3' ) THEN
               CALL LAST_X
            ELSEIF ( INPUT .EQ. CHAR( CARR_RETURN ) ) THEN
               CALL OUT_CHAR  ( 8,71,1,'Q' )
               CALL ERR_HAND  ( -2 )
               CALL GET_INPUT ( INPUT )
               CALL HELP ( INPUT )
            ELSEIF ( INPUT .EQ. '0' ) THEN
               CALL CLEAR_X_REG
            ELSEIF ( INPUT .EQ. '.' ) THEN
               CALL PI
            ELSEIF ( INPUT .EQ. CHAR( CTRL_H ) ) THEN
               IF ( TT_TYPE .EQ. DT$_VT52 ) THEN
                  CALL LOG_E
               ELSE
                  CALL ERR_HAND ( -3 )
               END IF
            ELSE
               CALL ERR_HAND ( -3 )
            END IF
            BLACK = .FALSE.
            CALL OUT_CHAR ( 8,65,1,' ' )
            CALL MOVE_TO  ( 24,1 )

         ELSEIF ( WHITE ) THEN

            IF     ( INPUT .EQ. 'P' ) THEN
               BLACK = .TRUE.
               CALL OUT_CHAR ( 8,65,1,B )
            ELSEIF ( INPUT .EQ. 'Q' ) THEN
            ELSEIF ( INPUT .EQ. 'R' ) THEN
               CALL POWER_10
            ELSEIF ( INPUT .EQ. 'S' ) THEN
               CALL POWER_E
            ELSEIF ( INPUT .EQ. '7' ) THEN
               CALL ARC_SINE
            ELSEIF ( INPUT .EQ. '8' ) THEN
               CALL ARC_COSINE
            ELSEIF ( INPUT .EQ. '9' ) THEN
               CALL ARC_TANGENT
            ELSEIF ( INPUT .EQ. '-' ) THEN
               CALL CHANGE_TRIG ( 'DEG',1 )
            ELSEIF ( INPUT .EQ. '4' ) THEN
               CALL SQUARE_X
            ELSEIF ( INPUT .EQ. '5' ) THEN
               CALL EXPONENT
            ELSEIF ( INPUT .EQ. '6' ) THEN
               CALL ABS_VALUE
            ELSEIF ( INPUT .EQ. ',' ) THEN
               CALL FRACTION
            ELSEIF ( INPUT .EQ. '1' ) THEN
               CALL ROLL_UP
            ELSEIF ( INPUT .EQ. '2' ) THEN
               CALL EXCHANGE
            ELSEIF ( INPUT .EQ. '3' ) THEN
               CALL RESET
            ELSEIF ( INPUT .EQ. CHAR( CARR_RETURN ) ) THEN
               CALL CLEAR_SCREEN
               CALL SYS$EXIT ( %VAL(1) )
            ELSEIF ( INPUT .EQ. '0' ) THEN
               CALL CLEAR_STACK
            ELSEIF ( INPUT .EQ. '.' ) THEN
               CALL E
            ELSEIF ( INPUT .EQ. CHAR( CTRL_H ) ) THEN
               IF ( TT_TYPE .EQ. DT$_VT52 ) THEN
                  CALL POWER_E
               ELSE
                  CALL ERR_HAND ( -3 )
               END IF
            ELSE
               CALL ERR_HAND ( -3 )
            END IF
            WHITE = .FALSE.
            CALL OUT_CHAR ( 8,68,1,' ' )
            CALL MOVE_TO  ( 24,1 )

         ELSE

            IF     ( INPUT .EQ. CHAR( CARR_RETURN ) ) THEN
               CALL ENTER
            ELSEIF ( INPUT .EQ. CHAR( DELETE ) ) THEN
               CALL DELETE_DIGIT
            ELSEIF ( INPUT .EQ. '+' ) THEN
               CALL ADD
            ELSEIF ( INPUT .EQ. '-' ) THEN
               CALL SUBTRACT
            ELSEIF ( INPUT .EQ. '*' ) THEN
               CALL MULTIPLY
            ELSEIF ( INPUT .EQ. '/' ) THEN
               CALL DIVIDE
            ELSEIF ( INPUT .EQ. 'P' ) THEN
               BLACK = .TRUE.
               CALL OUT_CHAR ( 8,65,1,B )
               CALL MOVE_TO  ( 24,1 )
            ELSEIF ( INPUT .EQ. 'Q' ) THEN
               WHITE = .TRUE.
               CALL OUT_CHAR ( 8,68,1,W )
               CALL MOVE_TO  ( 24,1 )
            ELSEIF ( INPUT .EQ. CHAR( CTRL_B ) ) THEN
               CALL CHANGE_MODE ( 'B',1 )
            ELSEIF ( INPUT .EQ. CHAR( CTRL_E ) ) THEN
               CALL CHANGE_MODE ( 'E',1 )
            ELSEIF ( INPUT .EQ. CHAR( CTRL_F ) ) THEN
               CALL CHANGE_MODE ( 'F',1 )
            ELSEIF ( INPUT .EQ. CHAR( CTRL_H ) ) THEN
               CALL CHANGE_MODE ( 'H',1 )
            ELSEIF ( INPUT .EQ. CHAR( CTRL_I ) ) THEN
               CALL CHANGE_MODE ( 'I',1 )
            ELSEIF ( INPUT .EQ. CHAR( CTRL_O ) ) THEN
               CALL CHANGE_MODE ( 'O',1 )
            ELSEIF ( INPUT .EQ. '?' ) THEN
               CALL HELP ( INPUT )
            ELSE
               CALL DIGIT ( INPUT )
            END IF

         END IF

      GO TO 1000

      END

      SUBROUTINE ABS_VALUE

C     Calculates | X |

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = DABS( X )

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ADD

C     Adds the Y register to the X register

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

C     Load the X register if necessary

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = X + Y
      Y = Z
      Z = T
      T = 0.

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ADD_DIGIT ( DIGIT )

C     Adds a digit to the current display

      PARAMETER CARR_RETURN = '0000000D'X

      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      CHARACTER STRING*37,DIGIT*1,MODE*1
      LOGICAL   PUSH_FLAG,ERROR,RADS,D_OK

      COMMON / DISP  / MODE,STRING,ERROR
      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( LAST .EQ. CARR_RETURN ) THEN
         X = 0.
         STRING = ' '
         CALL OUT_CHAR ( 6,40,37,STRING )
         CALL MOVE_TO  ( 24,1 )
      END IF

      IF ( PUSH_FLAG ) THEN
         CALL PUSH_STACK
         STRING = ' '
         CALL OUT_CHAR ( 6,40,37,STRING )
         CALL MOVE_TO  ( 24,1 )
         PUSH_FLAG = .FALSE.
      END IF

      IF ( STRING(1:1) .NE. ' ' ) THEN
         CALL ERR_HAND ( -5 )
      ELSE
         STRING = STRING(2:37)//DIGIT
         CALL OUT_CHAR ( 6,40,37,STRING )
         CALL MOVE_TO  ( 24,1 )
         D_OK = .TRUE.
      END IF

      LAST = 0

      RETURN
      END

      SUBROUTINE ARC_COSINE

C     Calculates ARCCOS( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( RADS ) THEN
         X = DACOS( X )
      ELSE
         X = DACOSD( X )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ARC_SINE

C     Calculates ARCSIN( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( RADS ) THEN
         X = DASIN( X )
      ELSE
         X = DASIND( X )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ARC_TANGENT

C     Calculates ARCTAN( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( RADS ) THEN
         X = DATAN( X )
      ELSE
         X = DATAND( X )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE CHANGE_MODE ( NEW_MODE,FLAG )

C     Changes the display mode as follows:
C
C        I   Decimal integer
C        B   Binary integer
C        O   Octal integer
C        H   Hexadecimal integer
C        F   Floating point (decimal)
C        E   Exponential floating point (decimal)

      INTEGER   FLAG
      REAL*8    X,Y,Z,T,LASTX
      LOGICAL   PUSH_FLAG,ERROR,RADS,D_OK
      BYTE      LAST
      CHARACTER MODE*1,NEW_MODE*1,STRING*37

      COMMON / DISP  / MODE,STRING,ERROR
      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF     ( NEW_MODE .EQ. 'I' ) THEN
         CALL OUT_CHAR ( 8,39,24,'Integer mode            ' )
         MODE = NEW_MODE
      ELSEIF ( NEW_MODE .EQ. 'B' ) THEN
         CALL OUT_CHAR ( 8,39,24,'Binary integer mode     ' )
         MODE = NEW_MODE
      ELSEIF ( NEW_MODE .EQ. 'O' ) THEN
         CALL OUT_CHAR ( 8,39,24,'Octal integer mode      ' )
         MODE = NEW_MODE
      ELSEIF ( NEW_MODE .EQ. 'H' ) THEN
         CALL OUT_CHAR ( 8,39,24,'Hexadecimal integer mode' )
         MODE = NEW_MODE
      ELSEIF ( NEW_MODE .EQ. 'F' ) THEN
         CALL OUT_CHAR ( 8,39,24,'Floating point mode     ' )
         MODE = NEW_MODE
      ELSEIF ( NEW_MODE .EQ. 'E' ) THEN
         CALL OUT_CHAR ( 8,39,24,'Exponential mode        ' )
         MODE = NEW_MODE
      END IF
      CALL MOVE_TO ( 24,1 )

      PUSH_FLAG = .TRUE.
      LAST = 0

      IF ( FLAG .EQ. 1 ) CALL DISPLAY

      RETURN
      END

      SUBROUTINE CHANGE_SIGN

C     Changes the sign of the X register

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = - X

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE CHANGE_TRIG ( MODE,FLAG )

C     Changes from degrees to radians, and vice-versa

      INTEGER   FLAG
      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      CHARACTER MODE*3
      LOGICAL   PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( MODE .EQ. 'DEG' ) THEN
         RADS = .FALSE.
         CALL OUT_CHAR ( 8,75,3,'DEG' )
      ELSE
         RADS = .TRUE.
         CALL OUT_CHAR ( 8,75,3,'RAD' )
      END IF
      CALL MOVE_TO ( 24,1 )

      PUSH_FLAG = .TRUE.
      LAST = 0
      IF ( FLAG .EQ. 1 ) CALL DISPLAY
 
      RETURN
      END

      SUBROUTINE CLEAR_SCREEN

C     Clears the screen

      PARAMETER DT$_VT100 = '00000060'X
      PARAMETER DT$_VT52  = '00000040'X

      BYTE    FORM_1(6),FORM_2(4)
      INTEGER TT_TYPE,IO_CHAN,FIX_NUM

      DATA FORM_1 / 27,'[','H',27,'[','J' /
      DATA FORM_2 / 27,'H', 27,'J' /

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

      IF     ( TT_TYPE .EQ. DT$_VT100 ) THEN
         CALL OUT_BYTE ( 6,FORM_1 )
      ELSEIF ( TT_TYPE .EQ. DT$_VT52  ) THEN
         CALL OUT_BYTE ( 4,FORM_2 )
      END IF

      RETURN
      END

      SUBROUTINE CLEAR_STACK

C     Resets the stack

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      X = 0.
      Y = 0.
      Z = 0.
      T = 0.
      LASTX = 0.

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE CLEAR_X_REG

C     Clears the X register

      PARAMETER CARR_RETURN = '0000000D'X

      CHARACTER MODE*1,STRING*37
      LOGICAL   ERROR,PUSH_FLAG,RADS,D_OK
      BYTE      LAST
      REAL*8    X,Y,Z,T,LASTX

      COMMON / DISP  / MODE,STRING,ERROR
      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      X = 0.

      PUSH_FLAG = .FALSE.
      LAST = CARR_RETURN

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE COSINE

C     Calculates COS( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( RADS ) THEN
         X = DCOS( X )
      ELSE
         X = DCOSD( X )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE DELETE_DIGIT

C     Deletes a digit from the current display

      PARAMETER CARR_RETURN = '0000000D'X

      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      CHARACTER MODE*1,STRING*37
      LOGICAL   PUSH_FLAG,RADS,ERROR,D_OK

      COMMON / DISP  / MODE,STRING,ERROR
      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( D_OK ) THEN
         STRING = ' '//STRING(1:36)
         IF ( STRING(37:37) .EQ. ' ' ) THEN
            CALL DISPLAY
            LAST = CARR_RETURN
         ELSE
            CALL OUT_CHAR ( 6,40,37,STRING )
            CALL MOVE_TO  ( 24,1 )
         END IF
      ELSE
         CALL ERR_HAND ( -4 )
      END IF

      RETURN
      END

      SUBROUTINE DIGIT ( CHAR )

C     Determines if the character is a valid digit

      PARAMETER CARR_RETURN = '0000000D'X

      CHARACTER MODE*1,CHAR*1,STRING*37
      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      INTEGER   STR$POSITION
      LOGICAL   PUSH_FLAG,ERROR,RADS,D_OK,FLAG

      COMMON / DISP  / MODE,STRING,ERROR
      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( LAST .EQ. CARR_RETURN ) THEN
         FLAG = .TRUE.
      ELSE
         FLAG = PUSH_FLAG
      END IF

      IF ( MODE .EQ. 'I' ) THEN

         IF ( CHAR.GE.'0' .AND. CHAR.LE.'9' ) THEN
            CALL ADD_DIGIT ( CHAR )
         ELSE
            CALL ERR_HAND ( -6 )
         END IF

      ELSEIF ( MODE .EQ. 'B' ) THEN

         IF ( CHAR.GE.'0' .AND. CHAR.LE.'1' ) THEN
            CALL ADD_DIGIT ( CHAR )
         ELSE
            CALL ERR_HAND ( -6 )
         END IF

      ELSEIF ( MODE .EQ. 'O' ) THEN

         IF ( CHAR.GE.'0' .AND. CHAR.LE.'7' ) THEN
            CALL ADD_DIGIT ( CHAR )
         ELSE
            CALL ERR_HAND ( -6 )
         END IF

      ELSEIF ( MODE .EQ. 'H' ) THEN

         IF ( (CHAR.GE.'0' .AND. CHAR.LE.'9') .OR.
     .        (CHAR.GE.'A' .AND. CHAR.LE.'F')      ) THEN
            CALL ADD_DIGIT ( CHAR )
         ELSE
            CALL ERR_HAND ( -6 )
         END IF

      ELSEIF ( MODE .EQ. 'F' ) THEN

         IF ( CHAR.GE.'0' .AND. CHAR.LE.'9' ) THEN
            CALL ADD_DIGIT ( CHAR )
         ELSEIF ( CHAR .EQ. '.' ) THEN
            IF ( FLAG ) THEN
               CALL ADD_DIGIT ( CHAR )
            ELSE
               IF ( STR$POSITION( STRING,'.' ) .EQ. 0 ) THEN
                  CALL ADD_DIGIT ( CHAR )
               ELSE
                  CALL ERR_HAND ( -7 )
               END IF
            END IF
         ELSE
            CALL ERR_HAND ( -6 )
         END IF

      ELSEIF ( MODE .EQ. 'E' ) THEN

         IF ( CHAR.GE.'0' .AND. CHAR.LE.'9' ) THEN
            IF ( FLAG ) THEN
               CALL ADD_DIGIT ( CHAR )
            ELSE
               I = STR$POSITION( STRING,'E' )
               IF ( I .NE. 0 ) THEN
                  CALL STR$TRIM ( STRING,STRING,J )
                  IF ( J-I .LE. 1 ) THEN
                     CALL ADD_DIGIT ( CHAR )
                  ELSE
                     IF ( J-I.EQ.2 .AND. STRING(36:36).EQ.'-' ) THEN
                        CALL ADD_DIGIT ( CHAR )
                     ELSE
                        CALL ERR_HAND ( -8 )
                     END IF
                  END IF
               ELSE
                  CALL ADD_DIGIT ( CHAR )
               END IF
            END IF
         ELSEIF ( CHAR .EQ. 'E' ) THEN
            IF ( .NOT.FLAG ) THEN
               IF ( STR$POSITION( STRING,'E' ) .EQ. 0 ) THEN
                  CALL ADD_DIGIT ( CHAR )
               ELSE
                  CALL ERR_HAND ( -9 )
               END IF
            ELSE
               CALL ERR_HAND ( -10 )
            END IF
         ELSEIF ( CHAR .EQ. '.' ) THEN
            IF ( FLAG ) THEN
               CALL ADD_DIGIT ( CHAR )
            ELSE
               IF ( STR$POSITION( STRING,'.' ) .EQ. 0 ) THEN
                  IF ( STR$POSITION( STRING,'E' ) .EQ. 0 ) THEN
                     CALL ADD_DIGIT ( CHAR )
                  ELSE
                     CALL ERR_HAND ( -11 )
                  END IF
               ELSE
                  CALL ERR_HAND ( -7 )
               END IF
            END IF
         ELSE
            CALL ERR_HAND ( -6 )
         END IF

      END IF

      RETURN
      END

      SUBROUTINE DISPLAY

C     Displays the contents of the X register

      REAL*8    X,Y,Z,T,LASTX
      INTEGER   I_X,IO_CHAN,TT_TYPE,FIX_NUM
      BYTE      LAST
      CHARACTER MODE*1,STRING*37
      LOGICAL   FLAG,MINUS,PUSH_FLAG,ERROR,RADS,D_OK

      COMMON / STACK  / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK
      COMMON / DISP   / MODE,STRING,ERROR
      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

1000  IF     ( MODE .EQ. 'I' ) THEN
         IF ( DABS( X ) .GE. 2147483647. ) GO TO 1200
         ENCODE ( 37,10,STRING,ERR=1200 ) JIDNNT( X )
      ELSEIF ( MODE.EQ.'B' .OR. MODE.EQ.'O' .OR. MODE.EQ.'H' ) THEN
         IF ( DABS( X ) .GE. 2147483647. ) GO TO 1200
         I_X = JIDNNT( X )
         IF ( I_X .LT. 0 ) THEN
            MINUS = .TRUE.
            I_X = -I_X
         ELSE
            MINUS = .FALSE.
         END IF
         IF ( MODE .EQ. 'B' ) THEN
            FLAG = .FALSE.
            DO I = 30, 0, -1
               IF ( I_X .GE. 2**I ) THEN
                  FLAG = .TRUE.
                  STRING(37-I:37-I) = '1'
                  I_X = I_X - 2**I
               ELSE
                  IF ( FLAG ) THEN
                     STRING(37-I:37-I) = '0'
                  ELSE
                     STRING(37-I:37-I) = ' '
                  END IF
               END IF
            END DO
            STRING(1:6) = ' '
            IF ( STRING(37:37) .EQ. ' ' ) STRING(37:37) = '0'
         ELSEIF ( MODE .EQ. 'O' ) THEN
            ENCODE ( 37,20,STRING,ERR=1200 ) I_X
         ELSEIF ( MODE .EQ. 'H' ) THEN
            ENCODE ( 37,30,STRING,ERR=1200 ) I_X
         END IF
         IF ( MINUS ) THEN
            DO I = 2, 37
               IF ( STRING(I:I) .NE. ' ' ) GO TO 1100
            END DO
1100        STRING(I-1:I-1) = '-'
         END IF
      ELSEIF ( MODE .EQ. 'E' ) THEN
         ENCODE ( 37,40,STRING,ERR=1200 ) X
         STRING(34:34) = ' '
         IF ( STRING(35:35) .EQ. '+' ) STRING(35:35) = ' '
      ELSEIF ( MODE .EQ. 'F' ) THEN
         ENCODE ( 37,50,STRING,ERR=1200 ) X
      END IF

      CALL OUT_CHAR ( 6,40,37,STRING )
      CALL MOVE_TO  ( 24,1 )

      D_OK = .FALSE.
      RETURN

C     Encoding error

1200  CALL ERR_HAND ( -5 )
      X = 0.

      GO TO 1000

10    FORMAT ( I37 )
20    FORMAT ( O37 )
30    FORMAT ( Z37 )
40    FORMAT ( E37.<FIX_NUM> )
50    FORMAT ( F37.<FIX_NUM> )

      END

      SUBROUTINE DIVIDE

C     Divides Y by X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

C     Load the X register if necessary

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = Y / X
      Y = Z
      Z = T
      T = 0.

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE DRAW_CALC

C     Draws the calculator

      PARAMETER DT$_VT100 = '00000060'X
      PARAMETER DT$_VT52  = '00000040'X

      INTEGER IO_CHAN,TT_TYPE,FIX_NUM
      BYTE    G_ON(3),G_OFF(3),R_ON(4),R_OFF(4)

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

      DATA G_ON  / 27,'(','0' /
      DATA G_OFF / 27,'(','B' /
      DATA R_ON  / 27,'[','7','m' /
      DATA R_OFF / 27,'[','0','m' /

      CALL CLEAR_SCREEN

      IF ( TT_TYPE .EQ. DT$_VT100 ) THEN

         CALL OUT_BYTE ( 3,G_ON )
         CALL OUT_CHAR ( 5,38,
     .                 41,'lqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqk' )
         CALL OUT_CHAR ( 6,37,
     .                43,'lu                                       tk' )
         CALL OUT_CHAR ( 7,37,
     .                43,'xmqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqjx' )
         CALL OUT_CHAR ( 8,37,
     .                43,'x                                         x' )
         CALL OUT_CHAR ( 9,37,
     .                43,'xlqqqqqqqqqwqqqqqqqqqwqqqqqqqqqwqqqqqqqqqkx' )
         CALL OUT_CHAR ( 10,37,
     .                43,'xx  BLACK  x         x   LOG   x   LN    xx' )
         CALL OUT_BYTE ( 4,R_ON )
         CALL OUT_CHAR ( 10,49,9,'         ' )
         CALL OUT_BYTE ( 4,R_OFF )
         CALL OUT_CHAR ( 11,37,
     .                43,'xx         x         x         x         xx' )
         CALL OUT_BYTE ( 4,R_ON )
         CALL OUT_CHAR ( 11,49,9,'  WHITE  ' )
         CALL OUT_CHAR ( 11,59,9,'   10^X  ' )
         CALL OUT_CHAR ( 11,69,9,'   EXP   ' )
         CALL OUT_BYTE ( 4,R_OFF )
         CALL OUT_CHAR ( 12,37,
     .                43,'xtqqqqqqqqqnqqqqqqqqqnqqqqqqqqqnqqqqqqqqqux' )
         CALL OUT_CHAR ( 13,37,
     .                43,'xx   SIN   x   COS   x   TAN   x   RAD   xx' )
         CALL OUT_CHAR ( 14,37,
     .                43,'xx         x         x         x         xx' )
         CALL OUT_BYTE ( 4,R_ON )
         CALL OUT_CHAR ( 14,39,9,'   ASIN  ' )
         CALL OUT_CHAR ( 14,49,9,'   ACOS  ' )
         CALL OUT_CHAR ( 14,59,9,'   ATAN  ' )
         CALL OUT_CHAR ( 14,69,9,'   DEG   ' )
         CALL OUT_BYTE ( 4,R_OFF )
         CALL OUT_CHAR ( 15,37,
     .                43,'xtqqqqqqqqqnqqqqqqqqqnqqqqqqqqqnqqqqqqqqqux' )
         CALL OUT_CHAR ( 16,37,
     .                43,'xx   SQRT  x   1/X   x   +/-   x   INT   xx' )
         CALL OUT_CHAR ( 17,37,
     .                43,'xx         x         x         x         xx' )
         CALL OUT_BYTE ( 4,R_ON )
         CALL OUT_CHAR ( 17,39,9,'   X^2   ' )
         CALL OUT_CHAR ( 17,49,9,'   Y^X   ' )
         CALL OUT_BYTE ( 3,G_OFF )
         CALL OUT_CHAR ( 17,59,9,'   |X|   ' )
         CALL OUT_BYTE ( 3,G_ON )
         CALL OUT_CHAR ( 17,69,9,'   FRAC  ' )
         CALL OUT_BYTE ( 4,R_OFF )
         CALL OUT_CHAR ( 18,37,
     .                43,'xtqqqqqqqqqnqqqqqqqqqnqqqqqqqqqnqqqqqqqqqux' )
         CALL OUT_CHAR ( 19,37,
     .                43,'xx   RDN   x   FIX   x  LASTX  x         xx' )
         CALL OUT_CHAR ( 20,37,
     .                43,'xx         x         x         x         xx' )
         CALL OUT_BYTE ( 4,R_ON )
         CALL OUT_CHAR ( 20,39,9,'   RUP   ' )
         CALL OUT_CHAR ( 20,49,9,'   X<>Y  ' )
         CALL OUT_CHAR ( 20,59,9,'  RESET  ' )
         CALL OUT_BYTE ( 4,R_OFF )
         CALL OUT_CHAR ( 20,72,4,'HELP' )
         CALL OUT_CHAR ( 21,37,
     .                43,'xtqqqqqqqqqvqqqqqqqqqnqqqqqqqqqu         xx' )
         CALL OUT_CHAR ( 22,37,
     .                43,'xx       CL X        x    {    x         xx' )
         CALL OUT_BYTE ( 4,R_ON )
         CALL OUT_CHAR ( 22,69,9,'   EXIT  ' )
         CALL OUT_BYTE ( 4,R_OFF )
         CALL OUT_CHAR ( 23,37,
     .                43,'mu                   x         x         tj' )
         CALL OUT_BYTE ( 4,R_ON )
         CALL OUT_CHAR ( 23,39,19,'       CLST        ' )
         CALL OUT_BYTE ( 3,G_OFF )
         CALL OUT_CHAR ( 23,59,9,'    e    ' )
         CALL OUT_BYTE ( 3,G_ON )
         CALL OUT_BYTE ( 4,R_OFF )
         CALL OUT_CHAR ( 24,38,
     .                 41,'mqqqqqqqqqqqqqqqqqqqvqqqqqqqqqvqqqqqqqqqj' )
         CALL OUT_CHAR (  9, 4,32,'lqqqqqk lqqqqqk  lqqqqqk lqqqqqk' )
         CALL OUT_CHAR ( 10, 4,32,'x  +  x x  -  x  x  *  x x  /  x' )
         CALL OUT_CHAR ( 11, 4,32,'mqqqqqj mqqqqqj  mqqqqqj mqqqqqj' )
         CALL OUT_BYTE ( 3,G_OFF )
         CALL OUT_CHAR (  7,16,8,'(arrows)' )
         CALL OUT_CHAR (  8, 6,2,'up')
         CALL OUT_CHAR (  8,13,4,'down')
         CALL OUT_CHAR (  8,23,3,'<--')
         CALL OUT_CHAR (  8,31,3,'-->')
         CALL OUT_CHAR ( 13, 5,14,'Integer modes:' )
         CALL OUT_CHAR ( 15, 7,17,'Ctrl-I  (Decimal)' )
         CALL OUT_CHAR ( 16, 7,14,'Ctrl-B  Binary' )
         CALL OUT_CHAR ( 17, 7,13,'Ctrl-O  Octal' )
         CALL OUT_CHAR ( 18, 7,19,'Ctrl-H  Hexadecimal' )
         CALL OUT_CHAR ( 20, 5,11,'Real modes:' )
         CALL OUT_CHAR ( 22, 7,22,'Ctrl-F  Floating point' )
         CALL OUT_CHAR ( 23, 7,19,'Ctrl-E  Exponential' )
         CALL MOVE_TO  ( 24,1 )

      ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN

         CALL OUT_CHAR ( 5,38,
     .                 41,'+---------------------------------------+' )
         CALL OUT_CHAR ( 6,38,
     .                 41,'|                                       |' )
         CALL OUT_CHAR ( 7,38,
     .                 41,'+---------------------------------------+' )
         CALL OUT_CHAR ( 9,38,
     .                 41,'+---------+---------+---------+---------+' )
         CALL OUT_CHAR ( 10,38,
     .                 41,'|  UPPER  |         |   LOG   |   LN    |' )
         CALL OUT_CHAR ( 11,38,
     .                 41,'|         |  LOWER  |   10^X  |   EXP   |' )
         CALL OUT_CHAR ( 12,38,
     .                 41,'+---------+---------+---------+---------+' )
         CALL OUT_CHAR ( 13,38,
     .                 41,'|   SIN   |   COS   |   TAN   |   RAD   |' )
         CALL OUT_CHAR ( 14,38,
     .                 41,'|   ASIN  |   ACOS  |   ATAN  |   DEG   |' )
         CALL OUT_CHAR ( 15,38,
     .                 41,'+---------+---------+---------+---------+' )
         CALL OUT_CHAR ( 16,38,
     .                 41,'|   SQRT  |   1/X   |   +/-   |   INT   |' )
         CALL OUT_CHAR ( 17,38,
     .                 41,'|   X^2   |   Y^X   |   |X|   |   FRAC  |' )
         CALL OUT_CHAR ( 18,38,
     .                 41,'+---------+---------+---------+---------+' )
         CALL OUT_CHAR ( 19,38,
     .                 41,'|   RDN   |   FIX   |  LASTX  |         |' )
         CALL OUT_CHAR ( 20,38,
     .                 41,'|   RUP   |   X<>Y  |  RESET  |   HELP  |' )
         CALL OUT_CHAR ( 21,38,
     .                 41,'+---------+---------+---------+         |' )
         CALL OUT_CHAR ( 22,38,
     .                 41,'|       CL X        |    PI   |   EXIT  |' )
         CALL OUT_CHAR ( 23,38,
     .                 41,'|       CLST        |    e    |         |' )
         CALL OUT_CHAR ( 24,38,
     .                 41,'+-------------------+---------+---------+' )
         CALL OUT_CHAR (  9, 4,32,'+-----+ +-----+  +-----+ +-----+' )
         CALL OUT_CHAR ( 10, 4,32,'|  +  | |  -  |  |  *  | |  /  |' )
         CALL OUT_CHAR ( 11, 4,32,'+-----+ +-----+  +-----+ +-----+' )
         CALL OUT_CHAR (  8,16,8,'(arrows)' )
         CALL OUT_CHAR ( 13, 5,14,'Integer modes:' )
         CALL OUT_CHAR ( 15, 7,17,'Ctrl-I  (Decimal)' )
         CALL OUT_CHAR ( 16, 7,14,'Ctrl-B  Binary' )
         CALL OUT_CHAR ( 17, 7,13,'Ctrl-O  Octal' )
         CALL OUT_CHAR ( 18, 7,19,'Ctrl-H  Hexadecimal' )
         CALL OUT_CHAR ( 20, 5,11,'Real modes:' )
         CALL OUT_CHAR ( 22, 7,22,'Ctrl-F  Floating point' )
         CALL OUT_CHAR ( 23, 7,19,'Ctrl-E  Exponential' )
         CALL MOVE_TO  ( 24,1 )

      END IF

      RETURN
      END

      SUBROUTINE DRAW_HELP ( FLAG )

C     Draws the bottom part of the help display

      PARAMETER DT$_VT100 = '00000060'X
      PARAMETER DT$_VT52  = '00000040'X

      INTEGER IO_CHAN,TT_TYPE,FIX_NUM
      BYTE    G_ON(3),G_OFF(3)
      LOGICAL FLAG

      DATA G_ON  / 27,'(','0' /
      DATA G_OFF / 27,'(','B' /

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

      IF     ( TT_TYPE .EQ. DT$_VT100 ) THEN
         CALL OUT_BYTE ( 3,G_ON )
         CALL OUT_CHAR ( 20, 1,34,'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq' )
         CALL OUT_CHAR ( 20,35,34,'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq' )
         CALL OUT_CHAR ( 20,69,11,'qqqqqqqqqqq' )
         CALL OUT_BYTE ( 3,G_OFF )
      ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN
         CALL OUT_CHAR ( 20, 1,34,'----------------------------------' )
         CALL OUT_CHAR ( 20,35,34,'----------------------------------' )
         CALL OUT_CHAR ( 20,69,11,'-----------' )
      END IF
      IF ( FLAG ) THEN
         CALL OUT_CHAR ( 21,13,34,'Type A SPACE     to continue the o' )
         CALL OUT_CHAR ( 21,47,10,'utput; or,' )
      ELSE
         CALL OUT_CHAR ( 22,13,4,'Type' )
      END IF
      CALL OUT_CHAR ( 22,18,37,'ANOTHER KEY for help on that key; or,' )
      CALL OUT_CHAR ( 23,18,29,'A CTRL-Z    to return to CALC' )
      CALL MOVE_TO  ( 24,1 )

      RETURN
      END

      SUBROUTINE E

C     Puts E in the X register and in LASTX

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      CALL PUSH_STACK
      X     = 2.71828182845904523536
      LASTX = X

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ENTER

C     Enters the display into the stack

      PARAMETER CARR_RETURN = '0000000D'X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      CALL PUSH_STACK
      X = Y

      PUSH_FLAG = .FALSE.
      LAST = CARR_RETURN

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ERR_HAND ( CODE )

C     CALC's error handler

      PARAMETER CTRL_G = '00000007'X

      INTEGER   CODE,LENGTH
      CHARACTER MODE*1,STRING*37,LINE*67
      LOGICAL   ERROR,BELL

      COMMON / DISP / MODE,STRING,ERROR

      IF ( CODE .EQ. 0 ) THEN
         LINE  = ' '
         BELL  = .FALSE.
         ERROR = .FALSE.
      ELSE
         ERROR = .TRUE.
         IF     ( CODE .EQ. -1 ) THEN
            LINE = 'Enter a hexadecimal digit between 1 and F'
            BELL = .FALSE.
         ELSEIF ( CODE .EQ. -2 ) THEN
            LINE = 'Type a key for help on that key '
            BELL = .FALSE.
         ELSEIF ( CODE .EQ. -3 ) THEN
            LINE = 'Unrecognized input'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -4 ) THEN
            LINE = 'Delete not allowed now'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -5 ) THEN
            LINE = 'Display overflow'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -6 ) THEN
            LINE = 'Invalid digit for this mode'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -7 ) THEN
            LINE = 'Decimal point already entered'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -8 ) THEN
            LINE = 'Exponent limited to 2 digits'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -9 ) THEN
            LINE = 'Exponent delimiter already entered'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -10 ) THEN
            LINE = 'Numeric digit must precede E'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -11 ) THEN
            LINE = 'Decimal point not allowed in exponent'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -12 ) THEN
            LINE = 'Bad FIX precision parameter'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -13 ) THEN
            LINE = 'Internal overflow'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -14 ) THEN
            LINE = 'Arithmetic error'
            BELL = .TRUE.
         ELSEIF ( CODE .EQ. -15 ) THEN
            LINE = 'Type ? for general instructions'
            BELL = .FALSE.
         ELSE
            CALL SYS$GETMSG ( %VAL(CODE),LENGTH,LINE,%VAL(1), )
            LINE(LENGTH+1:67) = ' '
            BELL = .TRUE.
         END IF
         CALL STR$TRIM ( LINE,LINE,LENGTH )
      END IF

      IF ( BELL ) CALL OUT_BYTE ( 1,CTRL_G )
      CALL OUT_CHAR ( 4,39,LENGTH,LINE )
      CALL MOVE_TO  ( 24,1 )

      RETURN
      END

      SUBROUTINE EXCHANGE

C     Exchanges the X and Y registers

      REAL*8  X,Y,Z,T,Q,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      Q = X
      X = Y
      Y = Q

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE EXPONENT

C     Calculates Y**X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( X .LT. 0. ) THEN
         X = 1. / (Y**(-X))
      ELSE
         X = Y**X
      END IF
      Y = Z
      Z = T
      T = 0.

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE FIX ( NEW_NUM )

C     Changes the number of decimal digits in 'E' and 'F' modes

      CHARACTER NEW_NUM*1
      INTEGER   FIX_NUM,IO_CHAN,TT_TYPE,TEMP
      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      LOGICAL   PUSH_FLAG,RADS,D_OK

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM
      COMMON / STACK  / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      DECODE ( 1,10,NEW_NUM,ERR=1000 ) TEMP
10    FORMAT ( Z1 )

      IF ( TEMP.GT.0 .AND. TEMP.LE.15 ) THEN
         CALL ERR_HAND ( 0 )
         FIX_NUM = TEMP
      ELSE
1000     CALL ERR_HAND ( 0 )
         CALL ERR_HAND ( -12 )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE FRACTION

C     Strips off the integer part of X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = X - DFLOTJ( JIDINT(X) )

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE GET_INPUT ( INPUT )

C     Asks for and analyzes a character from the keyboard

      PARAMETER IO$_TTYREADALL = '0000003A'X
      PARAMETER IO$M_NOECHO    = '00000040'X
      PARAMETER ESCAPE         = '0000001B'X
      PARAMETER CTRL_C         = '00000003'X
      PARAMETER CTRL_Y         = '00000019'X
      PARAMETER DT$_VT100      = '00000060'X
      PARAMETER DT$_VT52       = '00000040'X

      INTEGER   IO_CHAN,TT_TYPE,FIX_NUM,SEQ_POS
      BYTE      READ_STAT(8)
      CHARACTER INPUT*1
      LOGICAL   ERR_CHECK

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM
      COMMON / ERROR  / ERR_CHECK

      ERR_CHECK = .FALSE.
      SEQ_POS   = 0

1000  CONTINUE

         INPUT = ' '
         CALL SYS$QIOW ( %VAL(0),
     .                   %VAL(IO_CHAN),
     .                   %VAL(IO$_TTYREADALL+
     .                        IO$M_NOECHO),
     .                    READ_STAT,,,
     .                   %REF(INPUT),
     .                   %VAL(1),,,, )

         IF ( READ_STAT(5) .EQ. CTRL_C ) STOP '^C'
         IF ( READ_STAT(5) .EQ. CTRL_Y ) STOP '^Y'

         CALL STR$UPCASE ( INPUT,INPUT )

         IF ( SEQ_POS .EQ. 0 ) THEN
            IF ( READ_STAT(5) .EQ. ESCAPE ) THEN
               SEQ_POS = 1
            ELSE
               IF ( READ_STAT(5) .NE. 0 ) THEN
                  INPUT = CHAR( READ_STAT(5) )
               ELSE
                  IF ( INPUT.EQ.'P' .OR. INPUT.EQ.'Q' .OR.
     .                 INPUT.EQ.'R' .OR. INPUT.EQ.'S'      ) INPUT = ' '
               END IF
               RETURN
            END IF
         ELSEIF ( SEQ_POS .EQ. 1 ) THEN
            IF     ( TT_TYPE .EQ. DT$_VT100 ) THEN
               IF ( INPUT .EQ. 'O' ) THEN
                  SEQ_POS = 2
               ELSEIF ( INPUT .EQ. '[' ) THEN
                  SEQ_POS = 3
               ELSE
                  INPUT = ' '
                  RETURN
               END IF
            ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN
               IF ( INPUT .EQ. 'A' ) THEN
                  INPUT = '+'
               ELSEIF ( INPUT .EQ. 'B' ) THEN
                  INPUT = '-'
               ELSEIF ( INPUT .EQ. 'D' ) THEN
                  INPUT = '*'
               ELSEIF ( INPUT .EQ. 'C' ) THEN
                  INPUT = '/'
               ELSE
                  IF ( INPUT.LT.'P' .AND. INPUT.GT.'R' ) INPUT = ' '
               END IF
               RETURN
            END IF
         ELSEIF ( SEQ_POS .EQ. 2 ) THEN
            IF ( INPUT.LT.'P' .AND. INPUT.GT.'S' ) INPUT = ' '
            RETURN
         ELSE
            IF ( INPUT .EQ. 'A' ) THEN
               INPUT = '+'
            ELSEIF ( INPUT .EQ. 'B' ) THEN
               INPUT = '-'
            ELSEIF ( INPUT .EQ. 'D' ) THEN
               INPUT = '*'
            ELSEIF ( INPUT .EQ. 'C' ) THEN
               INPUT = '/'
            ELSE
               INPUT = ' '
            END IF
            RETURN
         END IF

      GO TO 1000

      END

      INTEGER FUNCTION HANDLER ( SIGARGS,MECHARGS )

C     Error condition handler

      EXTERNAL PATCH_FAULT

      PARAMETER SS$_CONTINUE = '00000001'X
      PARAMETER SS$_RESIGNAL = '00000918'X
      PARAMETER SS$_FLTDIV_F = '000004BC'X
      PARAMETER SS$_FLTOVF_F = '000004B4'X
      PARAMETER SS$_FLTUND_F = '000004C4'X

      INTEGER SIGARGS(1:*),MECHARGS(1:*)
      LOGICAL ERR_CHECK

      COMMON / ERROR / ERR_CHECK

      ERR_CHECK = .NOT.ERR_CHECK
      IF ( .NOT.ERR_CHECK ) THEN

C        If HANDLER has been called twice in a row, the condition must
C        be unrecoverable

         HANDLER = SS$_RESIGNAL

      ELSE

C        Otherwise, attempt to recover

         IF ( SIGARGS(2) .EQ. SS$_FLTOVF_F ) THEN
            CALL ERR_HAND ( -13 )
         ELSE
            CALL ERR_HAND ( -14 )
         END IF

         IF ( SIGARGS(2).EQ.SS$_FLTDIV_F .OR.
     .        SIGARGS(2).EQ.SS$_FLTOVF_F .OR.
     .        SIGARGS(2).EQ.SS$_FLTUND_F      ) THEN

            HANDLER = LIB$DECODE_FAULT ( SIGARGS,
     .                                   MECHARGS,
     .                                   %DESCR(PATCH_FAULT),, )

         ELSE

            MECHARGS(3) = '00000000'X
            MECHARGS(4) = '00000000'X
            HANDLER     = SS$_CONTINUE

         END IF

      END IF

      RETURN
      END

      SUBROUTINE HELP ( KEY )

C     Functions as an online help facility

      PARAMETER DT$_VT100     = '00000060'X
      PARAMETER DT$_VT52      = '00000040'X
      PARAMETER CARR_RETURN   = '0000000D'X
      PARAMETER LBR$C_READ    = '00000001'X
      PARAMETER LBR$C_TYP_TXT = '00000004'X
      PARAMETER LBR$_NORMAL   = '00268001'X
      PARAMETER SS$_NORMAL    = '00000001'X
      PARAMETER RMS$_EOF      = '0001827A'X
      PARAMETER DELETE        = '0000007F'X
      PARAMETER CTRL_B        = '00000002'X
      PARAMETER CTRL_E        = '00000005'X
      PARAMETER CTRL_F        = '00000006'X
      PARAMETER CTRL_H        = '00000008'X
      PARAMETER CTRL_I        = '00000009'X
      PARAMETER CTRL_O        = '0000000F'X
      PARAMETER CTRL_Z        = '0000001A'X

      CHARACTER KEY*1,LINE*67,LIBKEY*6
      INTEGER   IO_CHAN,TT_TYPE,FIX_NUM,INDEX,STATUS,LBR$OPEN,RFA(2),
     .          LBR$LOOKUP_KEY,LBR$GET_RECORD,O_STAT,STR$POSITION
      LOGICAL   MORE

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

C     Open CALC's help library

      CALL LBR$INI_CONTROL ( INDEX,LBR$C_READ,LBR$C_TYP_TXT, )
      O_STAT = LBR$OPEN ( INDEX,'CALC$HELPFILE',,,,, )

C     Help loop

1000  CONTINUE

         IF     ( KEY .EQ. CHAR( CARR_RETURN ) ) THEN
            LIBKEY = 'CR'
         ELSEIF ( KEY .EQ. CHAR( DELETE ) ) THEN
            LIBKEY = 'DEL'
         ELSEIF ( KEY .EQ. CHAR( CTRL_B ) ) THEN
            LIBKEY = 'CTRL_B'
         ELSEIF ( KEY .EQ. CHAR( CTRL_E ) ) THEN
            LIBKEY = 'CTRL_E'
         ELSEIF ( KEY .EQ. CHAR( CTRL_F ) ) THEN
            LIBKEY = 'CTRL_F'
         ELSEIF ( KEY .EQ. CHAR( CTRL_H ) ) THEN
            IF ( TT_TYPE .EQ. DT$_VT100 ) THEN
               LIBKEY = 'BS100'
            ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN
               LIBKEY = 'BS52'
            END IF
         ELSEIF ( KEY .EQ. CHAR( CTRL_I ) ) THEN
            LIBKEY = 'CTRL_I'
         ELSEIF ( KEY .EQ. CHAR( CTRL_O ) ) THEN
            LIBKEY = 'CTRL_O'
         ELSEIF ( KEY .EQ. ',' ) THEN
            LIBKEY = 'COMMA'
         ELSEIF ( KEY .EQ. '+' ) THEN
            LIBKEY = 'PLUS'
         ELSEIF ( KEY .EQ. '-' ) THEN
            LIBKEY = 'MINUS'
         ELSEIF ( KEY .EQ. '*' ) THEN
            LIBKEY = 'STAR'
         ELSEIF ( KEY .EQ. '/' ) THEN
            LIBKEY = 'SLASH'
         ELSE
            LIBKEY = KEY
         END IF

         STATUS = LBR$LOOKUP_KEY ( INDEX,LIBKEY,RFA )
         IF ( STATUS .EQ. SS$_NORMAL ) THEN

1100        CALL CLEAR_SCREEN
            MORE = .TRUE.
            DO I = 1, 18
               LINE = ' '
               STATUS = LBR$GET_RECORD ( INDEX,LINE, )
               IF ( STATUS .EQ. RMS$_EOF ) THEN
                  MORE = .FALSE.
                  GO TO 1400
               ELSE
                  IF ( TT_TYPE .EQ. DT$_VT52 ) THEN
1200                 CONTINUE
                        J = STR$POSITION( LINE,'BLACK' )
                        IF ( J .NE. 0 ) THEN
                           LINE(J:J+4) = 'UPPER'
                        ELSE
                           J = STR$POSITION( LINE,'WHITE' )
                           IF ( J .NE. 0 ) THEN
                              LINE(J:J+4) = 'LOWER'
                           ELSE
                              GO TO 1300
                           END IF
                        END IF
                     GO TO 1200
                  END IF
1300              CALL STR$TRIM ( LINE,LINE,J )
                  CALL OUT_CHAR ( I,13,J,LINE )
               END IF
            END DO

         ELSE

            CALL CLEAR_SCREEN
            MORE = .FALSE.
            IF ( O_STAT .NE. LBR$_NORMAL ) THEN
               CALL OUT_CHAR ( 4,13,25,'Unable to open help file:' )
               CALL ERR_HAND ( O_STAT )
            ELSE
               CALL OUT_CHAR ( 4,13,29,'That key does nothing; typing' )
               CALL OUT_CHAR ( 4,42,28,' it will result in an error' )
            END IF

         END IF

1400     CALL DRAW_HELP ( MORE )
         CALL GET_INPUT ( KEY )
         IF ( MORE .AND. KEY.EQ.' ' ) THEN
            GO TO 1100
         ELSEIF ( KEY .EQ. CHAR( CTRL_Z ) ) THEN
            CALL LBR$CLOSE ( INDEX )
            CALL RESET
            RETURN
         END IF

      GO TO 1000

      END

      SUBROUTINE INITIALIZE

C     Initializes the calculator

      PARAMETER DVI$_DEVTYPE = '00060004'X
      PARAMETER DT$_VT100    = '00000060'X
      PARAMETER DT$_VT52     = '00000040'X

      INTEGER   IO_CHAN,DEV_DATA(4),TT_TYPE,FIX_NUM
      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST,RESET_100(16),RESET_52(8)
      LOGICAL   PUSH_FLAG,RADS,D_OK

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM
      COMMON / STACK  / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      DATA RESET_100 /  27,'[','0','m', 27,'[','?','3','l', 27,'[','?',
     .                 '5','l', 27,'>' /
      DATA RESET_52  /  27,'G', 27,'H', 27,'J', 27,'>' /

      DEV_DATA(1) = DVI$_DEVTYPE
      DEV_DATA(2) = %LOC(TT_TYPE)
      DEV_DATA(3) = 0
      DEV_DATA(4) = 0

C     Establish a channel to the terminal

      CALL SYS$ASSIGN ( 'SYS$COMMAND',IO_CHAN,, )

C     Check for terminal type

      CALL SYS$GETDVI ( %VAL(0),%VAL(IO_CHAN),,DEV_DATA,,,, )
      CALL SYS$WAITFR ( %VAL(0) )

      IF ( TT_TYPE .EQ. DT$_VT100 ) THEN
         CALL OUT_BYTE ( 16,RESET_100 )
      ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN
         CALL OUT_BYTE ( 8,RESET_52 )
      ELSE
         STOP '  Terminal must be VT100 or VT52'
      END IF

C     Write out the display

      CALL DRAW_CALC

C     Set the defaults and clear the stack

      FIX_NUM = 4
      LAST    = 0
      D_OK    = .FALSE.

      CALL CHANGE_TRIG ( 'RAD',0 )
      CALL CHANGE_MODE ( 'F',0 )
      CALL CLEAR_STACK
      CALL ERR_HAND ( -15 )

      RETURN
      END

      SUBROUTINE INTEGER

C     Integerizes the X register

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = DFLOTJ( JIDINT(X) )

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE INVERT

C     Calculates 1 / X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = 1. / X

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE LAST_X

C     Puts the last-entered number in the X register

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      CALL PUSH_STACK
      X = LASTX

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE LOAD_X_REG

C     Loads the X register

      PARAMETER CARR_RETURN = '0000000D'X

      CHARACTER STRING*37,MODE*1
      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      INTEGER   I_X,STR$POSITION
      LOGICAL   PUSH_FLAG,ERROR,MINUS,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK
      COMMON / DISP  / MODE,STRING,ERROR

      IF ( LAST .EQ. CARR_RETURN ) RETURN

      IF ( MODE .EQ. 'I' ) THEN
         DECODE ( 37,10,STRING,ERR=1100 ) I_X
         X = DFLOTJ( I_X )
      ELSEIF ( MODE.EQ.'B' .OR. MODE.EQ.'O' .OR. MODE.EQ.'H' ) THEN
         MINUS = .FALSE.
         DO I = 1, 37
            IF ( STRING(I:I) .EQ. '-' ) THEN
               STRING(I:I) = ' '
               MINUS = .TRUE.
               GO TO 1000
            END IF
         END DO
1000     IF ( MODE .EQ. 'B' ) THEN
            I_X = 0
            DO I = 7, 37
               IF ( STRING(I:I) .EQ. '1' ) THEN
                  I_X = I_X + 2**(37-I)
               END IF
            END DO
            X = FLOATJ( I_X )
         ELSEIF ( MODE .EQ. 'O' ) THEN
            DECODE ( 37,20,STRING,ERR=1100 ) I_X
            X = FLOATJ( I_X )
         ELSEIF ( MODE .EQ. 'H' ) THEN
            DECODE ( 37,30,STRING,ERR=1100 ) I_X
            X = FLOATJ( I_X )
         END IF
         IF ( MINUS ) X = -X
      ELSEIF ( MODE .EQ. 'F' ) THEN
         IF ( STR$POSITION( STRING,'.' ) .EQ. 0 ) THEN
            STRING = STRING(2:37)//'.'
         END IF
         DECODE ( 37,40,STRING,ERR=1100 ) X
      ELSEIF ( MODE .EQ. 'E' ) THEN
         IF ( STRING(33:33).NE.' ' .AND. STRING(34:34).EQ.' ' ) THEN
            STRING(34:34) = 'D'
            IF ( STRING(35:35) .EQ. ' ' ) STRING(35:35) = '+'
         ELSE
            IF ( STR$POSITION( STRING,'.' ) .EQ. 0 ) THEN
               I = STR$POSITION( STRING,'E' )
               IF ( I .EQ. 0 ) THEN
                  STRING = STRING(2:37)//'.'
               ELSE
                  STRING(1:I-1) = STRING(2:I-1)//'.'
               END IF
            END IF
         END IF
         DECODE ( 37,50,STRING,ERR=1100 ) X
      END IF

      LASTX = X
      RETURN

C     Error in decoding

1100  CALL ERR_HAND ( -5 )
      X = 0.

      RETURN

10    FORMAT ( I37 )
20    FORMAT ( O37 )
30    FORMAT ( Z37 )
40    FORMAT ( F37.16 )
50    FORMAT ( E37.16 )

      END

      SUBROUTINE LOG_10

C     Calculates LOG( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = DLOG10( X )

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE LOG_E

C     Calculates LN( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = DLOG( X )

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE MOVE_TO ( LINE,COLUMN )

C     Moves the cursor to the specified position

      PARAMETER DT$_VT100 = '00000060'X
      PARAMETER DT$_VT52  = '00000040'X

      INTEGER LINE,COLUMN,TT_TYPE,IO_CHAN,FIX_NUM
      BYTE    FORM_1(6),FORM_2(7),FORM_3(7),FORM_4(8),FORM_5(4)

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

      DATA FORM_1 / 27,'[',' ',';',' ','f'         /
      DATA FORM_2 / 27,'[',' ',';',' ',' ','f'     /
      DATA FORM_3 / 27,'[',' ',' ',';',' ','f'     /
      DATA FORM_4 / 27,'[',' ',' ',';',' ',' ','f' /
      DATA FORM_5 / 27,'Y',' ',' ' /

      IF ( TT_TYPE .EQ. DT$_VT100 ) THEN

         IF ( LINE .LT. 10 ) THEN
            IF ( COLUMN .LT. 10 ) THEN
               ENCODE ( 1,10,FORM_1(3) ) LINE
               ENCODE ( 1,10,FORM_1(5) ) COLUMN
               CALL OUT_BYTE ( 6,FORM_1 )
            ELSE
               ENCODE ( 1,10,FORM_2(3) ) LINE
               ENCODE ( 2,20,FORM_2(5) ) COLUMN
               CALL OUT_BYTE ( 7,FORM_2 )
            END IF
         ELSE
            IF ( COLUMN .LT. 10 ) THEN
               ENCODE ( 2,20,FORM_3(3) ) LINE
               ENCODE ( 1,10,FORM_3(6) ) COLUMN
               CALL OUT_BYTE ( 7,FORM_3 )
            ELSE
               ENCODE ( 2,20,FORM_4(3) ) LINE
               ENCODE ( 2,20,FORM_4(6) ) COLUMN
               CALL OUT_BYTE ( 8,FORM_4 )
            END IF
         END IF

      ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN

         ENCODE ( 1,30,FORM_5(3) )   LINE+31
         ENCODE ( 1,30,FORM_5(4) ) COLUMN+31
         CALL OUT_BYTE ( 4,FORM_5 )

      END IF
      RETURN

10    FORMAT ( I1 )
20    FORMAT ( I2 )
30    FORMAT ( A1 )

      END

      SUBROUTINE MULTIPLY

C     Multiplies X by Y

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

C     Load the X register if necessary

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = X * Y
      Y = Z
      Z = T
      T = 0.

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE OUT_BYTE ( LENGTH,STRING )

C     Writes out a byte string of given length

      PARAMETER IO$_WRITEVBLK = '00000030'X
      PARAMETER IO$M_NOFORMAT = '00000100'X
      PARAMETER IO$M_CANCTRLO = '00000040'X

      BYTE    STRING(100)
      INTEGER IO_CHAN,LENGTH,TT_TYPE,FIX_NUM

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

      CALL SYS$QIOW ( %VAL(0),
     .                %VAL(IO_CHAN),
     .                %VAL(IO$_WRITEVBLK+
     .                     IO$M_CANCTRL0+
     .                     IO$M_NOFORMAT),,,,
     .                 STRING,
     .                %VAL(LENGTH),,,, )

      RETURN
      END

      SUBROUTINE OUT_CHAR ( X,Y,LENGTH,STRING )

C     Writes out a character string of given length at (X,Y)

      PARAMETER IO$_WRITEVBLK = '00000030'X
      PARAMETER IO$M_NOFORMAT = '00000100'X
      PARAMETER IO$M_CANCTRLO = '00000040'X

      CHARACTER STRING*100
      INTEGER   IO_CHAN,LENGTH,TT_TYPE,FIX_NUM,X,Y

      COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM

      CALL MOVE_TO ( X,Y )

      CALL SYS$QIOW ( %VAL(0),
     .                %VAL(IO_CHAN),
     .                %VAL(IO$_WRITEVBLK+
     .                     IO$M_CANCTRLO+
     .                     IO$M_NOFORMAT),,,,
     .                %REF(STRING),
     .                %VAL(LENGTH),,,, )

      RETURN
      END

      INTEGER FUNCTION PATCH_FAULT ( OPCODE,PC,PSL,REGISTERS,OP_COUNT,
     .                               OP_TYPES,READ_OPS,WRITE_OPS,
     .                               SIGARGS,SIGNAL,CONTEXT,USERARG )

C     Dummy routine needed by LIB$DECODE_FAULT

      PARAMETER SS$_CONTINUE = '00000001'X

      INTEGER OPCODE,PC,PSL,REGISTERS(15),OP_COUNT,OP_TYPES(1:*),
     .        READ_OPS(1:*),WRITE_OPS(1:*),SIGARGS(1:*),SIGNAL,
     .        CONTEXT,USERARG

      PATCH_FAULT = SS$_CONTINUE

      RETURN
      END

      SUBROUTINE PI

C     Puts PI in the X register and in LASTX

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      CALL PUSH_STACK
      X     = 3.1415926535897932384626433
      LASTX = X

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE POWER_10

C     Calculates 10**X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( X .LT. 0. ) THEN
         X = 1. / 10.**(-X)
      ELSE
         X = 10.**X
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE POWER_E

C     Calculates E**X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( X .LT. 0. ) THEN
         X = 1. / DEXP( -X )
      ELSE
         X = DEXP( X )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE PUSH_STACK

C     Pushes the stack up

      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      LOGICAL   PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      T = Z
      Z = Y
      Y = X
      X = 0.

      RETURN
      END

      SUBROUTINE RESET

C     Resets the display

      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      CHARACTER MODE*1,STRING*37
      LOGICAL   PUSH_FLAG,RADS,ERROR,D_OK

      COMMON / DISP  / MODE,STRING,ERROR
      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

C     Write out the display

      CALL DRAW_CALC

      IF ( RADS ) THEN
         CALL CHANGE_TRIG ( 'RAD',0 )
      ELSE
         CALL CHANGE_TRIG ( 'DEG',0 )
      END IF
      CALL CHANGE_MODE ( MODE,0 )

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ROLL_DOWN

C     Rolls the stack down

      REAL*8  X,Y,Z,T,Q,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      Q = X
      X = Y
      Y = Z
      Z = T
      T = Q

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE ROLL_UP

C     Rolls the stack up

      REAL*8  X,Y,Z,T,Q,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      Q = T
      T = Z
      Z = Y
      Y = X
      X = Q

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE SINE

C     Calculates SIN( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( RADS ) THEN
         X = DSIN( X )
      ELSE
         X = DSIND( X )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE SQUARE_ROOT

C     Calculates the square root of X

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = DSQRT( X )

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE SQUARE_X

C     Calculates X**2

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      X = X**2.

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END

      SUBROUTINE SUBTRACT

C     Subtracts X from Y

      REAL*8    X,Y,Z,T,LASTX
      BYTE      LAST
      CHARACTER MODE*1,STRING*37
      LOGICAL   PUSH_FLAG,ERROR,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK
      COMMON / DISP  / MODE,STRING,ERROR

C     Load the X register if necessary

      LAST = 0
      IF ( .NOT.PUSH_FLAG ) THEN
         IF ( MODE .EQ. 'E' ) THEN
            IF ( STRING(37:37) .EQ. 'E' ) THEN
               CALL ADD_DIGIT ( '-' )
               RETURN
            ELSE
               CALL LOAD_X_REG
            END IF
         ELSE
            CALL LOAD_X_REG
         END IF
      END IF

      X = Y - X
      Y = Z
      Z = T
      T = 0.

      PUSH_FLAG = .TRUE.
      CALL DISPLAY

      RETURN
      END

      SUBROUTINE TANGENT

C     Calculates TAN( X )

      REAL*8  X,Y,Z,T,LASTX
      BYTE    LAST
      LOGICAL PUSH_FLAG,RADS,D_OK

      COMMON / STACK / X,Y,Z,T,PUSH_FLAG,LAST,RADS,LASTX,D_OK

      IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG

      IF ( RADS ) THEN
         X = DTAN( X )
      ELSE
         X = DTAND( X )
      END IF

      PUSH_FLAG = .TRUE.
      LAST = 0

      CALL DISPLAY

      RETURN
      END
