SUBROUTINE CALUN(RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
	INCLUDE 'VKLUGPRM.FTN'
C	PARAMETER RRW = 32
C	PARAMETER RCL = 32
C RRW=MAX REAL ROWS
C RCL=MAX REAL COLS
C RRW MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED RRW,RCL
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
C	SUBROUTINE CALUN(RETCD)
	REAL*8 REAL
	REAL*8 DABS,DEXP,DLOG,DLOG10,DSQRT,DSIN,DCOS
	REAL*8 DTANH,DATAN
	REAL*8 DASIN,DACOS,DTAN
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(20,40),STACK2(20,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(20,ST1PT-1).EQ.PLUS)GOTO 160
150	STACK1(20,ST1PT-1)=PLUS
	GOTO 90000
160	STACK1(20,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,
     1  12840,12860,12880),K
C CODE 45 = ASIN, 46= ACOS, 47 = TAN
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
12405	CONTINUE
	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)
C
	GOTO 14000
C
C  ASIN
12840	CONTINUE
	IF(REAL.LT.-1.0.OR.REAL.GT.1.0) GOTO 12405
	REAL=DASIN(REAL)
	GOTO 14000
C
C  ACOS
12860	CONTINUE
	IF(REAL.LT.-1.0.OR.REAL.GT.1.0) GOTO 12405
	REAL=DACOS(REAL)
	GOTO 14000
C
C  TAN
12880	CONTINUE
	IF(REAL.GT.(1.570795))REAL=1.570795
	IF(REAL.LT.-1.570795) REAL=-1.570795
C GENERIC ERROR IF TOO NEAR PI/2. FORCE IT INTO VALID
C RANGE BY HAND TO PREVENT BLOWUPS.
	REAL=DTAN(REAL)
C	GOTO 14000
C (GOTO NOT NEEDED IF THIS IS LAST FUNCTION)

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