Trailing-Edge
-
PDP-10 Archives
-
decus_20tap1_198111
-
decus/20-0001/calun.for
There is 1 other file named calun.for in the archive. Click here to see a list.
C
C
C
C COPYRIGHT (c) 1977 BY
C DIGITAL EQUIPMENT CORPORTATION, MAYNARD, MASS.
C
C THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
C ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
C INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
C COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
C OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
C TRANSFERRED.
C
C THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
C AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
C CORPORATION.
C
C DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
C SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
C
C
C
C
C
C
C
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++
C + +
C + CALC VERSION X01-01 +
C + +
C + PETER BAUM 1-SEP-77 +
C + DIGITAL EQUIPMENT CORPORATION +
C + 146 MAIN STREET +
C + MAYNARD, MASSACHUSETTS 01754 +
C + +
C ++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C
C
C
C *****************************************************
C * SUBROUTINE CALUN *
C *****************************************************
C
C
C SUBROUTINE CALUN PERFORMS A UNARY OPERATION.
C
C
C
C
C
C UPON ENTRANCE:
C OPERATOR IS ON STACK 2
C OPERAND IS ON STACK 1
C UPON EXIT:
C OPERATOR HAS BEEN POPPED OFF STACK 2
C RESULT IS ON STACK 1
C
C RETCD MEANING
C
C 1 O.K.
C 2 ERROR
C
C
C
C MODIFICATION CLASSES: M3, M4, AND M8
C
C
C
C CALUN CALLS
C
C CONTYP CONVERTS DATA TYPES
C ERRMSG PRINTS ERROR MESSAGES
C $DATAN ARC TANGENT
C $DCOS COSINE
C $DEXP E**X
C $DLOG NATURAL LOG
C $DLOG10 LOG BASE 10
C $DSIN SINE
C $DSQRT SQUARE ROOT
C $DTANH HYPERBOLIC TANGENT
C
C
C
C CALUN IS CALLED BY POSTVL WHICH CONVERTS FROM INFIX TO POSTFIX
C
C
C
C VARIABLE USE
C
C RETCD RETURN CODE: 1 = O.K. 2 = ERROR
C J,K,K2,I HOLD TEMPORARY VALUES
C MINUS VALUE IN LAST MULTIPLE PRECISION BYTE.
C USED TO INDICATE A NEGATIVE NUMBER.
C PLUS VALUE IN LAST MULTIPLE PRCISION BYTE.
C USED TO INDICATE A POSITIVE NUMBER.
C REAL TEMPORARY DOUBLE PRECISION VALUES.
C INT TEMPORARY INTEGER*4 VALUES.
C ST1TYP(40) TYPE FOR EACH ELEMENT ON STACK 1
C ST2TYP(40) TYPE FOR EACH ELEMENT OF STACK 2
C ST1PT POINTS TO TOP OF STACK 1
C ST2PT POINTS TO TOP OF STACK 2
C STACK1 HOLDS OPERAND
C STACK2 HOLDS UNARY OPERATOR
C
C
C
SUBROUTINE CALUN(RETCD)
REAL*8 REAL
REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
REAL*8 DTANH,DATAN
C
REAL*4 FLOAT
C
INTEGER*4 INT,IABS
C
INTEGER*2 RETCD,RETCD2
INTEGER*2 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT,ST1LIM,ST2LIM
INTEGER*2 K,K2
C
LOGICAL*1 STACK1(100,40),STACK2(100,40),FOUR(4),EIGHT(8)
LOGICAL*1 PLUS,MINUS
C
EQUIVALENCE (FOUR,INT),(EIGHT,REAL)
C
COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,
; ST1TYP,ST2TYP,ST1LIM,ST2LIM
C
DATA PLUS/0/,MINUS/1/
C
C
C
C
C
C
C
RETCD=1
K=ST2TYP(ST2PT-1)
K2=ST1TYP(ST1PT-1)
C
C
C MAKE SURE VARIABLE IS DEFINED
IF(K2.GT.0)GOTO 50
C IF NOT, PRINT MESSAGE AND RETURN
CALL ERRMSG(16)
GOTO 89999
C
C
C
50 J=K
C
C
C SEE IF IT IS A UNARY MINUS
IF (J.EQ.111) GOTO 100
C
C
C FUNCTIONS START AT 31
K=K-30
GOTO (100,100,300,400,500,400,10000),K
GOTO 10000
C
C
C ***************************************
C *** ABS (=DABS), IABS, AND UNARY - ***
C ***************************************
100 CONTINUE
IF(K2.GT.0)GO TO 105
CALL ERRMSG(16)
GO TO 89999
105 GOTO (110,120,130,130,140,140,140,130,120),K2
STOP 100
C
C
C ASCII
110 CALL ERRMSG (12)
GOTO 89999
C
C
C DECIMAL AND REAL
120 DO 121 I=1,8
121 EIGHT(I)=STACK1(I,ST1PT-1)
IF (K.NE.111) GOTO 123
C
C
C UNARY -
REAL=-REAL
GOTO 124
123 REAL=DABS(REAL)
124 DO 125 I=1,8
125 STACK1(I,ST1PT-1)=EIGHT(I)
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, AND OCTAL
130 DO 131 I=1,4
131 FOUR(I)=STACK1(I,ST1PT-1)
IF (K.NE.111) GOTO 133
INT=-INT
GO TO 134
133 INT=IABS(INT)
134 DO 135 I=1,4
135 STACK1(I,ST1PT-1)=FOUR(I)
GOTO 90000
C
C
C MULTIPLE PRECISION
140 IF (K.NE.111) GOTO 150
IF (STACK1(100,ST1PT-1).EQ.PLUS)GOTO 160
150 STACK1(100,ST1PT-1)=PLUS
GOTO 90000
160 STACK1(100,ST1PT-1)=MINUS
GOTO 90000
C
C
C ***************************************
C ************ FLOAT ******************
C ***************************************
300 CONTINUE
GOTO (310,320,330,330,340,340,340,330,320),K2
C
C
C ASCII
310 CALL ERRMSG(12)
GOTO 89999
C
C
C REAL (=DECIMAL)
320 CALL ERRMSG (13)
GOTO 89999
C
C
C INTEGER=HEXADECIMAL=OCTAL
330 DO 333 I=1,4
333 FOUR(I)=STACK1(I,ST1PT-1)
REAL=FLOAT(INT)
DO 335 I=1,8
335 STACK1(I,ST1PT-1)=EIGHT(I)
ST1TYP(ST1PT-1)=2
GOTO 90000
C
C
C MULTIPLE PRECISION
340 CALL ERRMSG (11)
GOTO 89999
C
C
C
C ***************************************
C ******* IFIX AND INT (=IDINT) *******
C ***************************************
400 CONTINUE
GOTO (410,420,430,430,440,440,440,430,420),K2
STOP 400
C
C
C ASCII
410 CALL ERRMSG (12)
GOTO 89999
C
C
C REAL AND DECIMAL
420 DO 421 I=1,8
421 EIGHT(I)=STACK1(I,ST1PT-1)
INT=IDINT(REAL)
DO 424 I=1,4
424 STACK1(I,ST1PT-1)=FOUR(I)
ST1TYP(ST1PT-1)=4
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, AND OCTAL
430 CALL ERRMSG (10)
GOTO 89999
C
C
C MULTIPLE PRECISION
440 CALL ERRMSG (11)
GOTO 89999
C
C
C
C ***************************************
C *************** AINT ****************
C ***************************************
C
C REAL TO REAL TRUNCATION
500 CONTINUE
GOTO (510,520,530,530,540,540,540,530,520),K2
C
C
C ASCII
510 CALL ERRMSG (12)
GOTO 89999
C
C
C REAL AND DECIMAL
520 DO 522 I=1,8
522 EIGHT(I)=STACK1(I,ST1PT-1)
C
C DON'T USE AINT(SNGL(REAL)) BECAUSE THEN
C 2.9999999 RESULTS IN 3.0
REAL=IDINT(REAL)
DO 524 I=1,8
524 STACK1(I,ST1PT-1)=EIGHT(I)
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, AND OCTAL
530 CALL ERRMSG (10)
GOTO 89999
C
C
C MULTIPLE PRECISION
540 CALL ERRMSG(11)
GOTO 89999
C
C
C
C
C ****************************************
C ****************************************
C ******** ********
C ******** REAL TO REAL FUNCTIONS ********
C ******** ********
C ******** EXP (=DEXP) ********
C ******** ALOG (=DLOG) ********
C ******** ALOG10 (=DLOG10) ********
C ******** SQRT (=DSQRT) ********
C ******** SIN (=DSIN) ********
C ******** COS (=DCOS) ********
C ******** TANH (DTANH) ********
C ******** ATAN (=DATAN) ********
C ******** ********
C ****************************************
C ****************************************
C
C
C
10000 CONTINUE
GOTO (11000,12000,15000,15000,15000,15000,15000,15000,12000),K2
STOP 10000
C
C
C ASCII
11000 CALL ERRMSG (12)
GOTO 89999
C
C
C REAL AND DECIMAL
12000 DO 12010 I=1,8
12010 EIGHT(I)=STACK1(I,ST1PT-1)
K=K-6
GOTO (12100,12200,12300,12400,12500,12600,12700,12800),K
C
C
C EXP
12100 REAL=DEXP(REAL)
GOTO 14000
C
C
C ALOG
12200 REAL=DLOG(REAL)
GOTO 14000
C
C
C DLOG10
12300 REAL=DLOG10(REAL)
GOTO 14000
C
C
C DSQRT
12400 IF (REAL.GE.0.D0) GOTO 12410
CALL ERRMSG (14)
GOTO 89999
12410 REAL=DSQRT (REAL)
GOTO 14000
C
C
C DSIN
12500 REAL=DSIN(REAL)
GOTO 14000
C
C
C DCOS
12600 REAL=DCOS(REAL)
GOTO 14000
C
C
C DTANH
12700 REAL=DTANH(REAL)
GOTO 14000
C
C
C DATAN
12800 REAL=DATAN(REAL)
14000 DO 14010 I=1,8
14010 STACK1(I,ST1PT-1)=EIGHT(I)
GOTO 90000
C
C
C INTEGER, HEXADECIMAL, OCTAL, AND MULTIPLE PRECISION
15000 CONTINUE
CALL CONTYP(STACK1,ST1PT-1,K2,2,RETCD2)
GO TO(15010,89999),RETCD2
STOP 15000
15010 ST1TYP(ST1PT-1)=2
GO TO 12000
C
C
C
C
C EXIT
89999 RETCD=2
90000 ST2PT=ST2PT-1
RETURN
END