PROGRAM CALC2 C Calculator emulator (2-4-84 Greg Janee) C January, 1987 David Deley C June, 1988 David Deley C July, 1990 David Deley (add vt300 series) C October, 1993 David Deley (convert HANDLER to work on Alpha AXP/OpenVMS) IMPLICIT NONE CHARACTER MODE*1,STRING*37 LOGICAL BLACK,WHITE,ERROR,ERR_CHECK INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER SMG$PUT_CHARS,TERM_CHAR, SMG$READ_KEYSTROKE,KEYBOARD1 INTEGER KEY INTEGER SMG$CREATE_VIRTUAL_KEYBOARD INTEGER ISTATUS LOGICAL VT200 COMMON / DISP / ERROR,MODE,STRING COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 COMMON / ERROR / ERR_CHECK COMMON / STATE / WHITE,BLACK COMMON / KEYBOARD / KEYBOARD1 COMMON / TERM / VT200 CALL INITIALIZE BLACK = .FALSE. WHITE = .FALSE. C+ C Create a virtual keyboard. C- ISTATUS = SMG$CREATE_VIRTUAL_KEYBOARD ( KEYBOARD1) C C --- MAIN LOOP -------------------------------------------------------- C 1000 CONTINUE C+ C Read a key stroke from the virtual keyboard. C- CALL SMG$READ_KEYSTROKE ( KEYBOARD1, KEY ) ERR_CHECK = .FALSE. IF ( ERROR ) CALL ERR_HAND ( 0 ) CALL CASE( KEY ) GOTO 1000 END REAL*8 FUNCTION F_DABS( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DABS = DABS( X ) RETURN END SUBROUTINE ABS_VALUE C Calculates | X | IMPLICIT NONE EXTERNAL F_DABS REAL*8 F_DABS REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_DABS( X ) PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_ADD( X, Y ) IMPLICIT NONE REAL*8 X,Y EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_ADD = X + Y RETURN END SUBROUTINE ADD C Adds the Y register to the X register IMPLICIT NONE EXTERNAL F_ADD REAL*8 F_ADD REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST C Load the X register if necessary IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_ADD( X, Y ) !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 IMPLICIT NONE PARAMETER CARR_RETURN = '0000000D'X REAL*8 X,Y,Z,T,LASTX INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER ISTATUS INTEGER SMG$PUT_CHARS LOGICAL PUSH_FLAG,ERROR,RADS,D_OK BYTE LAST CHARACTER STRING*37,DIGIT*1,MODE*1 COMMON / DISP / ERROR,MODE,STRING COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 IF ( LAST .EQ. CARR_RETURN ) THEN X = 0. STRING = ' ' ISTATUS = SMG$PUT_CHARS( DISPLAY1, STRING, 2, 3) CALL MOVE_TO ( 24,1 ) END IF IF ( PUSH_FLAG ) THEN CALL PUSH_STACK STRING = ' ' ISTATUS = SMG$PUT_CHARS( DISPLAY1, STRING, 2, 3) 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 ISTATUS = SMG$PUT_CHARS( DISPLAY1, STRING, 2, 3) CALL MOVE_TO ( 24,1 ) D_OK = .TRUE. END IF LAST = 0 RETURN END REAL*8 FUNCTION F_DACOS( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DACOS = DACOS( X ) RETURN END REAL*8 FUNCTION F_DACOSD( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DACOSD = DACOSD( X ) RETURN END SUBROUTINE ARC_COSINE C Calculates ARCCOS( X ) IMPLICIT NONE EXTERNAL F_DACOS REAL*8 F_DACOS EXTERNAL F_DACOSD REAL*8 F_DACOSD REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( RADS ) THEN X = F_DACOS( X ) ELSE X = F_DACOSD( X ) END IF PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_DASIN( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DASIN = DASIN( X ) RETURN END REAL*8 FUNCTION F_DASIND( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DASIND = DASIND( X ) RETURN END SUBROUTINE ARC_SINE C Calculates ARCSIN( X ) IMPLICIT NONE EXTERNAL F_DASIN REAL*8 F_DASIN EXTERNAL F_DASIND REAL*8 F_DASIND REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( RADS ) THEN X = F_DASIN( X ) ELSE X = F_DASIND( X ) END IF PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_DATAN( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DATAN = DATAN( X ) RETURN END REAL*8 FUNCTION F_DATAND( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DATAND = DATAND( X ) RETURN END SUBROUTINE ARC_TANGENT C Calculates ARCTAN( X ) IMPLICIT NONE EXTERNAL F_DATAN REAL*8 F_DATAN EXTERNAL F_DATAND REAL*8 F_DATAND REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( RADS ) THEN X = F_DATAN( X ) ELSE X = F_DATAND( X ) END IF PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END SUBROUTINE CASE(KEY) IMPLICIT NONE INCLUDE '($SMGDEF)' C PARAMETER SMG$K_TRM_EXCLAMATION_POINT = '00000021'X ! ! C PARAMETER SMG$K_TRM_LEFT_PAREN = '00000028'X ! ( C PARAMETER SMG$K_TRM_RIGHT_PAREN = '00000029'X ! ) C PARAMETER SMG$K_TRM_PLUS_SIGN = '0000002B'X ! + C PARAMETER SMG$K_TRM_ZERO = '00000030'X ! 0 LOGICAL BLACK,WHITE INTEGER KEY, DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER ISTATUS INTEGER SMG$PUT_CHARS CHARACTER*1 CHARACTER, INPUT COMMON / STATE / WHITE,BLACK COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4, * DISPLAY5,DISPLAY6 IF ( BLACK ) THEN C ****************************************************************** C ****************** IF STATE BLACK ******************************** C ****************************************************************** C -------------- CONTROL CHARACTERS 000 - 031 --------------------- IF ( KEY .LT. SMG$K_TRM_SPACE ) THEN !CONTROL CHARACTERS IF ( KEY .EQ. SMG$K_TRM_CTRLR ) THEN CALL RESET ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLW ) THEN CALL RESET ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLZ ) THEN CALL CLEAR_SCREEN CALL SYS$EXIT (%VAL(1) ) ENDIF C -------------MISCELANEOUS !"#$%&'()*+,-./ ------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_ZERO ) THEN !MISC C --------------- NUMBERS 0-9 -------------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_NINE ) THEN !NUMBERS C ------------- MISCELLANEOUS :;<=>?@ ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_UPPERCASE_A) THEN !MISC C -------------- LETTERS A-Z --------------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_UPPERCASE_Z) THEN !UPPERCAE ALPHABET C ---------------- MISCELANEOUS [\]^_` ----------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_LOWERCASE_A) THEN !MISC C ---------------- lowercase letters a-z --------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_LOWERCASE_Z) THEN !lowercase alphabet C ----------------- MISCELLANEOUS {|}~ del ------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_PF1) THEN !MISC C ------------------ KEYPAD PF1-PF4 -------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_PF4) THEN !PF1-PF4 IF ( KEY .EQ. SMG$K_TRM_PF1 ) THEN BLACK = .TRUE. CALL SMG$PUT_CHARS( DISPLAY4, 'B', 2, 28) CALL MOVE_TO ( 24,1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_PF2 ) THEN WHITE = .TRUE. CALL SMG$PUT_CHARS( DISPLAY4, 'W', 2, 31) CALL MOVE_TO ( 24,1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_PF3 ) THEN CALL LOG_10 ELSEIF ( KEY .EQ. SMG$K_TRM_PF4 ) THEN CALL LOG_E ENDIF C --------------------- KEYPAD 0-9 --------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_KP9) THEN !KP0-KP9 IF ( KEY .EQ. SMG$K_TRM_KP0) THEN CALL CLEAR_X_REG ELSEIF ( KEY .EQ. SMG$K_TRM_KP1) THEN CALL ROLL_DOWN ELSEIF ( KEY .EQ. SMG$K_TRM_KP2) THEN C CALL OUT_CHAR ( 8,71,1,'Q' ) CALL ERR_HAND ( -1 ) CALL GET_INPUT ( INPUT ) CALL FIX ( INPUT ) C CALL OUT_CHAR ( 8,71,1,' ' ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP3) THEN CALL LAST_X ELSEIF ( KEY .EQ. SMG$K_TRM_KP4) THEN CALL SQUARE_ROOT ELSEIF ( KEY .EQ. SMG$K_TRM_KP5) THEN CALL INVERT ELSEIF ( KEY .EQ. SMG$K_TRM_KP6) THEN CALL CHANGE_SIGN ELSEIF ( KEY .EQ. SMG$K_TRM_KP7) THEN CALL SINE ELSEIF ( KEY .EQ. SMG$K_TRM_KP8) THEN CALL COSINE ELSEIF ( KEY .EQ. SMG$K_TRM_KP9) THEN CALL TANGENT END IF C --------------------- MISCELLANEOUS ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_F1) THEN !MISC IF (KEY .EQ. SMG$K_TRM_ENTER ) THEN C CALL OUT_CHAR ( 8,71,1,'Q' ) C CALL ERR_HAND ( -2 ) C CALL GET_INPUT ( INPUT ) C CALL HELP ( INPUT ) ELSEIF ( KEY .EQ. SMG$K_TRM_MINUS ) THEN CALL CHANGE_TRIG ( 'RAD',1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_COMMA ) THEN CALL INTEGER ELSEIF ( KEY .EQ. SMG$K_TRM_PERIOD ) THEN CALL PI ELSEIF ( KEY .EQ. SMG$K_TRM_UP ) THEN CALL ADD ELSEIF ( KEY .EQ. SMG$K_TRM_DOWN ) THEN CALL SUBTRACT ELSEIF ( KEY .EQ. SMG$K_TRM_LEFT ) THEN CALL MULTIPLY ELSEIF ( KEY .EQ. SMG$K_TRM_RIGHT ) THEN CALL DIVIDE ENDIF C -------------- END CASE IF BLACK --------------------------------- ELSE CALL ERR_HAND ( -3 ) END IF BLACK = .FALSE. ISTATUS = SMG$PUT_CHARS( DISPLAY4, ' ', 2, 28) CALL MOVE_TO ( 24,1 ) ELSEIF ( WHITE ) THEN C ****************************************************************** C ****************** IF STATE WHITE ******************************** C ****************************************************************** C -------------- CONTROL CHARACTERS 000 - 031 --------------------- IF ( KEY .LT. SMG$K_TRM_SPACE ) THEN !CONTROL CHARACTERS IF ( KEY .EQ. SMG$K_TRM_CR ) THEN CALL CLEAR_SCREEN CALL SYS$EXIT ( %VAL(1) ) ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLR ) THEN CALL RESET ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLW ) THEN CALL RESET ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLZ ) THEN CALL CLEAR_SCREEN CALL SYS$EXIT (%VAL(1) ) ENDIF C -------------MISCELANEOUS !"#$%&'()*+,-./ ------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_ZERO ) THEN !MISC C --------------- NUMBERS 0-9 -------------------------------------- ELSEIF (KEY .LE. SMG$K_TRM_NINE) THEN !NUMBERS C ------------- MISCELLANEOUS :;<=>?@ ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_UPPERCASE_A) THEN !MISC C -------------- LETTERS A-Z --------------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_UPPERCASE_Z ) THEN !UPPERCAE ALPHABET C ---------------- MISCELANEOUS [\]^_` ----------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_LOWERCASE_A ) THEN !MISC C ---------------- lowercase letters a-z --------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_LOWERCASE_Z) THEN !lowercase alphabet C ----------------- MISCELLANEOUS {|}~ del ------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_PF1 ) THEN !MISC C ------------------ KEYPAD PF1-PF4 -------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_PF4) THEN !PF1-PF4 IF ( KEY .EQ. SMG$K_TRM_PF1 ) THEN BLACK = .TRUE. CALL SMG$PUT_CHARS( DISPLAY4, 'B', 2, 28) CALL MOVE_TO ( 24,1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_PF2 ) THEN WHITE = .TRUE. CALL SMG$PUT_CHARS( DISPLAY4, 'W', 2, 31) CALL MOVE_TO ( 24,1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_PF3 ) THEN CALL POWER_10 ELSEIF ( KEY .EQ. SMG$K_TRM_PF4 ) THEN CALL POWER_E ENDIF C --------------------- KEYPAD 0-9 --------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_KP9 ) THEN !KP0-KP9 IF ( KEY .EQ. SMG$K_TRM_KP0 ) THEN CALL CLEAR_STACK ELSEIF ( KEY .EQ. SMG$K_TRM_KP1 ) THEN CALL ROLL_UP ELSEIF ( KEY .EQ. SMG$K_TRM_KP2 ) THEN CALL EXCHANGE ELSEIF ( KEY .EQ. SMG$K_TRM_KP3 ) THEN CALL RESET ELSEIF ( KEY .EQ. SMG$K_TRM_KP4 ) THEN CALL SQUARE_X ELSEIF ( KEY .EQ. SMG$K_TRM_KP5 ) THEN CALL EXPONENT ELSEIF ( KEY .EQ. SMG$K_TRM_KP6 ) THEN CALL ABS_VALUE ELSEIF ( KEY .EQ. SMG$K_TRM_KP7 ) THEN CALL ARC_SINE ELSEIF ( KEY .EQ. SMG$K_TRM_KP8 ) THEN CALL ARC_COSINE ELSEIF ( KEY .EQ. SMG$K_TRM_KP9 ) THEN CALL ARC_TANGENT END IF C --------------------- MISCELLANEOUS ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_F1 ) THEN !MISC IF ( KEY .EQ. SMG$K_TRM_ENTER ) THEN CALL CLEAR_SCREEN CALL SYS$EXIT ( %VAL(1) ) ELSEIF ( KEY .EQ. SMG$K_TRM_MINUS ) THEN CALL CHANGE_TRIG ( 'DEG',1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_COMMA ) THEN CALL FRACTION ELSEIF ( KEY .EQ. SMG$K_TRM_PERIOD ) THEN CALL E ELSEIF ( KEY .EQ. SMG$K_TRM_UP ) THEN CALL ADD ELSEIF ( KEY .EQ. SMG$K_TRM_DOWN ) THEN CALL SUBTRACT ELSEIF ( KEY .EQ. SMG$K_TRM_LEFT ) THEN CALL MULTIPLY ELSEIF ( KEY .EQ. SMG$K_TRM_RIGHT ) THEN CALL DIVIDE ENDIF C -------------- END CASE ------------------------------------------ ELSE CALL ERR_HAND ( -3 ) END IF WHITE = .FALSE. ISTATUS = SMG$PUT_CHARS( DISPLAY4, ' ', 2, 31) CALL MOVE_TO ( 24,1 ) ELSE C ****************************************************************** C ***********************IF STATE OFF ****************************** C ****************************************************************** C -------------- CONTROL CHARACTERS 000 - 031 --------------------- IF ( KEY .LT. SMG$K_TRM_SPACE ) THEN !CONTROL CHARACTERS IF ( KEY .EQ. SMG$K_TRM_CTRLB ) THEN CALL CHANGE_MODE ('B',1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLE ) THEN CALL CHANGE_MODE ('E',1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLF ) THEN CALL CHANGE_MODE ('F',1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLH ) THEN CALL CHANGE_MODE ('H',1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLI ) THEN CALL CHANGE_MODE ('I',1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_CR ) THEN CALL ENTER ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLR ) THEN CALL RESET ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLW ) THEN CALL RESET ELSEIF ( KEY .EQ. SMG$K_TRM_CTRLZ ) THEN CALL CLEAR_SCREEN CALL SYS$EXIT (%VAL(1) ) ENDIF C -------------MISCELANEOUS !"#$%&'()*+,-./ ------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_ZERO ) THEN !MISC IF ( KEY .EQ. SMG$K_TRM_ASTERISK ) THEN CALL MULTIPLY ELSEIF ( KEY .EQ. SMG$K_TRM_PLUS_SIGN ) THEN CALL ADD ELSEIF ( KEY .EQ. SMG$K_TRM_DASH ) THEN CALL SUBTRACT ELSEIF ( KEY .EQ. SMG$K_TRM_DOT ) THEN CHARACTER = CHAR( KEY ) CALL DIGIT( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_SLASH ) THEN CALL DIVIDE ENDIF C --------------- NUMBERS 0-9 -------------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_NINE ) THEN !NUMBERS CHARACTER = CHAR( KEY ) CALL DIGIT( CHARACTER ) C ------------- MISCELLANEOUS :;<=>?@ ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_UPPERCASE_A ) THEN !MISC C -------------- LETTERS A-Z --------------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_UPPERCASE_Z) THEN !UPPERCAE ALPHABET IF ( KEY .EQ. SMG$K_TRM_UPPERCASE_O) THEN CALL CHANGE_MODE ('O',1 ) ELSE CHARACTER = CHAR( KEY ) CALL DIGIT( CHARACTER ) ENDIF C ---------------- MISCELANEOUS [\]^_` ----------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_LOWERCASE_A ) THEN !MISC C ---------------- lowercase letters a-z --------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_LOWERCASE_Z ) THEN !lowercase alphabet IF ( KEY .EQ. SMG$K_TRM_LOWERCASE_O) THEN CALL CHANGE_MODE ('O',1 ) ELSE CHARACTER = CHAR( KEY ) CALL STR$UPCASE ( CHARACTER, CHARACTER ) CALL DIGIT( CHARACTER) ENDIF C ----------------- MISCELLANEOUS {|}~ del ------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_PF1 ) THEN !MISC IF ( KEY .EQ. SMG$K_TRM_DELETE ) THEN CALL DELETE_DIGIT ENDIF C ------------------ KEYPAD PF1-PF4 -------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_PF4 ) THEN !PF1-PF4 IF ( KEY .EQ. SMG$K_TRM_PF1 ) THEN BLACK = .TRUE. CALL SMG$PUT_CHARS( DISPLAY4, 'B', 2, 28) CALL MOVE_TO ( 24,1 ) ELSEIF ( KEY .EQ. SMG$K_TRM_PF2 ) THEN WHITE = .TRUE. CALL SMG$PUT_CHARS( DISPLAY4, 'W', 2, 31) CALL MOVE_TO ( 24,1 ) ENDIF C --------------------- KEYPAD 0-9 --------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_KP9 ) THEN !KP0-KP9 IF ( KEY .EQ. SMG$K_TRM_KP0 ) THEN CHARACTER = '0' CALL DIGIT( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP1 ) THEN CHARACTER = '1' CALL DIGIT ( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP2 ) THEN CHARACTER = '2' CALL DIGIT ( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP3 ) THEN CHARACTER = '3' CALL DIGIT ( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP4 ) THEN CHARACTER = '4' CALL DIGIT ( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP5 ) THEN CHARACTER = '5' CALL DIGIT (CHARACTER) ELSEIF ( KEY .EQ. SMG$K_TRM_KP6 ) THEN CHARACTER = '6' CALL DIGIT ( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP7 ) THEN CHARACTER = '7' CALL DIGIT ( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP8 ) THEN CHARACTER = '8' CALL DIGIT ( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_KP9 ) THEN CHARACTER = '9' CALL DIGIT ( CHARACTER ) END IF C --------------------- MISCELLANEOUS ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_F1 ) THEN !MISC IF ( KEY .EQ. SMG$K_TRM_ENTER ) THEN CALL ENTER ELSEIF ( KEY .EQ. SMG$K_TRM_PERIOD ) THEN CHARACTER = '.' CALL DIGIT( CHARACTER ) ELSEIF ( KEY .EQ. SMG$K_TRM_UP ) THEN CALL ADD ELSEIF ( KEY .EQ. SMG$K_TRM_DOWN ) THEN CALL SUBTRACT ELSEIF ( KEY .EQ. SMG$K_TRM_LEFT ) THEN CALL MULTIPLY ELSEIF ( KEY .EQ. SMG$K_TRM_RIGHT ) THEN CALL DIVIDE ENDIF C -------------- END CASE ------------------------------------------ ENDIF C ----- END CASES BLACK, WHITE, OFF ----- ENDIF 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 -- NOT AVAILABLE C H Hexadecimal integer C F Floating point (decimal) C E Exponential floating point (decimal) IMPLICIT NONE 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 INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, PASTE1, * DISPLAY6 INTEGER SMG$PUT_CHARS INTEGER ISTATUS COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 COMMON / DISP / ERROR,MODE,STRING COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( NEW_MODE .EQ. 'I' ) THEN ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'Integer mode ', 2, 2) MODE = NEW_MODE ELSEIF ( NEW_MODE .EQ. 'B' ) THEN ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'Binary integer mode ', 2, 2) MODE = NEW_MODE ELSEIF ( NEW_MODE .EQ. 'O' ) THEN ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'Octal integer mode ', 2, 2) MODE = NEW_MODE ELSEIF ( NEW_MODE .EQ. 'H' ) THEN ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'Hexadecimal integer mode', 2, 2) MODE = NEW_MODE ELSEIF ( NEW_MODE .EQ. 'F' ) THEN ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'Floating point mode ', 2, 2) MODE = NEW_MODE ELSEIF ( NEW_MODE .EQ. 'E' ) THEN ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'Exponential mode ', 2, 2) MODE = NEW_MODE END IF CALL MOVE_TO ( 24,1 ) PUSH_FLAG = .TRUE. LAST = 0 IF ( FLAG .EQ. 1 ) CALL DISPLAY RETURN END REAL*8 FUNCTION F_NEG( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_NEG = -X RETURN END SUBROUTINE CHANGE_SIGN C Changes the sign of the X register IMPLICIT NONE EXTERNAL F_NEG REAL*8 F_NEG REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_NEG( X ) ! 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 IMPLICIT NONE INTEGER FLAG REAL*8 X,Y,Z,T,LASTX BYTE LAST CHARACTER MODE*3 LOGICAL PUSH_FLAG,RADS,D_OK INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, PASTE1, * DISPLAY6 INTEGER SMG$PUT_CHARS INTEGER ISTATUS COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( MODE .EQ. 'DEG' ) THEN RADS = .FALSE. ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'DEG', 2, 38) ELSE RADS = .TRUE. ISTATUS = SMG$PUT_CHARS( DISPLAY4, 'RAD', 2, 38) 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 IMPLICIT NONE INTEGER SMG$ERASE_PASTEBOARD, PASTE1, ISTATUS COMMON / PASTE / PASTE1 C Clear the screen ISTATUS = SMG$ERASE_PASTEBOARD( PASTE1 ) RETURN END SUBROUTINE CLEAR_STACK C Resets the stack IMPLICIT NONE REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 IMPLICIT NONE 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 / ERROR,MODE,STRING COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST X = 0. PUSH_FLAG = .FALSE. LAST = CARR_RETURN CALL DISPLAY RETURN END REAL*8 FUNCTION F_DCOS( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DCOS = DCOS( X ) RETURN END REAL*8 FUNCTION F_DCOSD( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DCOSD = DCOSD( X ) RETURN END SUBROUTINE COSINE C Calculates COS( X ) IMPLICIT NONE EXTERNAL F_DCOS REAL*8 F_DCOS EXTERNAL F_DCOSD REAL*8 F_DCOSD REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( RADS ) THEN X = F_DCOS( X ) ELSE X = F_DCOSD( X ) END IF PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END SUBROUTINE CREATE_DISPLAYS C DISPLAY4 - BACKGROUND BORDER OF CALCULATOR KEYS C DISPLAY2 - CALCULATOR KEYS C DISPLAY1 - CALCULATOR OUTPUT DISPLAY AT TOP C DISPLAY3 - CALCULATOR INFORMATION ON SIDE C DISPLAY5 - ERROR TEXT AT TOP OF CALCULATOR C DISPLAY6 - ARROW KEY DEFINITIONS IMPLICIT NONE INCLUDE '($SMGDEF)' LOGICAL CRT, VT200 INTEGER SMG$CREATE_VIRTUAL_DISPLAY, SMG$CREATE_PASTEBOARD INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER PASTE1, KEYBOARD1, ROWS, COLUMNS, TERM_CHAR, ISTATUS COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 COMMON / PASTE / PASTE1 if ( .not. crt() ) then print*, 'You must use a DEC CRT terminal' call exit endif C+ C Create the pasteboard. C- ISTATUS = SMG$CREATE_PASTEBOARD (PASTE1) C+ C Create the virtual displays. C- ROWS = 3 COLUMNS = 41 ISTATUS = SMG$CREATE_VIRTUAL_DISPLAY( ROWS, COLUMNS, DISPLAY1 ) ROWS = 16 COLUMNS = 41 ISTATUS = SMG$CREATE_VIRTUAL_DISPLAY( ROWS, COLUMNS, DISPLAY2 ) ROWS = 11 COLUMNS = 33 ISTATUS = SMG$CREATE_VIRTUAL_DISPLAY( ROWS, COLUMNS, DISPLAY3 ) ROWS = 16 COLUMNS = 41 ISTATUS = SMG$CREATE_VIRTUAL_DISPLAY * ( ROWS, COLUMNS, DISPLAY4, SMG$M_BORDER ) ROWS = 1 COLUMNS = 41 ISTATUS = SMG$CREATE_VIRTUAL_DISPLAY( ROWS, COLUMNS, DISPLAY5 ) ROWS = 9 COLUMNS = 33 ISTATUS = SMG$CREATE_VIRTUAL_DISPLAY( ROWS, COLUMNS, DISPLAY6 ) END logical function crt IMPLICIT NONE include '($dvidef)' include '($ttdef)' include '($tt2def)' logical VT200 integer*2 b2(14) integer*4 b4(7), buf, len_buf, sys$getdviw, dev_type integer*4 len_dev_type logical*4 for$bjtest, istat equivalence ( b4(1), b2(1) ) COMMON / TERM / VT200 b2(1) = 4 b2(2) = dvi$_devdepend2 b4(2) = %loc( buf ) b4(3) = %loc( len_buf ) b2(7) = 4 b2(8) = dvi$_devtype b4(5) = %loc( dev_type ) b4(6) = %loc( len_dev_type ) b4(7) = 0 istat = sys$getdviw( ,, 'SYS$COMMAND', b4,,,, ) crt = ( for$bjtest( buf, tt2$v_deccrt ) .or. . dev_type .eq. tt$_vt52 ) VT200 = ((dev_type .eq. tt$_vt200_series) * .OR. (dev_type .eq. tt$_vt300_series)) return end SUBROUTINE DELETE_DIGIT C Deletes a digit from the current display IMPLICIT NONE 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 INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER ISTATUS INTEGER SMG$PUT_CHARS COMMON / DISP / ERROR,MODE,STRING COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 IF ( D_OK ) THEN STRING = ' '//STRING(1:36) IF ( STRING(37:37) .EQ. ' ' ) THEN CALL DISPLAY LAST = CARR_RETURN ELSE ISTATUS = SMG$PUT_CHARS( DISPLAY1, STRING, 2, 3) 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 IMPLICIT NONE PARAMETER CARR_RETURN = '0000000D'X CHARACTER MODE*1,CHAR*1,STRING*37 REAL*8 X,Y,Z,T,LASTX BYTE LAST INTEGER STR$POSITION INTEGER I,J LOGICAL PUSH_FLAG,ERROR,RADS,D_OK,FLAG COMMON / DISP / ERROR,MODE,STRING COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 IMPLICIT NONE REAL*8 X,Y,Z,T,LASTX INTEGER I_X,IO_CHAN,TT_TYPE,FIX_NUM,SMG$PUT_CHARS BYTE LAST CHARACTER MODE*1,STRING*37 LOGICAL FLAG,MINUS,PUSH_FLAG,ERROR,RADS,D_OK INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER ISTATUS INTEGER I COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST COMMON / DISP / ERROR,MODE,STRING 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 ISTATUS = SMG$PUT_CHARS( DISPLAY1, STRING, 2, 3) 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. ) 50 FORMAT ( F37. ) END REAL*8 FUNCTION F_DIVIDE( X, Y ) IMPLICIT NONE REAL*8 X,Y EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DIVIDE = Y / X RETURN END SUBROUTINE DIVIDE C Divides Y by X IMPLICIT NONE EXTERNAL F_DIVIDE REAL*8 F_DIVIDE REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST C Load the X register if necessary IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_DIVIDE( X, Y ) !X = Y / X Y = Z Z = T T = 0. PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END SUBROUTINE DRAW_CALC C DISPLAY4 - BACKGROUND BORDER OF CALCULATOR KEYS C DISPLAY2 - CALCULATOR KEYS C DISPLAY1 - CALCULATOR OUTPUT DISPLAY AT TOP C DISPLAY3 - CALCULATOR INFORMATION ON SIDE C DISPLAY5 - ERROR TEXT AT TOP OF CALCULATOR C DISPLAY6 - ARROW KEY DEFINITIONS IMPLICIT NONE INCLUDE '($SMGDEF)' LOGICAL VT200 INTEGER SMG$PASTE_VIRTUAL_DISPLAY, SMG$PUT_LINE, SMG$PUT_CHARS INTEGER SMG$DRAW_LINE INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER PASTE1 INTEGER ISTATUS COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 COMMON / TERM / VT200 parameter PF1_U = ' BLACK ' parameter PF1_L = ' ' parameter PF2_U = ' ' parameter PF2_L = ' WHITE ' parameter PF3_U = ' LOG ' parameter PF3_L = ' 10^X ' parameter PF4_U = ' LN ' parameter PF4_L = ' EXP ' parameter KP1_U = ' RDN ' parameter KP1_L = ' RUP ' parameter KP2_U = ' FIX ' parameter KP2_L = ' X<>Y ' parameter KP3_U = ' LASTX ' parameter KP3_L = ' RESET ' parameter KP4_U = ' SQRT ' parameter KP4_L = ' X^2 ' parameter KP5_U = ' 1/X ' parameter KP5_L = ' Y^X ' parameter KP6_U = ' +/- ' parameter KP6_L = ' |X| ' parameter KP7_U = ' SIN ' parameter KP7_L = ' ASIN ' parameter KP8_U = ' COS ' parameter KP8_L = ' ACOS ' parameter KP9_U = ' TAN ' parameter KP9_L = ' ATAN ' parameter MINUS_U = ' RAD ' parameter MINUS_L = ' DEG ' parameter COMMA_U = ' INT ' parameter COMMA_L = ' FRAC ' parameter ENTER_U = ' ' parameter ENTER_L = ' EXIT ' parameter PERIOD_U = ' PI ' parameter PERIOD_L = ' e ' parameter KP0_U = ' CL X ' parameter KP0_L = ' CLST ' C .BEGIN C Draw box around calculator output display ISTATUS = SMG$DRAW_LINE ( DISPLAY1, 1, 1, 1, 41) ISTATUS = SMG$DRAW_LINE ( DISPLAY1, 3, 1, 3, 41) ISTATUS = SMG$DRAW_LINE ( DISPLAY1, 1, 1, 3, 1) ISTATUS = SMG$DRAW_LINE ( DISPLAY1, 1, 41, 3, 41) C Draw the keys on display2 ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 1, 1, 1, 41) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 4, 1, 4, 41) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 7, 1, 7, 41) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 10, 1, 10, 41) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 13, 1, 13, 31) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 16, 1, 16, 41) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 1, 1, 16, 1) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 1, 11, 13, 11) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 1, 21, 16, 21) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 1, 31, 16, 31) ISTATUS = SMG$DRAW_LINE ( DISPLAY2, 1, 41, 16, 41) C Label the keys ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF1_U, 2, 2) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF1_L, 3, 2) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF2_U, 2, 12, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF2_L, 3, 12, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF3_U, 2, 22) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF3_L, 3, 22, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF4_U, 2, 32) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PF4_L, 3, 32, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP1_U, 11, 2) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP1_L, 12, 2, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP2_U, 11, 12) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP2_L, 12, 12, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP3_U, 11, 22) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP3_L, 12, 22, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP4_U, 8, 2) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP4_L, 9, 2, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP5_U, 8, 12) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP5_L, 9, 12, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP6_U, 8, 22) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP6_L, 9, 22, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP7_U, 5, 2) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP7_L, 6, 2, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP8_U, 5, 12) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP8_L, 6, 12, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP9_U, 5, 22) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP9_L, 6, 22, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, MINUS_U, 5, 32) ISTATUS = SMG$PUT_CHARS( DISPLAY2, MINUS_L, 6, 32, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, COMMA_U, 8, 32) ISTATUS = SMG$PUT_CHARS( DISPLAY2, COMMA_L, 9, 32, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, ENTER_U, 12, 32) ISTATUS = SMG$PUT_CHARS( DISPLAY2, ENTER_L, 14, 32, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PERIOD_U, 14, 22) ISTATUS = SMG$PUT_CHARS( DISPLAY2, PERIOD_L, 15, 22, , SMG$M_REVERSE) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP0_U, 14, 2) ISTATUS = SMG$PUT_CHARS( DISPLAY2, KP0_L, 15, 2, , SMG$M_REVERSE) C Calculator information on display3 ISTATUS = SMG$PUT_CHARS( DISPLAY3,'Integer modes:', 1, 1) ISTATUS = SMG$PUT_CHARS( DISPLAY3,'Ctrl-I (Decimal)', 3, 3) ISTATUS = SMG$PUT_CHARS( DISPLAY3, 'Ctrl-B Binary', 4, 3) ISTATUS = SMG$PUT_CHARS( DISPLAY3, ' O Octal', 5, 3) ISTATUS = SMG$PUT_CHARS( DISPLAY3, 'Ctrl-H Hexadecimal', 6, 3) ISTATUS = SMG$PUT_CHARS( DISPLAY3, 'Real modes:', 8, 1) ISTATUS = SMG$PUT_CHARS( DISPLAY3, 'Ctrl-F Floating point', 10, 3) ISTATUS = SMG$PUT_CHARS( DISPLAY3, 'Ctrl-E Exponential', 11, 3) C Draw boxes for arrow keys ( + - * / ) IF (VT200) THEN !If VT200 series terminal then draw arrows differently) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '(arrows)', 1, 14) ISTATUS = SMG$PUT_CHARS( DISPLAY6, 'up', 2, 17) ISTATUS = SMG$PUT_CHARS( DISPLAY6, 'down', 9, 17) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '<--', 9, 9) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '-->', 9, 25) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '+', 4, 18) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '-', 7, 18) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '*', 7, 10) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '/', 7, 26) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 3, 15, 3, 21) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 3, 21, 5, 21) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 3, 15, 5, 15) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 5, 15, 5, 21) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 7, 6, 13) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 13, 8, 13) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 7, 8, 7) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 8, 7, 8, 13) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 15, 6, 21) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 21, 8, 21) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 15, 8, 15) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 8, 15, 8, 21) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 23, 6, 29) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 29, 8, 29) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 23, 8, 23) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 8, 23, 8, 29) ELSE !Else not VT200 series terminal. Draw arrows normally) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '(arrows)', 4, 14) ISTATUS = SMG$PUT_CHARS( DISPLAY6, 'up', 5, 4) ISTATUS = SMG$PUT_CHARS( DISPLAY6, 'down', 5, 11) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '<--', 5, 21) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '-->', 5, 28) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '+', 7, 5) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '-', 7, 13) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '*', 7, 22) ISTATUS = SMG$PUT_CHARS( DISPLAY6, '/', 7, 30) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 2, 6, 8) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 8, 8, 8) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 2, 8, 2) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 8, 2, 8, 8) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 10, 6, 16) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 16, 8, 16) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 10, 8, 10) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 8, 10, 8, 16) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 19, 6, 25) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 25, 8, 25) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 19, 8, 19) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 8, 19, 8, 25) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 27, 6, 33) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 33, 8, 33) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 6, 27, 8, 27) ISTATUS = SMG$DRAW_LINE ( DISPLAY6, 8, 27, 8, 33) ENDIF C+ C Paste the virtual displays. ISTATUS = SMG$PASTE_VIRTUAL_DISPLAY ( DISPLAY4, PASTE1, 7, 38) ISTATUS = SMG$PASTE_VIRTUAL_DISPLAY ( DISPLAY2, PASTE1, 9, 38) ISTATUS = SMG$PASTE_VIRTUAL_DISPLAY ( DISPLAY1, PASTE1, 5, 38) ISTATUS = SMG$PASTE_VIRTUAL_DISPLAY ( DISPLAY5, PASTE1, 4, 38) ISTATUS = SMG$PASTE_VIRTUAL_DISPLAY ( DISPLAY3, PASTE1,13, 3) ISTATUS = SMG$PASTE_VIRTUAL_DISPLAY ( DISPLAY6, PASTE1, 3, 3) END C SUBROUTINE DRAW_HELP ( FLAG ) CC THIS ROUTINE HAS BEEN DISABLED C CC Draws the bottom part of the help display C C PARAMETER DT$_VT100 = '00000060'X C PARAMETER DT$_VT52 = '00000040'X C C INTEGER IO_CHAN,TT_TYPE,FIX_NUM C BYTE G_ON(3),G_OFF(3) C LOGICAL FLAG C C DATA G_ON / 27,'(','0' / C DATA G_OFF / 27,'(','B' / C C COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM C C IF ( TT_TYPE .EQ. DT$_VT100 ) THEN C CALL OUT_BYTE ( 3,G_ON ) C CALL OUT_CHAR ( 20, 1,34,'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq' ) C CALL OUT_CHAR ( 20,35,34,'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq' ) C CALL OUT_CHAR ( 20,69,11,'qqqqqqqqqqq' ) C CALL OUT_BYTE ( 3,G_OFF ) C ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN C CALL OUT_CHAR ( 20, 1,34,'----------------------------------' ) C CALL OUT_CHAR ( 20,35,34,'----------------------------------' ) C CALL OUT_CHAR ( 20,69,11,'-----------' ) C END IF C IF ( FLAG ) THEN C CALL OUT_CHAR ( 21,13,34,'Type A SPACE to continue the o' ) C CALL OUT_CHAR ( 21,47,10,'utput; or,' ) C ELSE C CALL OUT_CHAR ( 22,13,4,'Type' ) C END IF C CALL OUT_CHAR ( 22,18,37,'ANOTHER KEY for help on that key; or,' ) C CALL OUT_CHAR ( 23,18,29,'A CTRL-Z to return to CALC' ) C CALL MOVE_TO ( 24,1 ) C C RETURN C END SUBROUTINE E C Puts E in the X register and in LASTX IMPLICIT NONE REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 IMPLICIT NONE 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,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 IMPLICIT NONE INTEGER CODE,LENGTH, SMG$PUT_CHARS INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 LOGICAL ERROR,BELL INTEGER ISTATUS CHARACTER MODE*1,STRING*37,LINE*67 COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 COMMON / DISP / ERROR,MODE,STRING 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 C LINE = 'Type ? for general instructions' !HELP HAS BEEN DISABLED LINE = ' ' 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 SMG$RING_BELL( DISPLAY5 ) ISTATUS = SMG$PUT_CHARS( DISPLAY5, LINE, 1, 1) CALL MOVE_TO ( 24,1 ) RETURN END SUBROUTINE EXCHANGE C Exchanges the X and Y registers IMPLICIT NONE REAL*8 X,Y,Z,T,Q,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG Q = X X = Y Y = Q PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_EXPONENT( X, Y ) IMPLICIT NONE REAL*8 X,Y EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) IF ( X .LT. 0. ) THEN F_EXPONENT = 1. / (Y**(-X)) ELSE F_EXPONENT = Y**X END IF RETURN END SUBROUTINE EXPONENT C Calculates Y**X IMPLICIT NONE EXTERNAL F_EXPONENT REAL*8 F_EXPONENT REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_EXPONENT( X, Y ) !Y**X 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 IMPLICIT NONE 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,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 IMPLICIT NONE EXTERNAL F_DFLOTJ_JIDINT REAL*8 F_DFLOTJ_JIDINT REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = X - F_DFLOTJ_JIDINT( X ) !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 IMPLICIT NONE INCLUDE '($SMGDEF)' C PARAMETER SMG$K_TRM_EXCLAMATION_POINT = '00000021'X ! ! C PARAMETER SMG$K_TRM_LEFT_PAREN = '00000028'X ! ( C PARAMETER SMG$K_TRM_RIGHT_PAREN = '00000029'X ! ) C PARAMETER SMG$K_TRM_PLUS_SIGN = '0000002B'X ! + C PARAMETER SMG$K_TRM_ZERO = '00000030'X ! 0 INTEGER SMG$READ_KEYSTROKE, KEY INTEGER KEYBOARD1 LOGICAL ERR_CHECK CHARACTER INPUT*1 COMMON / ERROR / ERR_CHECK COMMON / KEYBOARD / KEYBOARD1 ERR_CHECK = .FALSE. CALL SMG$READ_KEYSTROKE ( KEYBOARD1, KEY ) INPUT = 'X' !This should cause an error unless input is changed !upon parsing the keystroke below. A bit kludgy. C ****************************************************************** C -------------- CONTROL INPUTS 000 - 031 --------------------- IF ( KEY .LT. SMG$K_TRM_SPACE ) THEN !CONTROL INPUTS C -------------MISCELANEOUS !"#$%&'()*+,-./ ------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_ZERO ) THEN !MISC C --------------- NUMBERS 0-9 -------------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_NINE ) THEN !NUMBERS INPUT = CHAR( KEY ) C ------------- MISCELLANEOUS :;<=>?@ ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_UPPERCASE_A ) THEN !MISC C -------------- LETTERS A-Z --------------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_UPPERCASE_Z) THEN !UPPERCAE ALPHABET INPUT = CHAR( KEY ) C ---------------- MISCELANEOUS [\]^_` ----------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_LOWERCASE_A ) THEN !MISC C ---------------- lowercase letters a-z --------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_LOWERCASE_Z ) THEN !lowercase alphabet INPUT = CHAR( KEY ) CALL STR$UPCASE ( INPUT, INPUT ) C ----------------- MISCELLANEOUS {|}~ del ------------------------- ELSEIF ( KEY .LT. SMG$K_TRM_PF1 ) THEN !MISC C ------------------ KEYPAD PF1-PF4 -------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_PF4 ) THEN !PF1-PF4 C --------------------- KEYPAD 0-9 --------------------------------- ELSEIF ( KEY .LE. SMG$K_TRM_KP9 ) THEN !KP0-KP9 IF ( KEY .EQ. SMG$K_TRM_KP0 ) THEN INPUT = '0' ELSEIF ( KEY .EQ. SMG$K_TRM_KP1 ) THEN INPUT = '1' ELSEIF ( KEY .EQ. SMG$K_TRM_KP2 ) THEN INPUT = '2' ELSEIF ( KEY .EQ. SMG$K_TRM_KP3 ) THEN INPUT = '3' ELSEIF ( KEY .EQ. SMG$K_TRM_KP4 ) THEN INPUT = '4' ELSEIF ( KEY .EQ. SMG$K_TRM_KP5 ) THEN INPUT = '5' ELSEIF ( KEY .EQ. SMG$K_TRM_KP6 ) THEN INPUT = '6' ELSEIF ( KEY .EQ. SMG$K_TRM_KP7 ) THEN INPUT = '7' ELSEIF ( KEY .EQ. SMG$K_TRM_KP8 ) THEN INPUT = '8' ELSEIF ( KEY .EQ. SMG$K_TRM_KP9 ) THEN INPUT = '9' END IF C --------------------- MISCELLANEOUS ------------------------------ ELSEIF ( KEY .LT. SMG$K_TRM_F1 ) THEN !MISC C -------------- END CASE ------------------------------------------ ENDIF RETURN END C Arithmetic Error Condition Handler C Established as handler for functions which perform arithmatic and C return the result as a REAL*8 floating point function value. C For any arithmetic error, set the return status of the function to 0.0 C C OpenVMS Calling Standard C C 6.5.3.2 Exception Synchronization (Alpha VMS Only) C C · If a procedure has an exception handler that does not C simply reraise all arithmetic traps caused by code that is C not contained directly within that procedure, the proce- C dure must issue a TRAPB instruction before it establishes C itself as the current procedure. C C · If a procedure has an exception handler that does not C simply reraise all arithmetic traps caused either by code C that is not contained directly within that procedure or C by any procedure that might have been called while C that procedure was current, the procedure must issue a C TRAPB instruction in the procedure epilogue while it is C still the current procedure. C C These rules ensure that exceptions are detected in the in- C tended context of the exception handler. C C To specify the value of the top-level function being unwound, C the handler should modify the appropriate saved register lo- C cations in the mechanism_args vector. They are restored C from the mechanism_args vector at the end of the unwind. C C CHF$IH_MCH_SAVR0 refers to register R0<63:0> and C CHF$IH_MCH_SAVR1 refers to register R1<63:0>. Access C is also provided to F0<63:0> and F1<63:0> as CHF$FH_ C MCH_SAVF0 and CHF$FH_MCH_SAVF1, respectively, so C return values can be modified. (For more information, see C Section 6.7.2.) ¨ INTEGER FUNCTION HANDLER ( SIGARGS,MECHARGS ) IMPLICIT NONE INCLUDE '($SSDEF)' INTEGER SIGARGS(1:*),MECHARGS(1:*) INTEGER ISTAT INTEGER SYS$UNWIND LOGICAL ERR_CHECK COMMON / ERROR / ERR_CHECK IF (SIGARGS(2) .EQ. SS$_UNWIND) THEN HANDLER=SS$_RESIGNAL !Actually VMS ignores the return value here RETURN !Already unwinding !but DEC FORTRAN requires it to be set to something anyway. ENDIF 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 CALL ERR_HAND ( -14 ) !Arithmetic error MECHARGS(4) = 0 !VAX/VMS Set return value R0,R1 to 0 MECHARGS(5) = 0 !VAX/VMS C MECHARGS(44) = 0 !AXP/OpenVMS Set return value F0,F1 to 0 C MECHARGS(45) = 0 !AXP/OpenVMS ISTAT = SYS$UNWIND(,) !unwind ENDIF RETURN END C SUBROUTINE HELP ( KEY ) C HELP HAS BEEN DISABLED C Functions as an online help facility C C PARAMETER DT$_VT100 = '00000060'X C PARAMETER DT$_VT52 = '00000040'X C PARAMETER CARR_RETURN = '0000000D'X C PARAMETER LBR$C_READ = '00000001'X C PARAMETER LBR$C_TYP_TXT = '00000004'X C PARAMETER LBR$_NORMAL = '00268001'X C PARAMETER SS$_NORMAL = '00000001'X C PARAMETER RMS$_EOF = '0001827A'X C PARAMETER DELETE = '0000007F'X C PARAMETER CTRL_B = '00000002'X C PARAMETER CTRL_E = '00000005'X C PARAMETER CTRL_F = '00000006'X C PARAMETER CTRL_H = '00000008'X C PARAMETER CTRL_I = '00000009'X C PARAMETER CTRL_O = '0000000F'X C PARAMETER CTRL_Z = '0000001A'X C C CHARACTER KEY*1,LINE*67,LIBKEY*6 C INTEGER IO_CHAN,TT_TYPE,FIX_NUM,INDEX,STATUS,LBR$OPEN,RFA(2), C . LBR$LOOKUP_KEY,LBR$GET_RECORD,O_STAT,STR$POSITION C LOGICAL MORE C C COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM C CC Open CALC's help library C C CALL LBR$INI_CONTROL ( INDEX,LBR$C_READ,LBR$C_TYP_TXT, ) C O_STAT = LBR$OPEN ( INDEX,'CALC$HELPFILE',,,,, ) C CC Help loop C C1000 CONTINUE C C IF ( KEY .EQ. CHAR( CARR_RETURN ) ) THEN C LIBKEY = 'CR' C ELSEIF ( KEY .EQ. CHAR( DELETE ) ) THEN C LIBKEY = 'DEL' C ELSEIF ( KEY .EQ. CHAR( CTRL_B ) ) THEN C LIBKEY = 'CTRL_B' C ELSEIF ( KEY .EQ. CHAR( CTRL_E ) ) THEN C LIBKEY = 'CTRL_E' C ELSEIF ( KEY .EQ. CHAR( CTRL_F ) ) THEN C LIBKEY = 'CTRL_F' C ELSEIF ( KEY .EQ. CHAR( CTRL_H ) ) THEN C IF ( TT_TYPE .EQ. DT$_VT100 ) THEN C LIBKEY = 'BS100' C ELSEIF ( TT_TYPE .EQ. DT$_VT52 ) THEN C LIBKEY = 'BS52' C END IF C ELSEIF ( KEY .EQ. CHAR( CTRL_I ) ) THEN C LIBKEY = 'CTRL_I' C ELSEIF ( KEY .EQ. CHAR( CTRL_O ) ) THEN C LIBKEY = 'CTRL_O' C ELSEIF ( KEY .EQ. ',' ) THEN C LIBKEY = 'COMMA' C ELSEIF ( KEY .EQ. '+' ) THEN C LIBKEY = 'PLUS' C ELSEIF ( KEY .EQ. '-' ) THEN C LIBKEY = 'MINUS' C ELSEIF ( KEY .EQ. '*' ) THEN C LIBKEY = 'STAR' C ELSEIF ( KEY .EQ. '/' ) THEN C LIBKEY = 'SLASH' C ELSE C LIBKEY = KEY C END IF C C STATUS = LBR$LOOKUP_KEY ( INDEX,LIBKEY,RFA ) C IF ( STATUS .EQ. SS$_NORMAL ) THEN C C1100 CALL CLEAR_SCREEN C MORE = .TRUE. C DO I = 1, 18 C LINE = ' ' C STATUS = LBR$GET_RECORD ( INDEX,LINE, ) C IF ( STATUS .EQ. RMS$_EOF ) THEN C MORE = .FALSE. C GO TO 1400 C ELSE C IF ( TT_TYPE .EQ. DT$_VT52 ) THEN C1200 CONTINUE C J = STR$POSITION( LINE,'BLACK' ) C IF ( J .NE. 0 ) THEN C LINE(J:J+4) = 'UPPER' C ELSE C J = STR$POSITION( LINE,'WHITE' ) C IF ( J .NE. 0 ) THEN C LINE(J:J+4) = 'LOWER' C ELSE C GO TO 1300 C END IF C END IF C GO TO 1200 C END IF C1300 CALL STR$TRIM ( LINE,LINE,J ) C CALL OUT_CHAR ( I,13,J,LINE ) C END IF C END DO C C ELSE C C CALL CLEAR_SCREEN C MORE = .FALSE. C IF ( O_STAT .NE. LBR$_NORMAL ) THEN C CALL OUT_CHAR ( 4,13,25,'Unable to open help file:' ) C CALL ERR_HAND ( O_STAT ) C ELSE C CALL OUT_CHAR ( 4,13,29,'That key does nothing; typing' ) C CALL OUT_CHAR ( 4,42,28,' it will result in an error' ) C END IF C C END IF C C1400 CALL DRAW_HELP ( MORE ) C CALL GET_INPUT ( KEY ) C IF ( MORE .AND. KEY.EQ.' ' ) THEN C GO TO 1100 C ELSEIF ( KEY .EQ. CHAR( CTRL_Z ) ) THEN C CALL LBR$CLOSE ( INDEX ) C CALL RESET C RETURN C END IF C C GO TO 1000 C C END SUBROUTINE INITIALIZE C Initializes the calculator IMPLICIT NONE REAL*8 X,Y,Z,T,LASTX INTEGER IO_CHAN,TT_TYPE,FIX_NUM INTEGER PASTE1 LOGICAL PUSH_FLAG,RADS,D_OK BYTE LAST COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST COMMON / PASTE / PASTE1 C Establish a channel to the terminal C C CALL SYS$ASSIGN ( 'SYS$COMMAND',IO_CHAN,, ) C C Set the defaults and clear the stack FIX_NUM = 4 LAST = 0 D_OK = .FALSE. C Write out the display CALL CREATE_DISPLAYS CALL ERR_HAND ( -15 ) CALL DRAW_CALC CALL CHANGE_MODE ( 'F',0 ) CALL CHANGE_TRIG ( 'RAD',0 ) CALL CLEAR_STACK CALL MOVE_TO (1,1) RETURN END REAL*8 FUNCTION F_DFLOTJ_JIDINT( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DFLOTJ_JIDINT = DFLOTJ( JIDINT(X) ) RETURN END SUBROUTINE INTEGER C Integerizes the X register IMPLICIT NONE EXTERNAL F_DFLOTJ_JIDINT REAL*8 F_DFLOTJ_JIDINT REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_DFLOTJ_JIDINT( X ) !X = DFLOTJ( JIDINT(X) ) PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END SUBROUTINE INVERT C Calculates 1 / X IMPLICIT NONE EXTERNAL F_DIVIDE REAL*8 F_DIVIDE REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_DIVIDE( X, 1. ) !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 IMPLICIT NONE REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 IMPLICIT NONE PARAMETER CARR_RETURN = '0000000D'X REAL*8 X,Y,Z,T,LASTX INTEGER I_X,STR$POSITION INTEGER I LOGICAL PUSH_FLAG,ERROR,MINUS,RADS,D_OK CHARACTER STRING*37,MODE*1 BYTE LAST COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST COMMON / DISP / ERROR,MODE,STRING 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 = DFLOTJ( I_X ) ELSEIF ( MODE .EQ. 'O' ) THEN DECODE ( 37,20,STRING,ERR=1100 ) I_X X = DFLOTJ( I_X ) ELSEIF ( MODE .EQ. 'H' ) THEN DECODE ( 37,30,STRING,ERR=1100 ) I_X X = DFLOTJ( 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 REAL*8 FUNCTION F_DLOG10( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DLOG10 = DLOG10( X ) RETURN END SUBROUTINE LOG_10 C Calculates LOG( X ) IMPLICIT NONE EXTERNAL F_DLOG10 REAL*8 F_DLOG10 REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_DLOG10( X ) PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_DLOG( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DLOG = DLOG( X ) RETURN END SUBROUTINE LOG_E C Calculates LN( X ) IMPLICIT NONE EXTERNAL F_DLOG REAL*8 F_DLOG REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_DLOG( X ) PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END SUBROUTINE MOVE_TO ( LINE,COLUMN ) C Moves the cursor out of the way. Line and column are not used. IMPLICIT NONE INTEGER LINE, COLUMN INTEGER SMG$SET_CURSOR_ABS INTEGER DISPLAY1, DISPLAY2, DISPLAY3, DISPLAY4, DISPLAY5, * DISPLAY6 INTEGER ISTATUS COMMON / DISPLAYS / DISPLAY1,DISPLAY2,DISPLAY3,DISPLAY4,DISPLAY5, * DISPLAY6 ISTATUS = SMG$SET_CURSOR_ABS( DISPLAY3, 11, 1 ) RETURN END REAL*8 FUNCTION F_MULTIPLY( X, Y ) IMPLICIT NONE REAL*8 X,Y EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_MULTIPLY = X * Y RETURN END SUBROUTINE MULTIPLY C Multiplies X by Y IMPLICIT NONE EXTERNAL F_MULTIPLY REAL*8 F_MULTIPLY REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST C Load the X register if necessary IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_MULTIPLY( X, Y ) !X = X*Y Y = Z Z = T T = 0. PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END C SUBROUTINE OUT_BYTE ( LENGTH,STRING ) C CC THIS SUBROUTINE SHOULD NO LONGE BE CALLED. USE SMG SERVICES INSTEAD CC Writes out a byte string of given length C C PARAMETER IO$_WRITEVBLK = '00000030'X C PARAMETER IO$M_NOFORMAT = '00000100'X C PARAMETER IO$M_CANCTRL0 = '00000040'X C C BYTE STRING(100) C INTEGER IO_CHAN,LENGTH,TT_TYPE,FIX_NUM C C COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM C C CALL SYS$QIOW ( %VAL(0), C . %VAL(IO_CHAN), C . %VAL(IO$_WRITEVBLK+ C . IO$M_CANCTRL0+ C . IO$M_NOFORMAT),,,, C . STRING, C . %VAL(LENGTH),,,, ) C C RETURN C END C SUBROUTINE OUT_CHAR ( X,Y,LENGTH,STRING ) CC THIS SUBROUTINE SHOULD NO LONGER BE CALLED. USE SMG SERVICES INSTEAD C CC Writes out a character string of given length at (X,Y) C C PARAMETER IO$_WRITEVBLK = '00000030'X C PARAMETER IO$M_NOFORMAT = '00000100'X C PARAMETER IO$M_CANCTRLO = '00000040'X C C CHARACTER STRING*100 C INTEGER IO_CHAN,LENGTH,TT_TYPE,FIX_NUM,X,Y C C COMMON / SCREEN / IO_CHAN,TT_TYPE,FIX_NUM C C CALL MOVE_TO ( X,Y ) C C CALL SYS$QIOW ( %VAL(0), C . %VAL(IO_CHAN), C . %VAL(IO$_WRITEVBLK+ C . IO$M_CANCTRLO+ C . IO$M_NOFORMAT),,,, C . %REF(STRING), C . %VAL(LENGTH),,,, ) C C RETURN C END SUBROUTINE PI C Puts PI in the X register and in LASTX IMPLICIT NONE REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 REAL*8 FUNCTION F_POWER_10( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) IF ( X .LT. 0. ) THEN F_POWER_10 = 1. / 10.**(-X) ELSE F_POWER_10 = 10.**X END IF RETURN END SUBROUTINE POWER_10 C Calculates 10**X IMPLICIT NONE EXTERNAL F_POWER_10 REAL*8 F_POWER_10 REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_POWER_10( X ) PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_POWER_E( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) IF ( X .LT. 0. ) THEN F_POWER_E = 1. / DEXP( -X ) ELSE F_POWER_E = DEXP( X ) END IF RETURN END SUBROUTINE POWER_E C Calculates E**X IMPLICIT NONE EXTERNAL F_POWER_E REAL*8 F_POWER_E REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_POWER_E( X ) PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END SUBROUTINE PUSH_STACK C Pushes the stack up IMPLICIT NONE REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST T = Z Z = Y Y = X X = 0. RETURN END SUBROUTINE RESET C Resets the display IMPLICIT NONE INTEGER PASTE1, SMG$REPAINT_SCREEN INTEGER ISTATUS COMMON / PASTE / PASTE1 C Write out the display ISTATUS = SMG$REPAINT_SCREEN( PASTE1 ) RETURN END SUBROUTINE ROLL_DOWN C Rolls the stack down IMPLICIT NONE REAL*8 X,Y,Z,T,Q,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 IMPLICIT NONE REAL*8 X,Y,Z,T,Q,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST 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 REAL*8 FUNCTION F_DSIN( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DSIN = DSIN( X ) RETURN END REAL*8 FUNCTION F_DSIND( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DSIND = DSIND( X ) RETURN END SUBROUTINE SINE C Calculates SIN( X ) IMPLICIT NONE EXTERNAL F_DSIN REAL*8 F_DSIN EXTERNAL F_DSIND REAL*8 F_DSIND REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( RADS ) THEN X = F_DSIN( X ) ELSE X = F_DSIND( X ) END IF PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_DSQRT( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DSQRT = DSQRT( X ) RETURN END SUBROUTINE SQUARE_ROOT C Calculates the square root of X IMPLICIT NONE EXTERNAL F_DSQRT REAL*8 F_DSQRT REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_DSQRT( X ) PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END SUBROUTINE SQUARE_X C Calculates X*X IMPLICIT NONE EXTERNAL F_MULTIPLY REAL*8 F_MULTIPLY REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG X = F_MULTIPLY( X, X ) !X = X**2. PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END REAL*8 FUNCTION F_SUBTRACT( X, Y ) IMPLICIT NONE REAL*8 X,Y EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_SUBTRACT = Y - X RETURN END SUBROUTINE SUBTRACT C Subtracts X from Y IMPLICIT NONE EXTERNAL F_SUBTRACT REAL*8 F_SUBTRACT 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,LASTX,PUSH_FLAG,RADS,D_OK,LAST COMMON / DISP / ERROR,MODE,STRING 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 = F_SUBTRACT( X, Y ) !X = Y - X Y = Z Z = T T = 0. PUSH_FLAG = .TRUE. CALL DISPLAY RETURN END REAL*8 FUNCTION F_DTAN( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DTAN = DTAN( X ) RETURN END REAL*8 FUNCTION F_DTAND( X ) IMPLICIT NONE REAL*8 X EXTERNAL HANDLER CALL LIB$ESTABLISH ( HANDLER ) F_DTAND = DTAND( X ) RETURN END SUBROUTINE TANGENT C Calculates TAN( X ) IMPLICIT NONE EXTERNAL F_DTAN REAL*8 F_DTAN EXTERNAL F_DTAND REAL*8 F_DTAND REAL*8 X,Y,Z,T,LASTX BYTE LAST LOGICAL PUSH_FLAG,RADS,D_OK COMMON / STACK / X,Y,Z,T,LASTX,PUSH_FLAG,RADS,D_OK,LAST IF ( .NOT.PUSH_FLAG ) CALL LOAD_X_REG IF ( RADS ) THEN X = F_DTAN( X ) ELSE X = F_DTAND( X ) END IF PUSH_FLAG = .TRUE. LAST = 0 CALL DISPLAY RETURN END