!*********************************************************************************************************************************** ! ! R P N ! ! Program: RPN ! ! Programmer: David G. Simpson ! NASA Goddard Space Flight Center ! Greenbelt, Maryland 20771 ! ! Date: December 28, 2005 ! ! Language: Fortran-95 ! ! Version: 1.01d (August 23, 2006) ! ! Description: Reverse Polish Notation (RPN) calculator. ! ! Files: Source file: ! ! rpn.f95 Main program ! ! Note: This program assumes that the COMPLEX(KIND=8) data type contains 8 bytes for the real component ! and 8 bytes for the imaginary component, for a total of 16 bytes. In other words, the real and ! imaginary components are both DOUBLE PRECISION types. ! ! Usage: Start the program, then enter numbers and operations separated by blanks or carriage returns. ! The contents of the X register will be printed after each carriage return. ! For example: ! ! X ! ! 2 3 + 5.0000 ! 6 * 30.0000 ! SIN 0.5000 ! ! To exit the program, type QUIT, Q, EXIT, OFF, BYE, STOP, or END. ! ! Available operations: ! ! + Addition ! - Subtraction ! * Multiplication ! / Division ! ^ Exponentiation ! \ Reciprocal ! % Percent ! %CHG Percent change ! ! Factorial (= GAMMA(n+1)) ! !! Double factorial ! 10X 10^x ! 2PI 2 * pi ! 2PII 2 * pi * i ! 2X 2^x ! A0 Bohr radius (m) ! ABS Absolute value ! ACOS Inverse cosine ! ACOSH Inverse hyperbolic cosine ! ACOT Inverse cotangent ! ACOT2 Inverse cotangent (2 args) ! ACOTH Inverse hyperbolic cotangent ! ACOVERS Inverse coversine ! ACRD Inverse chord (of Ptolemy) ! ACSC Inverse cosecant ! ACSCH Inverse hyperbolic cosecant ! AEXSEC Inverse exsecant ! AHAV Inverse haversine ! ALL ALL display mode ! AMU Atomic mass unit (kg) ! AND Logical AND ! ARG Argument of a complex number ! ASEC Inverse secant ! ASECH Inverse hyperbolic secant ! ASIN Inverse sine ! ASINH Inverse hyperbolic sine ! ATAN Inverse tangent ! ATAN2 Inverse tangent (2 args) ! ATANH Inverse hyperbolic tangent ! AU Astronomical unit (m) ! AVERS Inverse versine ! BESSELJ0 Bessel function of the first kind, order 0 ! BESSELJ1 Bessel function of the first kind, order 1 ! BESSELJ Bessel function of the first kind, real order ! BESSELY0 Bessel function of the second kind, order 0 ! BESSELY1 Bessel function of the second kind, order 1 ! BESSELY Bessel function of the second kind, real order ! BESSELI0 Modified Bessel function of the first kind, order 0 ! BESSELI1 Modified Bessel function of the first kind, order 1 ! BESSELI Modified Bessel function of the first kind, real order ! BESSELK0 Modified Bessel function of the second kind, order 0 ! BESSELK1 Modified Bessel function of the second kind, order 1 ! BESSELK Modified Bessel function of the second kind, real order ! BETA Beta function ! BIN Binary mode ! C Speed of light in vacuum (m/s) ! C>F Celsius to Fahrenheit ! CBRT Cube root ! CHS Change sign ! CLALL Clear all ! CLREG Clear general registers ! CLS Clear summation registers ! CLSTK Clear stack ! CLX Clear X ! CM>IN Centimeter to inches ! CNR Combinations ! COMPLEX COMPLEX mode ! CONJ Complex conjugate ! COS Cosine ! COSH Hyperbolic cosine ! COT Cotangent ! COTH Hyperbolic cotangent ! COVERS Coversine ! CRD Chord (of Ptolemy) ! CSC Cosecant ! CSCH Hyperbolic cosecant ! CUBE Cube ! D>F Decimal to fraction ! D>R Degrees to radians ! DEC Decimal mode ! DEFAULT Restore default modes ! DEG Degrees mode ! DIGAMMA Digamma function ! DUP Duplicate X ! ECHG Elementary charge e (C) ! ENG Engineering notation ! EPS0 Permittivity of free space (F/m) ! ERF Error function ! ERFC Complementary error function ! EULER Euler-Mascheroni constant ! EXP exp(x) ! EXSEC Exsecant ! F>C Fahrenheit to Celsius ! FIX Fix notation ! FRAC Fractional part ! FRACTOL Set fraction tolerance ! G Stamdard acceleration due to gravity (m/s^2) ! GAL>L Gallons to liters ! GAMMA Gamma function ! GCD Greatest common divisor ! GOLDEN Golden ratio ! GRAD Grads mode ! GRAV Gravitational constant G (m^3/kg s^2) ! H Planck constant (J s) ! H>HMS Hours to HMS ! HAV Haversine ! HBAR Planck constant (J s) ! HEX Hexadecimal mode ! HMS>H HMS to hours ! HMS+ HMS add ! HMS- HMS subtract ! HYPOT Compute SQRT(X^2+Y^2) ! HYPOT3 Compute SQRT(X^2+Y^2+Z^2) ! I i (imaginary unit) ! IM Imaginary component ! IMPROPER Improper fraction display mode ! IN>CM Inches to centimeters ! INT Integer part ! INT/ Integer division ! KB Boltzmann constant (J/K) ! KEPLER Solves elliptical Kepler's equation (e,M -> E) ! KG>LB Kilograms to pounds ! L>GAL Liters to gallons ! LASTX Recall last X ! LB>KG Pounds to kilograms ! LCM Least common multiple ! LN Natural logarithm ! LOG Common logarithm ! LOG2 Logarithm base 2 ! LR Linear regression (leaves b in X, m in Y) ! ME Electron mass (kg) ! MIXED Mixed fraction display mode ! MN Neutron mass (kg) ! MOD Modulo ! MODES Print modes ! MP Proton mass (kg) ! MU0 Permeability of free space (N/A^2) ! MUB Bohr magneton (A m^2) ! MUN Nuclear magneton (A m^2) ! N Number of points in summation ! NA Avogadro's number (mol^-1) ! NOT Logical NOT ! OCT Octal mode ! OR Logical OR ! P>R Polar to rectangular ! PI Pi ! PNR Permutations ! PR Print registers ! PS Print stack ! PSUMS Print sums ! R Roll stack down ! R>D Radians to degrees ! R>P Rectangular to polar ! RAD Radians mode ! RAND Random number ! RATIONAL Rational (fraction) mode ! RCL Recall ! RCORR Linear regression correlation coefficient ! RE Real component ! REAL REAL mode ! REARTH Earth radius (m) ! REDUCE Reduce an angle ! RESET Reset calculator to initial state ! REV Revs mode ! RGAS Gas constant (J/mol K) ! RI Exchange real and imaginary parts ! ROUND Round to integer ! RUP Roll stack up ! RZETA Riemann zeta function ! S Summation ! S- Delete summation ! SCI Scientific notation ! SEC Secant ! SECH Hyperbolic secant ! SEED Store random number seed ! SGN Signum ! SIN Sine ! SINC Sine cardinal (sinc) function ! SINH Hyperbolic sine ! SINHC Sinhc function ! SQR Square ! SQRT Square root ! STEFAN Stefan-Boltzmann constant (W/m^2 K^4) ! STO Store ! SUMX Summation of X ! SUMX2 Summation of X^2 ! SUMXY Summation of XY ! SUMY Summation of Y ! SUMY2 Summation of Y^2 ! TAN Tangent ! TANC Tanc function ! TANH Hyperbolic tangent ! TANHC Tanhc function ! TIME Current date and time ! VER Print software version ! VERS Versine ! X^ Linear estimate X ! XMEAN Mean of X ! XOR Logical XOR ! XRT X root of Y ! XS Sample standard deviation of X ! XSIG Population standard deviation of X ! XY X-Y exchange ! Y^ Linear estimate Y ! YMEAN Mean of Y ! YS Sample standard deviation of Y ! YSIG Population standard deviation of Y ! ! Possible future operations: ! ! ? Incomplete gamma functions (upper and lower) ! ? Incomplete beta function ! ? Jinc function ! ? Spherical Bessel functions j, n ! ? Legendre functions Pnm, Qnm (various normalizations) ! ? Legendre polynomials ! ? Elliptic integrals ! ? Jacobi elliptic functions sn, cn, dn ! ? Jacobi amplitude function am ! ? Exponential integrals ! ? Hypergeometric functions ! ? Hermite polynomials ! !*********************************************************************************************************************************** !*********************************************************************************************************************************** ! Global variables !*********************************************************************************************************************************** MODULE GLOBAL IMPLICIT NONE CHARACTER(LEN=*), PARAMETER :: VERSION = '1.01d' INTEGER, PARAMETER :: STACK_SIZE = 4 ! stack size INTEGER, PARAMETER :: REG_SIZE = 10 ! number of storage registers DOUBLE PRECISION, DIMENSION (STACK_SIZE) :: STACK ! real stack DOUBLE PRECISION, DIMENSION (0:REG_SIZE-1) :: REG ! real storage registers COMPLEX(KIND=8), DIMENSION (STACK_SIZE) :: CSTACK ! complex stack COMPLEX(KIND=8), DIMENSION (0:REG_SIZE-1) :: CREG ! complex storage registers INTEGER, DIMENSION (STACK_SIZE) :: RNSTACK, RDSTACK ! rational stack INTEGER, DIMENSION (0:REG_SIZE-1) :: RNREG, RDREG ! rational storage registers DOUBLE PRECISION :: LASTX ! real LAST X register COMPLEX(KIND=8) :: CLASTX ! complex LAST X register INTEGER :: RNLASTX, RDLASTX ! rational LAST X register DOUBLE PRECISION :: NN, SUMX, SUMX2, SUMY, SUMY2, SUMXY ! real summation registers COMPLEX(KIND=8) :: CNN, CSUMX, CSUMX2, CSUMY, CSUMY2, CSUMXY ! complex summation registers INTEGER :: RNNN, RNSUMX, RNSUMX2, RNSUMY, RNSUMY2, RNSUMXY ! rational summation registers (num.) INTEGER :: RDNN, RDSUMX, RDSUMX2, RDSUMY, RDSUMY2, RDSUMXY ! rational summation registers (den.) DOUBLE PRECISION :: ANGLE_FACTOR, FRACTOL INTEGER :: ANGLE_MODE, DISP_MODE, DISP_DIGITS, BASE_MODE, DOMAIN_MODE, & FRACTION_MODE INTEGER, PARAMETER :: INITIAL_ANGLE_MODE = 1 ! 1=deg 2=rad 3=grad 4=rev INTEGER, PARAMETER :: INITIAL_DISP_MODE = 4 ! 1=fix, 2=sci, 3=eng, 4=all INTEGER, PARAMETER :: INITIAL_DISP_DIGITS = 4 INTEGER, PARAMETER :: INITIAL_DOMAIN_MODE = 1 ! 1=real, 2=complex, 3=rational INTEGER, PARAMETER :: INITIAL_BASE_MODE = 10 ! 2=bin, 8=oct, 10=dec, 16=hex INTEGER, PARAMETER :: INITIAL_FRACTION_MODE = 1 ! 1=improper, 2=mixed DOUBLE PRECISION, PARAMETER :: INITIAL_FRACTOL = 1.0D-4 ! tolerance for decimal to fraction conversion END MODULE GLOBAL !*********************************************************************************************************************************** ! Main program !*********************************************************************************************************************************** PROGRAM RPN USE GLOBAL IMPLICIT NONE DOUBLE PRECISION, PARAMETER :: PI = 3.14159265358979323846264338327950288419716939937510582097494459230781640628620899862803D0 DOUBLE PRECISION, PARAMETER :: TWOPI = 6.28318530717958647692528676655900576839433879875021164194988918461563281257241799726D0 INTEGER :: I, IDX, IERR, DEL, PTR, RN, RD DOUBLE PRECISION :: X COMPLEX(KIND=8) :: CX CHARACTER(LEN=300) :: LINE, SUBSTR CHARACTER(LEN=100) :: FMTSTR, NUMSTR LOGICAL :: NUM_FLAG LOGICAL :: ISREAL, ISCOMPLEX, ISRATIONAL !----------------------------------------------------------------------------------------------------------------------------------- WRITE (UNIT=*, FMT='(/A/)') ' RPN Version '//VERSION ! ! Initialize data. ! DEL = IACHAR('a') - IACHAR('A') ! find ASCII position diff between 'A' and 'a' STACK = 0.0D0 ! clear the REAL stack REG = 0.0D0 ! clear the REAL registers LASTX = 0.0D0 ! clear the REAL LAST X register NN = 0.0D0 ! clear the REAL summation registers SUMX = 0.0D0 SUMX2 = 0.0D0 SUMY = 0.0D0 SUMY2 = 0.0D0 SUMXY = 0.0D0 CSTACK = (0.0D0,0.0D0) ! clear the COMPLEX stack CREG = (0.0D0,0.0D0) ! clear the COMPLEX registers CLASTX = (0.0D0,0.0D0) ! clear the COMPLEX LAST X register CNN = (0.0D0,0.0D0) ! clear the COMPLEX summation registers CSUMX = (0.0D0,0.0D0) CSUMX2 = (0.0D0,0.0D0) CSUMY = (0.0D0,0.0D0) CSUMY2 = (0.0D0,0.0D0) CSUMXY = (0.0D0,0.0D0) RNSTACK = 0; RDSTACK = 1 ! clear the RATIONAL stack RNREG = 0; RDREG = 1 ! clear the RATIONAL registers RNLASTX = 0; RDLASTX = 1 ! clear the RATIONAL LAST X register RNNN = 0; RDNN = 1 ! clear the RATIONAL summation registers RNSUMX = 0; RDSUMX = 1 RNSUMX2 = 0; RDSUMX2 = 1 RNSUMY = 0; RDSUMY = 1 RNSUMY2 = 0; RDSUMY2 = 1 RNSUMXY = 0; RDSUMXY = 1 ANGLE_MODE = INITIAL_ANGLE_MODE SELECT CASE (ANGLE_MODE) CASE (1) ! deg ANGLE_FACTOR = PI/180.0D0 CASE (2) ! rad ANGLE_FACTOR = 1.0D0 CASE (3) ! grad ANGLE_FACTOR = PI/200.0D0 CASE (4) ! rev ANGLE_FACTOR = TWOPI END SELECT DISP_MODE = INITIAL_DISP_MODE ! set modes DISP_DIGITS = INITIAL_DISP_DIGITS DOMAIN_MODE = INITIAL_DOMAIN_MODE BASE_MODE = INITIAL_BASE_MODE FRACTION_MODE = INITIAL_FRACTION_MODE FRACTOL = INITIAL_FRACTOL ! set decimal-to-fraction tolerance CALL RANDOM_SEED ! init random number generator ! ! Main loop. ! DO ! loop once for each input line WRITE (UNIT=*, FMT='(A)', ADVANCE='NO') ' ? ' READ (UNIT=*, FMT='(A)') LINE ! ! Convert the input line to all uppercase. ! LINE = ADJUSTL(LINE) ! remove leading blanks DO I = 1, LEN_TRIM(LINE) ! scan each character in line IF (LGE(LINE(I:I),'a') .AND. LLE(LINE(I:I),'z')) THEN ! if between 'a' and 'z'.. LINE(I:I) = ACHAR(IACHAR(LINE(I:I)) - DEL) ! ..then convert to uppercase END IF END DO ! ! Search for QUIT or its equivalent. ! IF (TRIM(LINE) .EQ. 'QUIT') EXIT IF (TRIM(LINE) .EQ. 'Q') EXIT IF (TRIM(LINE) .EQ. 'EXIT') EXIT IF (TRIM(LINE) .EQ. 'OFF') EXIT IF (TRIM(LINE) .EQ. 'BYE') EXIT IF (TRIM(LINE) .EQ. 'STOP') EXIT IF (TRIM(LINE) .EQ. 'END') EXIT PTR = 1 ! ! Loop for each element in the input line. ! DO IDX = INDEX(LINE(PTR:), ' ') + PTR - 1 ! look for the next space.. IF (IDX .EQ. 0) IDX = LEN(LINE(PTR:)) ! ..or end of line SUBSTR = LINE(PTR:IDX-1) ! get the current substring SELECT CASE (DOMAIN_MODE) CASE (1) NUM_FLAG = ISREAL (SUBSTR, X) ! convert to a real number, if possible CASE (2) NUM_FLAG = ISCOMPLEX (SUBSTR, CX) ! convert to a complex number, if possible CASE (3) NUM_FLAG = ISRATIONAL (SUBSTR, RN, RD) ! convert to a rational number, if possible END SELECT IF (NUM_FLAG) THEN ! if a number, then put it on the stack SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (X) ! push real number onto real stack CASE (2) CALL CPUSH_STACK (CX) ! push complex number onto complex stack CASE (3) CALL RPUSH_STACK (RN, RD) ! push rational number onto rational stack END SELECT ELSE ! else it's an operator CALL EVAL (SUBSTR) ! evaluate operator END IF PTR = IDX + 1 ! update line pointer IF (LEN_TRIM(LINE(PTR:)) .EQ. 0) EXIT ! exit if at end of line END DO ! ! Print X register. ! WRITE (UNIT=*, FMT='(A)') ' ' SELECT CASE (DOMAIN_MODE) CASE (1) CALL PRINTX(STACK(1), NUMSTR) ! format REAL X CASE (2) CALL CPRINTX(CSTACK(1), NUMSTR) ! format COMPLEX X CASE (3) CALL RPRINTX(RNSTACK(1), RDSTACK(1), NUMSTR) ! format RATIONAL X END SELECT WRITE (UNIT=*, FMT='(3X,A)') TRIM(NUMSTR) ! print X WRITE (UNIT=*, FMT='(A)') ' ' END DO STOP END PROGRAM RPN !*********************************************************************************************************************************** ! PUSH_STACK ! ! Push a number onto the real stack. !*********************************************************************************************************************************** SUBROUTINE PUSH_STACK (X) USE GLOBAL IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X INTEGER :: I DO I = STACK_SIZE, 2, -1 STACK(I) = STACK(I-1) END DO STACK(1) = X RETURN END SUBROUTINE PUSH_STACK !*********************************************************************************************************************************** ! CPUSH_STACK ! ! Push a number onto the complex stack. !*********************************************************************************************************************************** SUBROUTINE CPUSH_STACK (CX) USE GLOBAL IMPLICIT NONE COMPLEX(KIND=8), INTENT(IN) :: CX INTEGER :: I DO I = STACK_SIZE, 2, -1 CSTACK(I) = CSTACK(I-1) END DO CSTACK(1) = CX RETURN END SUBROUTINE CPUSH_STACK !*********************************************************************************************************************************** ! RPUSH_STACK ! ! Push a number onto the rational stack. !*********************************************************************************************************************************** SUBROUTINE RPUSH_STACK (RN,RD) USE GLOBAL IMPLICIT NONE INTEGER, INTENT(IN) :: RN,RD INTEGER :: I DO I = STACK_SIZE, 2, -1 RNSTACK(I) = RNSTACK(I-1) RDSTACK(I) = RDSTACK(I-1) END DO RNSTACK(1) = RN RDSTACK(1) = RD RETURN END SUBROUTINE RPUSH_STACK !*********************************************************************************************************************************** ! DROP_STACK ! ! Drop a number from the real stack. !*********************************************************************************************************************************** SUBROUTINE DROP_STACK (N) USE GLOBAL IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER :: I DO I = N, STACK_SIZE-1 STACK(I) = STACK(I+1) END DO RETURN END SUBROUTINE DROP_STACK !*********************************************************************************************************************************** ! CDROP_STACK ! ! Drop a number from the complex stack. !*********************************************************************************************************************************** SUBROUTINE CDROP_STACK (N) USE GLOBAL IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER :: I DO I = N, STACK_SIZE-1 CSTACK(I) = CSTACK(I+1) END DO RETURN END SUBROUTINE CDROP_STACK !*********************************************************************************************************************************** ! RDROP_STACK ! ! Drop a number from the rational stack. !*********************************************************************************************************************************** SUBROUTINE RDROP_STACK (N) USE GLOBAL IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER :: I DO I = N, STACK_SIZE-1 RNSTACK(I) = RNSTACK(I+1) RDSTACK(I) = RDSTACK(I+1) END DO RETURN END SUBROUTINE RDROP_STACK !*********************************************************************************************************************************** ! PRINTX ! ! Print a real number to a string. !*********************************************************************************************************************************** SUBROUTINE PRINTX (X, NUMSTR) USE GLOBAL IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X CHARACTER(LEN=100), INTENT(OUT) :: NUMSTR DOUBLE PRECISION :: TMPX CHARACTER(LEN=100) :: FMTSTR IF (BASE_MODE .EQ. 10) THEN ! DEC mode SELECT CASE (DISP_MODE) CASE (1) ! print X (FIX) WRITE (UNIT=FMTSTR, FMT='(1H(,4HF15.,I0,1H))') DISP_DIGITS WRITE (UNIT=NUMSTR, FMT=FMTSTR) X IF (INDEX(NUMSTR,'*') .NE. 0) THEN ! disp. overflow WRITE (UNIT=FMTSTR, FMT='(1H(,5HES15.,I0,1H))') DISP_DIGITS WRITE (UNIT=NUMSTR, FMT=FMTSTR) X END IF READ (UNIT=NUMSTR, FMT=*) TMPX IF ((X .NE. 0.0D0) .AND. (TMPX .EQ. 0.0D0)) THEN ! disp. underflow WRITE (UNIT=FMTSTR, FMT='(1H(,5HES15.,I0,1H))') DISP_DIGITS WRITE (UNIT=NUMSTR, FMT=FMTSTR) X END IF CASE (2) ! print X (SCI) WRITE (UNIT=FMTSTR, FMT='(1H(,5HES15.,I0,1H))') DISP_DIGITS WRITE (UNIT=NUMSTR, FMT=FMTSTR) X CASE (3) ! print X (ENG) WRITE (UNIT=FMTSTR, FMT='(1H(,5HEN15.,I0,1H))') DISP_DIGITS WRITE (UNIT=NUMSTR, FMT=FMTSTR) X CASE (4) ! print X (ALL) WRITE (UNIT=FMTSTR, FMT='(A)') '(1PG23.15)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) X END SELECT ELSE SELECT CASE (BASE_MODE) CASE (2) ! print X (BIN) WRITE (UNIT=FMTSTR, FMT='(A)') '(B0)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(X) CASE (8) ! print X (OCT) WRITE (UNIT=FMTSTR, FMT='(A)') '(O0)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(X) CASE (16) ! print X (HEX) WRITE (UNIT=FMTSTR, FMT='(A)') '(Z0)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(X) END SELECT END IF RETURN END SUBROUTINE PRINTX !*********************************************************************************************************************************** ! CPRINTX ! ! Print a complex number to a string. !*********************************************************************************************************************************** SUBROUTINE CPRINTX (X, NUMSTR) USE GLOBAL IMPLICIT NONE COMPLEX(KIND=8), INTENT(IN) :: X CHARACTER(LEN=100), INTENT(OUT) :: NUMSTR COMPLEX(KIND=8) :: TMPX CHARACTER(LEN=100) :: FMTSTR IF (BASE_MODE .EQ. 10) THEN ! DEC mode SELECT CASE (DISP_MODE) CASE (1) ! print X (FIX) WRITE (UNIT=FMTSTR, FMT=800) DISP_DIGITS, DISP_DIGITS 800 FORMAT ("(ES25.",I0,",SP,4X,F25.",I0,",2H i)") WRITE (UNIT=NUMSTR, FMT=FMTSTR) DBLE(X), AIMAG(X) IF (INDEX(NUMSTR,'*') .NE. 0) THEN ! disp. overflow WRITE (UNIT=FMTSTR, FMT=810) DISP_DIGITS, DISP_DIGITS 810 FORMAT ("(EN25.",I0,",SP,4X,ES25.",I0,",2H i)") WRITE (UNIT=NUMSTR, FMT=FMTSTR) DBLE(X), AIMAG(X) END IF READ (UNIT=NUMSTR, FMT=*) TMPX IF ((X .NE. 0.0D0) .AND. (TMPX .EQ. 0.0D0)) THEN ! disp. underflow WRITE (UNIT=FMTSTR, FMT=820) DISP_DIGITS, DISP_DIGITS 820 FORMAT ("(EN25.",I0,",SP,4X,ES25.",I0,",2H i)") WRITE (UNIT=NUMSTR, FMT=FMTSTR) DBLE(X), AIMAG(X) END IF CASE (2) ! print X (SCI) WRITE (UNIT=FMTSTR, FMT=830) DISP_DIGITS, DISP_DIGITS 830 FORMAT ("(ES25.",I0,",SP,4X,ES25.",I0,",2H i)") WRITE (UNIT=NUMSTR, FMT=FMTSTR) DBLE(X), AIMAG(X) CASE (3) ! print X (ENG) WRITE (UNIT=FMTSTR, FMT=840) DISP_DIGITS, DISP_DIGITS 840 FORMAT ("(EN25.",I0,",SP,4X,ES25.",I0,",2H i)") WRITE (UNIT=NUMSTR, FMT=FMTSTR) DBLE(X), AIMAG(X) CASE (4) ! print X (ALL) WRITE (UNIT=FMTSTR, FMT='(A)') '(1PG23.15,SP,4X,G23.15,2H i)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) DBLE(X), AIMAG(X) END SELECT ELSE SELECT CASE (BASE_MODE) CASE (2) ! print X (BIN) WRITE (UNIT=FMTSTR, FMT='(A)') '(B0,4X,B0,2H i)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(DBLE(X)), INT(AIMAG(X)) CASE (8) ! print X (OCT) WRITE (UNIT=FMTSTR, FMT='(A)') '(O0,4X,O0,2H i)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(DBLE(X)), INT(AIMAG(X)) CASE (16) ! print X (HEX) WRITE (UNIT=FMTSTR, FMT='(A)') '(Z0,4X,Z0,2H i)' WRITE (UNIT=NUMSTR, FMT=FMTSTR) INT(DBLE(X)), INT(AIMAG(X)) END SELECT END IF RETURN END SUBROUTINE CPRINTX !*********************************************************************************************************************************** ! RPRINTX ! ! Print a rational number to a string. !*********************************************************************************************************************************** SUBROUTINE RPRINTX (RN, RD, NUMSTR) USE GLOBAL IMPLICIT NONE INTEGER, INTENT(IN) :: RN, RD CHARACTER(LEN=100), INTENT(OUT) :: NUMSTR INTEGER :: A1, A2, A3 SELECT CASE (BASE_MODE) CASE (2) ! print X (BIN) IF (RD .EQ. 1) THEN WRITE (UNIT=NUMSTR, FMT='(B0)') RN ELSE SELECT CASE (FRACTION_MODE) CASE (1) WRITE (UNIT=NUMSTR, FMT='(B0,3H / ,B0)') RN, RD CASE (2) CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3) WRITE (UNIT=NUMSTR, FMT='(B0,3X,B0,3H / ,B0)') A1, A2, A3 END SELECT END IF CASE (8) ! print X (OCT) IF (RD .EQ. 1) THEN WRITE (UNIT=NUMSTR, FMT='(O0)') RN ELSE SELECT CASE (FRACTION_MODE) CASE (1) WRITE (UNIT=NUMSTR, FMT='(O0,3H / ,O0)') RN, RD CASE (2) CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3) WRITE (UNIT=NUMSTR, FMT='(O0,3X,O0,3H / ,O0)') A1, A2, A3 END SELECT END IF CASE (10) ! print X (DEC) IF (RD .EQ. 1) THEN WRITE (UNIT=NUMSTR, FMT='(I0)') RN ELSE SELECT CASE (FRACTION_MODE) CASE (1) WRITE (UNIT=NUMSTR, FMT='(I0,3H / ,I0)') RN, RD CASE (2) CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3) WRITE (UNIT=NUMSTR, FMT='(I0,3X,I0,3H / ,I0)') A1, A2, A3 END SELECT END IF CASE (16) ! print X (HEX) IF (RD .EQ. 1) THEN WRITE (UNIT=NUMSTR, FMT='(Z0)') RN ELSE SELECT CASE (FRACTION_MODE) CASE (1) WRITE (UNIT=NUMSTR, FMT='(Z0,3H / ,Z0)') RN, RD CASE (2) CALL FRAC_TO_MIXED (RN, RD, A1, A2, A3) WRITE (UNIT=NUMSTR, FMT='(Z0,3X,Z0,3H / ,Z0)') A1, A2, A3 END SELECT END IF ! CASE (16) ! print X (HEX) ! IF (RD .EQ. 1) THEN ! WRITE (UNIT=NUMSTR, FMT='(Z0)') RN ! ELSE ! WRITE (UNIT=NUMSTR, FMT='(Z0,3H / ,Z0)') RN, RD ! END IF END SELECT RETURN END SUBROUTINE RPRINTX !*********************************************************************************************************************************** ! EVAL ! ! Evaluate a operation. !*********************************************************************************************************************************** SUBROUTINE EVAL (STR) USE GLOBAL IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: STR DOUBLE PRECISION, PARAMETER :: PI = 3.14159265358979323846264338327950288419716939937510582097494459230781640628620899862803D0 DOUBLE PRECISION, PARAMETER :: TWOPI = 6.28318530717958647692528676655900576839433879875021164194988918461563281257241799726D0 DOUBLE PRECISION, PARAMETER :: LN2 = 0.6931471805599453094172321214581765680755001343602552541206800094933936219696947156059D0 DOUBLE PRECISION, PARAMETER :: EULER = 0.57721566490153286060651209008240243104215933593992359880576723488486772677766467094D0 DOUBLE PRECISION, PARAMETER :: GOLDEN = 1.6180339887498948482045868343656381177203091798057628621354486227052604628189024497D0 COMPLEX(KIND=8), PARAMETER :: II = (0.0D0,1.0D0) DOUBLE PRECISION, PARAMETER :: KG_PER_LB = 0.45359237D0 DOUBLE PRECISION, PARAMETER :: CM_PER_IN = 2.54D0 DOUBLE PRECISION, PARAMETER :: L_PER_GAL = 3.785411784D0 DOUBLE PRECISION, PARAMETER :: A0 = 0.5291772108D-10 ! m DOUBLE PRECISION, PARAMETER :: AMU = 1.66053886D-27 ! kg DOUBLE PRECISION, PARAMETER :: AU = 1.49597870D11 ! m DOUBLE PRECISION, PARAMETER :: C = 299792458.0D0 ! m/s DOUBLE PRECISION, PARAMETER :: ECHG = 1.60217653D-19 ! C DOUBLE PRECISION, PARAMETER :: EPS0 = 8.8541878176203898505D-12 ! F/m DOUBLE PRECISION, PARAMETER :: G = 9.80665D0 ! m/s^2 DOUBLE PRECISION, PARAMETER :: GRAV = 6.6742D-11 ! m^3/kg s^2 DOUBLE PRECISION, PARAMETER :: H = 6.6260693D-34 ! J s DOUBLE PRECISION, PARAMETER :: HBAR = 1.05457168D-34 ! J s DOUBLE PRECISION, PARAMETER :: KB = 1.3806505D-23 ! J/K DOUBLE PRECISION, PARAMETER :: ME = 9.1093826D-31 ! kg DOUBLE PRECISION, PARAMETER :: MN = 1.67492728D-27 ! kg DOUBLE PRECISION, PARAMETER :: MP = 1.67262171D-27 ! kg DOUBLE PRECISION, PARAMETER :: MU0 = 12.5663706143591729539D-7 ! N/A^2 DOUBLE PRECISION, PARAMETER :: MUB = 927.400949D-26 ! A m^2 DOUBLE PRECISION, PARAMETER :: MUN = 5.05078343D-27 ! A m^2 DOUBLE PRECISION, PARAMETER :: NA = 6.0221415D23 ! mol^-1 DOUBLE PRECISION, PARAMETER :: REARTH = 6378140.0D0 ! m DOUBLE PRECISION, PARAMETER :: RGAS = 8.314472D0 ! J/mol K DOUBLE PRECISION, PARAMETER :: STEFAN = 5.670400D-8 ! W/m^2 K^4 INTEGER :: I, J, ITMP, ITMP2, IERR, NUM, DEN, NUM2, DEN2, NUM3, DEN3, NUM4, DEN4, & NUMM, DENM, NUMB, DENB DOUBLE PRECISION :: TMP, TMP2, TMP3, TMPM, TMPB, TMPR, BES_X, BES_ALPHA COMPLEX(KIND=8) :: CTMP, CTMP2, CTMP3, CTMPM, CTMPB, CTMPR CHARACTER(LEN=2) :: REGNAME INTEGER :: DT(8) INTEGER :: YEAR, MONTH, DAY, HOUR, MINUTE, SECOND, BES_NB, BES_NCALC CHARACTER(LEN=100) :: FMTSTR, NUMSTR CHARACTER(LEN=10) :: TIME, DATE, ZONE INTEGER :: RINT, GCD, LCM DOUBLE PRECISION :: DGAMMA, BETA, PSI, FRAC, CUBEROOT, SEC, CSC, COT, EXSEC, VERS, COVERS, HAV, & CRD, ASEC, ACSC, ACOT, ACOT2, AEXSEC, AVERS, ACOVERS, AHAV, ACRD, SECH, CSCH, COTH, ASINH, & ACOSH, ATANH, ASECH, ACSCH, ACOTH, SINC, SINHC, TANC, TANHC, DERF, DERFC, RIEMANNZETA, CNR, & PNR, REDUCE, KEPLER, BESJ0, BESJ1, BESY0, BESY1, BESI0, BESI1, BESK0, BESK1 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BES_B COMPLEX(KIND=8) :: CFRAC, CCUBEROOT, CTAN, CSEC, CCSC, CCOT, CEXSEC, CVERS, CCOVERS, CHAV, CCRD, & CSINH, CCOSH, CTANH, CSECH, CCSCH, CCOTH, CASIN, CACOS, CATAN, CASEC, CACSC, CACOT, CAEXSEC, & CAVERS, CACOVERS, CAHAV, CACRD, CASINH, CACOSH, CATANH, CASECH, CACSCH, CACOTH, CSINC, & CSINHC, CTANC, CTANHC, CMOD, CINT, CLOG10, CGAMMA, CBETA LOGICAL :: ISFRAC, ISINT EXTERNAL DGAMMA IF (LEN_TRIM(STR) .EQ. 0) THEN CONTINUE ELSE IF (TRIM(STR) .EQ. '+') THEN ! + SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(2) + STACK(1) CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(2) + CSTACK(1) CALL CDROP_STACK(2) CASE (3) CALL RADD (RNSTACK(2),RDSTACK(2),RNSTACK(1),RDSTACK(1),NUM,DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN CALL RDROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. '-') THEN ! - SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(2) - STACK(1) CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(2) - CSTACK(1) CALL CDROP_STACK(2) CASE (3) CALL RSUB (RNSTACK(2),RDSTACK(2),RNSTACK(1),RDSTACK(1),NUM,DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN CALL RDROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. '*') THEN ! * SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(2) * STACK(1) CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(2) * CSTACK(1) CALL CDROP_STACK(2) CASE (3) CALL RMUL (RNSTACK(2),RDSTACK(2),RNSTACK(1),RDSTACK(1),NUM,DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN CALL RDROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. '/') THEN ! / SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .EQ. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' Divide Error' ELSE LASTX = STACK(1) STACK(1) = STACK(2) / STACK(1) CALL DROP_STACK(2) END IF CASE (2) IF (CSTACK(1) .EQ. (0.0,0.0)) THEN WRITE (UNIT=*, FMT='(A)') ' Divide Error' ELSE CLASTX = CSTACK(1) CSTACK(1) = CSTACK(2) / CSTACK(1) CALL CDROP_STACK(2) END IF CASE (3) CALL RDIV (RNSTACK(2),RDSTACK(2),RNSTACK(1),RDSTACK(1),NUM,DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN CALL RDROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. '^') THEN ! ^ SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(2) ** STACK(1) CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(2) ** CSTACK(1) CALL CDROP_STACK(2) CASE (3) IF (RDSTACK(1) .EQ. 1) THEN RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = RNSTACK(2) ** RNLASTX RDSTACK(1) = RDSTACK(2) ** RNLASTX CALL RDROP_STACK(2) ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = STACK(2) ** STACK(1) CALL DROP_STACK(2) END IF END SELECT ELSE IF (TRIM(STR) .EQ. '\') THEN ! \ SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .EQ. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' Divide Error' ELSE LASTX = STACK(1) STACK(1) = 1.0D0 / STACK(1) END IF CASE (2) IF (CSTACK(1) .EQ. (0.0,0.0)) THEN WRITE (UNIT=*, FMT='(A)') ' Divide Error' ELSE CLASTX = CSTACK(1) CSTACK(1) = (1.0,0.0) / CSTACK(1) END IF CASE (3) CALL RDIV (1,1,RNSTACK(1),RDSTACK(1),NUM,DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN END SELECT ELSE IF (TRIM(STR) .EQ. '%') THEN ! % SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(2) * 1.0D-2*STACK(1) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(2) * 1.0D-2*CSTACK(1) CASE (3) NUM = RNSTACK(1) DEN = RDSTACK(1) NUM2 = RNSTACK(2) DEN2 = RDSTACK(2) CALL RMUL(NUM2,DEN2,NUM,DEN,ITMP,ITMP2) CALL RMUL(ITMP,ITMP2,1,100,NUM,DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN END SELECT ELSE IF (TRIM(STR) .EQ. '%CHG') THEN ! %CHG SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(2) .EQ. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' Divide Error' ELSE LASTX = STACK(1) STACK(1) = 100.0D0*(STACK(1)-STACK(2))/STACK(2) END IF CASE (2) IF (CSTACK(2) .EQ. (0.0D0,0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' Divide Error' ELSE CLASTX = CSTACK(1) CSTACK(1) = 100.0D0*(CSTACK(1)-CSTACK(2))/CSTACK(2) END IF CASE (3) NUM = RNSTACK(1) DEN = RDSTACK(1) NUM2 = RNSTACK(2) DEN2 = RDSTACK(2) CALL RSUB(NUM,DEN,NUM2,DEN2,ITMP,ITMP2) CALL RDIV(ITMP,ITMP2,NUM2,DEN2,NUM,DEN) CALL RMUL(NUM,DEN,100,1,NUM2,DEN2) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM2 RDSTACK(1) = DEN2 END SELECT ELSE IF (TRIM(STR) .EQ. '!') THEN ! ! SELECT CASE (DOMAIN_MODE) CASE (1) IF (ISINT(STACK(1)).AND.(STACK(1).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' Factorial Error' ELSE LASTX = STACK(1) STACK(1) = DGAMMA(STACK(1)+1.0D0) END IF CASE (2) IF (CSTACK(1) .EQ. (-1.0D0,0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' Factorial Error' ELSE CLASTX = CSTACK(1) CSTACK(1) = CGAMMA(CSTACK(1)+(1.0D0,0.0D0)) END IF CASE (3) IF ((RDSTACK(1).EQ.1).AND.(RNSTACK(1).LT.0)) THEN WRITE (UNIT=*, FMT='(A)') ' Factorial Error' ELSE IF (RDSTACK(1).EQ.1) THEN ITMP = RNSTACK(1) IF (ITMP.LT.0) THEN WRITE (UNIT=*, FMT='(A)') ' Factorial Error' ELSE ITMP2 = 1 DO I = 2, ITMP ITMP2 = ITMP2 * I END DO RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = ITMP2 RDSTACK(1) = 1 END IF ELSE CALL SWITCH_RAT_TO_REAL IF (ISINT(STACK(1)).AND.(STACK(1).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' Factorial Error' ELSE LASTX = STACK(1) STACK(1) = DGAMMA(STACK(1)+1.0D0) END IF END IF END IF END SELECT ELSE IF (TRIM(STR) .EQ. '!!') THEN ! !! SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .LT. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' !! Error' ELSE IF (ISFRAC(STACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' !! Error' ELSE IF (NINT(STACK(1)) .EQ. 0.0D0) THEN LASTX = STACK(1) STACK(1) = 1.0D0 ELSE LASTX = STACK(1) ITMP = NINT(STACK(1)) STACK(1) = 1.0D0 DO STACK(1) = STACK(1) * ITMP ITMP = ITMP - 2 IF (ITMP .LE. 1) EXIT END DO END IF CASE (2) IF (DBLE(CSTACK(1)) .LT. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' !! Error' ELSE IF (AIMAG(CSTACK(1)) .NE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' !! Error' ELSE IF (ISFRAC(DBLE(CSTACK(1)))) THEN WRITE (UNIT=*, FMT='(A)') ' !! Error' ELSE IF (NINT(DBLE(CSTACK(1))) .EQ. 0.0D0) THEN CLASTX = CSTACK(1) CSTACK(1) = (1.0D0,0.0D0) ELSE CLASTX = CSTACK(1) ITMP = NINT(DBLE(CSTACK(1))) TMP = 1.0D0 DO TMP = TMP * ITMP ITMP = ITMP - 2 IF (ITMP .LE. 1) EXIT END DO CSTACK(1) = CMPLX(TMP,0.0D0,8) END IF CASE (3) IF (RNSTACK(1) .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' !! Error' ELSE IF (RDSTACK(1) .NE. 1) THEN WRITE (UNIT=*, FMT='(A)') ' !! Error' ELSE IF (RNSTACK(1) .EQ. 0) THEN RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = 1 RDSTACK(1) = 1 ELSE RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) ITMP = RNSTACK(1) RNSTACK(1) = 1 RDSTACK(1) = 1 DO RNSTACK(1) = RNSTACK(1) * ITMP ITMP = ITMP - 2 IF (ITMP .LE. 1) EXIT END DO END IF END SELECT ELSE IF (TRIM(STR) .EQ. '10X') THEN ! 10X SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = 10.0D0**(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = 10.0D0**(CSTACK(1)) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = 10.0D0**(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. '2PI') THEN ! 2PI SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (TWOPI) CASE (2) CALL CPUSH_STACK (CMPLX(TWOPI,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (TWOPI) END SELECT ELSE IF (TRIM(STR) .EQ. '2PII') THEN ! 2PII SELECT CASE (DOMAIN_MODE) CASE (1) WRITE (UNIT=*, FMT='(A)') ' 2PIi not available in REAL mode' CASE (2) CALL CPUSH_STACK (CMPLX(0.0D0,TWOPI,8)) CASE (3) WRITE (UNIT=*, FMT='(A)') ' 2PIi not available in RATIONAL mode' END SELECT ELSE IF (TRIM(STR) .EQ. '2X') THEN ! 2X SELECT CASE (DOMAIN_MODE) CASE (1) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = 2.0D0**(CSTACK(1)) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = 2.0D0**(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'A0') THEN ! A0 SELECT CASE (DOMAIN_MODE) CASE (1) CASE (2) CALL CPUSH_STACK (CMPLX(A0,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (A0) END SELECT ELSE IF (TRIM(STR) .EQ. 'ABS') THEN ! ABS SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = ABS(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CMPLX(ABS(CSTACK(1)),0.0D0,8) CASE (3) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = ABS(RNSTACK(1)) RDSTACK(1) = ABS(RDSTACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'ACOS') THEN ! ACOS SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(STACK(1)) .GT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ACOS Error' ELSE LASTX = STACK(1) STACK(1) = ACOS(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACOS(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .GT. ABS(RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' ACOS Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACOS(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ACOSH') THEN ! ACOSH SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .LT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ACOSH Error' ELSE LASTX = STACK(1) STACK(1) = ACOSH(STACK(1)) END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACOSH(CSTACK(1)) CASE (3) IF (RNSTACK(1) .LT. RDSTACK(1)) THEN WRITE (UNIT=*, FMT='(A)') ' ACOSH Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACOSH(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ACOT') THEN ! ACOT SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = ACOT(STACK(1))/ANGLE_FACTOR CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACOT(CSTACK(1))/ANGLE_FACTOR CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACOT(STACK(1))/ANGLE_FACTOR END SELECT ELSE IF (TRIM(STR) .EQ. 'ACOT2') THEN ! ACOT2 SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = ACOT2(STACK(2),STACK(1))/ANGLE_FACTOR CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACOT(CSTACK(2)/CSTACK(1))/ANGLE_FACTOR CALL CDROP_STACK(2) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACOT2(STACK(2),STACK(1))/ANGLE_FACTOR CALL DROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. 'ACOTH') THEN ! ACOTH SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .EQ. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ACOTH Error' ELSE LASTX = STACK(1) STACK(1) = ACOTH(STACK(1)) END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACOTH(CSTACK(1)) CASE (3) IF (RNSTACK(1) .EQ. 0) THEN WRITE (UNIT=*, FMT='(A)') ' ACOTH Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACOTH(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ACOVERS') THEN ! ACOVERS SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(1.0D0-STACK(1)) .GT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ACOVERS Error' ELSE LASTX = STACK(1) STACK(1) = ACOVERS(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACOVERS(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' ACOVERS Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACOVERS(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ACRD') THEN ! ACRD SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(STACK(1)) .GT. 2.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ACRD Error' ELSE LASTX = STACK(1) STACK(1) = ACRD(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACRD(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .GT. 2*ABS(RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' ACRD Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACRD(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ACSC') THEN ! ACSC SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(STACK(1)) .LT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ACSC Error' ELSE LASTX = STACK(1) STACK(1) = ACSC(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACSC(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .LT. ABS(RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' ACSC Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACSC(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ACSCH') THEN ! ACSCH SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .EQ. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ACSCH Error' ELSE LASTX = STACK(1) STACK(1) = ACSCH(STACK(1)) END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CACSCH(CSTACK(1)) CASE (3) IF (RNSTACK(1) .EQ. 0) THEN WRITE (UNIT=*, FMT='(A)') ' ACSCH Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ACSCH(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'AEXSEC') THEN ! AEXSEC SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(STACK(1)+1.0D0) .LT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' AEXSEC Error' ELSE LASTX = STACK(1) STACK(1) = AEXSEC(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CAEXSEC(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' AEXSEC Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = AEXSEC(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'AHAV') THEN ! AHAV SELECT CASE (DOMAIN_MODE) CASE (1) IF ((STACK(1).LT.0.0D0).OR.(STACK(1).GT.1.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' AHAV Error' ELSE LASTX = STACK(1) STACK(1) = AHAV(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CAHAV(CSTACK(1))/ANGLE_FACTOR CASE (3) IF ((RNSTACK(1).LT.0).OR.(RNSTACK(1).GT.RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' AHAV Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = AHAV(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (STR(1:3) .EQ. 'ALL') THEN ! ALL DISP_MODE = 4 ELSE IF (TRIM(STR) .EQ. 'AMU') THEN ! AMU SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (AMU) CASE (2) CALL CPUSH_STACK (CMPLX(AMU,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (AMU) END SELECT ELSE IF (TRIM(STR) .EQ. 'AND') THEN ! AND SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = IAND (INT(STACK(2)), INT(STACK(1))) CALL DROP_STACK(2) CASE (2) TMP = IAND (INT(DBLE(CSTACK(2))), INT(DBLE(CSTACK(1)))) TMP2 = IAND (INT(AIMAG(CSTACK(2))), INT(AIMAG(CSTACK(1)))) CLASTX = CSTACK(1) CSTACK(1) = CMPLX(TMP,TMP2,8) CALL CDROP_STACK(2) CASE (3) ITMP = RNSTACK(1)/RDSTACK(1) ITMP2 = RNSTACK(2)/RDSTACK(2) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = IAND (ITMP2, ITMP) RDSTACK(1) = 1 CALL RDROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. 'ARG') THEN ! ARG SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = 0.0D0 CASE (2) TMP = ATAN2(AIMAG(CSTACK(1)),DBLE(CSTACK(1)))/ANGLE_FACTOR CLASTX = CSTACK(1) CSTACK(1) = CMPLX(TMP,0.0D0,8) CASE (3) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = 0 RDSTACK(1) = 1 END SELECT ELSE IF (TRIM(STR) .EQ. 'ASEC') THEN ! ASEC SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(STACK(1)) .LT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ASEC Error' ELSE LASTX = STACK(1) STACK(1) = ASEC(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CASEC(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .LT. ABS(RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' ASEC Error' ELSE CALL SWITCH_RAT_TO_REAL RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) STACK(1) = ASEC(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ASECH') THEN ! ASECH SELECT CASE (DOMAIN_MODE) CASE (1) IF ((STACK(1).LE.0.0D0).OR.(STACK(1).GT.1.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' ASECH Error' ELSE LASTX = STACK(1) STACK(1) = ASECH(STACK(1)) END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CASECH(CSTACK(1)) CASE (3) IF ((RNSTACK(1).LE.0).OR.(RNSTACK(1).GT.RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' ASECH Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ASECH(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ASIN') THEN ! ASIN SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(STACK(1)) .GT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ASIN Error' ELSE LASTX = STACK(1) STACK(1) = ASIN(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CASIN(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .GT. ABS(RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' ASIN Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ASIN(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'ASINH') THEN ! ASINH SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = ASINH(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CASINH(CSTACK(1)) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ASINH(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'ATAN') THEN ! ATAN SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = ATAN(STACK(1))/ANGLE_FACTOR CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CATAN(CSTACK(1))/ANGLE_FACTOR CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ATAN(STACK(1))/ANGLE_FACTOR END SELECT ELSE IF (TRIM(STR) .EQ. 'ATAN2') THEN ! ATAN2 SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = ATAN2(STACK(2),STACK(1))/ANGLE_FACTOR CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CATAN(CSTACK(2)/CSTACK(1))/ANGLE_FACTOR CALL CDROP_STACK(2) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ATAN2(STACK(2),STACK(1))/ANGLE_FACTOR CALL DROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. 'ATANH') THEN ! ATANH SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(STACK(1)) .GE. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' ATANH Error' ELSE LASTX = STACK(1) STACK(1) = ATANH(STACK(1)) END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CATANH(CSTACK(1)) CASE (3) IF (ABS(RNSTACK(1)) .GE. ABS(RDSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' ATANH Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = ATANH(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'AU') THEN ! AU SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (AU) CASE (2) CALL CPUSH_STACK (CMPLX(AU,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (AU) END SELECT ELSE IF (TRIM(STR) .EQ. 'AVERS') THEN ! AVERS SELECT CASE (DOMAIN_MODE) CASE (1) IF (ABS(1.0D0-STACK(1)) .GT. 1.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' AVERS Error' ELSE LASTX = STACK(1) STACK(1) = AVERS(STACK(1))/ANGLE_FACTOR END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CAVERS(CSTACK(1))/ANGLE_FACTOR CASE (3) IF (ABS(RNSTACK(1)) .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' AVERS Error' ELSE CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = AVERS(STACK(1))/ANGLE_FACTOR END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELJ0') THEN ! BESSELJ0 SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = BESJ0(STACK(1)) CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELJ0 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = BESJ0(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELJ1') THEN ! BESSELJ1 SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = BESJ1(STACK(1)) CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELJ1 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = BESJ1(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELJ') THEN ! BESSELJ SELECT CASE (DOMAIN_MODE) CASE (1) IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELJ Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RJBESL(BES_X, BES_ALPHA, BES_NB, BES_B, BES_NCALC) IF (BES_NCALC .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELJ Error 2' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELJ Error 3' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELJ not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELJ Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RJBESL(BES_X, BES_ALPHA, BES_NB, BES_B, BES_NCALC) IF (BES_NCALC .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELJ Error 2' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELJ Error 3' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELY0') THEN ! BESSELY0 SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY0 Error' ELSE LASTX = STACK(1) STACK(1) = BESY0(STACK(1)) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELY0 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY0 Error' ELSE LASTX = STACK(1) STACK(1) = BESY0(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELY1') THEN ! BESSELY1 SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY1 Error' ELSE LASTX = STACK(1) STACK(1) = BESY1(STACK(1)) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELY1 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY1 Error' ELSE LASTX = STACK(1) STACK(1) = BESY1(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELY') THEN ! BESSELY SELECT CASE (DOMAIN_MODE) CASE (1) IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RYBESL(BES_X, BES_ALPHA, BES_NB, BES_B, BES_NCALC) IF (BES_NCALC .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY Error 2' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY Error 3' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELY not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RYBESL(BES_X, BES_ALPHA, BES_NB, BES_B, BES_NCALC) IF (BES_NCALC .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY Error 2' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELY Error 3' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELI0') THEN ! BESSELI0 SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = BESI0(STACK(1)) CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELI0 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = BESI0(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELI1') THEN ! BESSELI1 SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = BESI1(STACK(1)) CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELI1 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = BESI1(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELI') THEN ! BESSELI SELECT CASE (DOMAIN_MODE) CASE (1) IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELI Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RIBESL(BES_X, BES_ALPHA, BES_NB, 1, BES_B, BES_NCALC) IF (BES_NCALC .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELI Error 2' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELI Error 3' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELI not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELI Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RIBESL(BES_X, BES_ALPHA, BES_NB, 1, BES_B, BES_NCALC) IF (BES_NCALC .LT. 0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELI Error 2' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELI Error 3' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELK0') THEN ! BESSELK0 SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK0 Error' ELSE LASTX = STACK(1) STACK(1) = BESK0(STACK(1)) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELK0 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK0 Error' ELSE LASTX = STACK(1) STACK(1) = BESK0(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELK1') THEN ! BESSELK1 SELECT CASE (DOMAIN_MODE) CASE (1) IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK1 Error' ELSE LASTX = STACK(1) STACK(1) = BESK1(STACK(1)) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELK1 not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF (STACK(1) .LE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK1 Error' ELSE LASTX = STACK(1) STACK(1) = BESK1(STACK(1)) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BESSELK') THEN ! BESSELK SELECT CASE (DOMAIN_MODE) CASE (1) IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RKBESL(BES_X, BES_ALPHA, BES_NB, 1, BES_B, BES_NCALC) IF (BES_NCALC .LT. -1) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 2' ELSE IF (BES_NCALC .EQ. -1) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 3' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 4' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF CASE (2) WRITE (UNIT=*, FMT='(A)') ' Error: BESSELK not available '// & 'in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 1' ELSE BES_X = STACK(1) BES_NB = INT(STACK(2)) + 1 BES_ALPHA = FRAC(STACK(2)) ALLOCATE (BES_B(BES_NB)) CALL RKBESL(BES_X, BES_ALPHA, BES_NB, 1, BES_B, BES_NCALC) IF (BES_NCALC .LT. -1) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 2' ELSE IF (BES_NCALC .EQ. -1) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 3' ELSE IF (BES_NCALC .NE. BES_NB) THEN WRITE (UNIT=*, FMT='(A)') ' BESSELK Error 4' ELSE LASTX = STACK(1) STACK(1) = BES_B(BES_NB) CALL DROP_STACK(2) END IF DEALLOCATE (BES_B) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BETA') THEN ! BETA SELECT CASE (DOMAIN_MODE) CASE (1) IF ((ISINT(STACK(1)).AND.(STACK(1).LE.0.0D0)) .OR. & (ISINT(STACK(2)).AND.(STACK(2).LE.0.0D0))) THEN WRITE (UNIT=*, FMT='(A)') ' BETA Error' ELSE LASTX = STACK(1) STACK(1) = BETA(STACK(1),STACK(2)) CALL DROP_STACK(2) END IF CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CBETA(CSTACK(1),CSTACK(2)) CALL CDROP_STACK(2) CASE (3) IF (((RDSTACK(1).EQ.1).AND.(RNSTACK(1).LE.0)) .OR. & ((RDSTACK(2).EQ.1).AND.(RNSTACK(2).LE.0))) THEN WRITE (UNIT=*, FMT='(A)') ' BETA Error' ELSE IF ((RDSTACK(1).EQ.1) .AND. (RDSTACK(2).EQ.1)) THEN ITMP = RNSTACK(1) IF (ITMP.LE.0) THEN WRITE (UNIT=*, FMT='(A)') ' BETA Error' ELSE CALL RBETA(RNSTACK(1),RNSTACK(2),ITMP,ITMP2) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = ITMP RDSTACK(1) = ITMP2 CALL RDROP_STACK(2) END IF ELSE CALL SWITCH_RAT_TO_REAL IF ((ISINT(STACK(1)).AND.(STACK(1).LE.0.0D0)) .OR. & (ISINT(STACK(2)).AND.(STACK(2).LE.0.0D0))) THEN WRITE (UNIT=*, FMT='(A)') ' BETA Error' ELSE LASTX = STACK(1) STACK(1) = BETA(STACK(1),STACK(2)) CALL DROP_STACK(2) END IF END IF END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'BIN') THEN ! BIN BASE_MODE = 2 ELSE IF (TRIM(STR) .EQ. 'C') THEN ! C SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (C) CASE (2) CALL CPUSH_STACK (CMPLX(C,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (C) END SELECT ELSE IF (TRIM(STR) .EQ. 'C>F') THEN ! C>F SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = (9.0D0/5.0D0)*STACK(1)+32.0D0 CASE (2) CLASTX = CSTACK(1) CSTACK(1) = (9.0D0/5.0D0)*CSTACK(1)+32.0D0 CASE (3) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) CALL RMUL (9,5,RNSTACK(1),RDSTACK(1),NUM,DEN) CALL RADD (NUM,DEN,32,1,NUM2,DEN2) RNSTACK(1) = NUM2 RDSTACK(1) = DEN2 END SELECT ELSE IF (TRIM(STR) .EQ. 'CBRT') THEN ! CBRT SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = CUBEROOT(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCUBEROOT(CSTACK(1)) CASE (3) TMP = CUBEROOT(DBLE(RNSTACK(1))) TMP2 = CUBEROOT(DBLE(RDSTACK(1))) IF (ISFRAC(TMP).OR.ISFRAC(TMP2)) THEN CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = CUBEROOT(STACK(1)) ELSE RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NINT(CUBEROOT(DBLE(RNSTACK(1)))) RDSTACK(1) = NINT(CUBEROOT(DBLE(RDSTACK(1)))) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'CHS') THEN ! CHS SELECT CASE (DOMAIN_MODE) CASE (1) STACK(1) = -STACK(1) CASE (2) CSTACK(1) = -CSTACK(1) CASE (3) RNSTACK(1) = -RNSTACK(1) END SELECT ELSE IF (TRIM(STR) .EQ. 'CLALL') THEN ! CLALL SELECT CASE (DOMAIN_MODE) CASE(1) STACK = 0.0D0 REG = 0.0D0 NN = 0.0D0 SUMX = 0.0D0 SUMX2 = 0.0D0 SUMY = 0.0D0 SUMY2 = 0.0D0 SUMXY = 0.0D0 CASE (2) CSTACK = (0.0D0,0.0D0) CREG = (0.0D0,0.0D0) CNN = (0.0D0,0.0D0) CSUMX = (0.0D0,0.0D0) CSUMX2 = (0.0D0,0.0D0) CSUMY = (0.0D0,0.0D0) CSUMY2 = (0.0D0,0.0D0) CSUMXY = (0.0D0,0.0D0) CASE (3) RNSTACK = 0; RDSTACK = 1 RNREG = 0; RDREG = 1 RNNN = 0; RDNN = 1 RNSUMX = 0; RDSUMX = 1 RNSUMX2 = 0; RDSUMX2 = 1 RNSUMY = 0; RDSUMY = 1 RNSUMY2 = 0; RDSUMY2 = 1 RNSUMXY = 0; RDSUMXY = 1 END SELECT ELSE IF (TRIM(STR) .EQ. 'CLREG') THEN ! CLREG SELECT CASE (DOMAIN_MODE) CASE (1) REG = 0.0D0 CASE (2) CREG = (0.0D0,0.0D0) CASE (3) RNREG = 0; RDREG = 1 END SELECT ELSE IF (TRIM(STR) .EQ. 'CLS') THEN ! CLS SELECT CASE (DOMAIN_MODE) CASE(1) NN = 0.0D0 SUMX = 0.0D0 SUMX2 = 0.0D0 SUMY = 0.0D0 SUMY2 = 0.0D0 SUMXY = 0.0D0 CASE (2) CNN = (0.0D0,0.0D0) CSUMX = (0.0D0,0.0D0) CSUMX2 = (0.0D0,0.0D0) CSUMY = (0.0D0,0.0D0) CSUMY2 = (0.0D0,0.0D0) CSUMXY = (0.0D0,0.0D0) CASE (3) RNNN = 0; RDNN = 1 RNSUMX = 0; RDSUMX = 1 RNSUMX2 = 0; RDSUMX2 = 1 RNSUMY = 0; RDSUMY = 1 RNSUMY2 = 0; RDSUMY2 = 1 RNSUMXY = 0; RDSUMXY = 1 END SELECT ELSE IF (TRIM(STR) .EQ. 'CLSTK') THEN ! CLSTK SELECT CASE (DOMAIN_MODE) CASE (1) STACK = 0.0D0 CASE (2) CSTACK = (0.0D0,0.0D0) CASE (3) RNSTACK = 0; RDSTACK = 1 END SELECT ELSE IF (TRIM(STR) .EQ. 'CLX') THEN ! CLX SELECT CASE (DOMAIN_MODE) CASE (1) STACK(1) = 0.0D0 CASE (2) CSTACK(1) = (0.0D0,0.0D0) CASE (3) RNSTACK(1) = 0; RDSTACK(1) = 1 END SELECT ELSE IF (TRIM(STR) .EQ. 'CM>IN') THEN ! CM>IN SELECT CASE (DOMAIN_MODE) CASE (1) STACK(1) = STACK(1) / CM_PER_IN CASE (2) CSTACK(1) = CSTACK(1) / CM_PER_IN CASE (3) CALL SWITCH_RAT_TO_REAL STACK(1) = STACK(1) / CM_PER_IN END SELECT ELSE IF (TRIM(STR) .EQ. 'CNR') THEN ! CNR SELECT CASE (DOMAIN_MODE) CASE (1) IF (ISFRAC(STACK(1)) .OR. ISFRAC(STACK(2))) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF ((STACK(1).LT.0.0D0) .OR. (STACK(2).LT.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF (STACK(2) .LT. STACK(1)) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE ITMP = NINT(STACK(1)) ITMP2 = NINT(STACK(2)) LASTX = STACK(1) STACK(1) = CNR (ITMP2, ITMP) CALL DROP_STACK(2) END IF CASE (2) IF (ISFRAC(DBLE(CSTACK(1))) .OR. ISFRAC(DBLE(CSTACK(2)))) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF (DBLE(CSTACK(1)).LT.0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF (DBLE(CSTACK(2)).LT.0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF (AIMAG(CSTACK(1)).NE.0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF (AIMAG(CSTACK(2)).NE.0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF (DBLE(CSTACK(2)) .LT. DBLE(CSTACK(1))) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE ITMP = NINT(DBLE(CSTACK(1))) ITMP2 = NINT(DBLE(CSTACK(2))) TMP = CNR (ITMP2, ITMP) CLASTX = CSTACK(1) CSTACK(1) = CMPLX(TMP,0.0D0,8) CALL CDROP_STACK(2) END IF CASE (3) IF ((RDSTACK(1).NE.1).OR.(RDSTACK(2).NE.1)) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF ((RNSTACK(1).LT.0) .OR. (RNSTACK(2).LT.0)) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE IF (RNSTACK(2) .LT. RNSTACK(1)) THEN WRITE (UNIT=*, FMT='(A)') ' CNR Error' ELSE RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = CNR (RNSTACK(2), RNSTACK(1)) CALL RDROP_STACK(2) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'COMPLEX') THEN ! COMPLEX SELECT CASE (DOMAIN_MODE) CASE (1) DOMAIN_MODE = 2 DO I = 1, STACK_SIZE CSTACK(I) = CMPLX(STACK(I),0.0D0,8) END DO DO I = 0, REG_SIZE-1 CREG(I) = CMPLX(REG(I),0.0D0,8) END DO CLASTX = CMPLX(LASTX,0.0D0,8) CNN = CMPLX(NN,0.0D0,8) CSUMX = CMPLX(SUMX,0.0D0,8) CSUMX2 = CMPLX(SUMX2,0.0D0,8) CSUMY = CMPLX(SUMY,0.0D0,8) CSUMY2 = CMPLX(SUMY2,0.0D0,8) CSUMXY = CMPLX(SUMXY,0.0D0,8) CASE (3) DOMAIN_MODE = 2 DO I = 1, STACK_SIZE TMP = DBLE(RNSTACK(I))/DBLE(RDSTACK(I)) CSTACK(I) = CMPLX(TMP,0.0D0,8) END DO DO I = 0, REG_SIZE-1 TMP = DBLE(RNREG(I))/DBLE(RDREG(I)) CREG(I) = CMPLX(TMP,0.0D0,8) END DO CLASTX = CMPLX(DBLE(RNLASTX)/DBLE(RDLASTX),0.0D0,8) CNN = CMPLX(DBLE(RNNN)/DBLE(RDNN),0.0D0,8) CSUMX = CMPLX(DBLE(RNSUMX)/DBLE(RDSUMX),0.0D0,8) CSUMX2 = CMPLX(DBLE(RNSUMX2)/DBLE(RDSUMX2),0.0D0,8) CSUMY = CMPLX(DBLE(RNSUMY)/DBLE(RDSUMY),0.0D0,8) CSUMY2 = CMPLX(DBLE(RNSUMY2)/DBLE(RDSUMY2),0.0D0,8) CSUMXY = CMPLX(DBLE(RNSUMXY)/DBLE(RDSUMXY),0.0D0,8) END SELECT ELSE IF (TRIM(STR) .EQ. 'CONJ') THEN ! CONJ SELECT CASE (DOMAIN_MODE) CASE (2) CSTACK(1) = CONJG(CSTACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'COS') THEN ! COS SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = COS(STACK(1)*ANGLE_FACTOR) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = COS(CSTACK(1)*ANGLE_FACTOR) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = COS(STACK(1)*ANGLE_FACTOR) END SELECT ELSE IF (TRIM(STR) .EQ. 'COSH') THEN ! COSH SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = COSH(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCOSH(CSTACK(1)) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = COSH(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'COT') THEN ! COT SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = COT(STACK(1)*ANGLE_FACTOR) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCOT(CSTACK(1)*ANGLE_FACTOR) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = COT(STACK(1)*ANGLE_FACTOR) END SELECT ELSE IF (TRIM(STR) .EQ. 'COTH') THEN ! COTH SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = COTH(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCOTH(CSTACK(1)) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = COTH(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'COVERS') THEN ! COVERS SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = COVERS(STACK(1)*ANGLE_FACTOR) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCOVERS(CSTACK(1)*ANGLE_FACTOR) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = COVERS(STACK(1)*ANGLE_FACTOR) END SELECT ELSE IF (TRIM(STR) .EQ. 'CRD') THEN ! CRD SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = CRD(STACK(1)*ANGLE_FACTOR) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCRD(CSTACK(1)*ANGLE_FACTOR) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = CRD(STACK(1)*ANGLE_FACTOR) END SELECT ELSE IF (TRIM(STR) .EQ. 'CSC') THEN ! CSC SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = CSC(STACK(1)*ANGLE_FACTOR) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCSC(CSTACK(1)*ANGLE_FACTOR) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = CSC(STACK(1)*ANGLE_FACTOR) END SELECT ELSE IF (TRIM(STR) .EQ. 'CSCH') THEN ! CSCH SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = CSCH(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CCSCH(CSTACK(1)) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = CSCH(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'CUBE') THEN ! CUBE SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(1)**3 CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(1)**3 CASE (3) NUM = RNSTACK(1) DEN = RDSTACK(1) CALL RMUL (NUM,DEN,NUM,DEN,NUM2,DEN2) CALL RMUL (NUM, DEN, NUM2, DEN2, NUM, DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN END SELECT ELSE IF (TRIM(STR) .EQ. 'D>F') THEN ! D>F SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) CALL DEC_TO_FRAC (STACK(1), NUM, DEN, FRACTOL) CALL DROP_STACK(1) CALL PUSH_STACK(DBLE(NUM)) CALL PUSH_STACK(DBLE(DEN)) CASE (2) CLASTX = CSTACK(1) CALL DEC_TO_FRAC (DBLE(CSTACK(1)), NUM, DEN, FRACTOL) CALL DEC_TO_FRAC (AIMAG(CSTACK(1)), NUM2, DEN2, FRACTOL) CALL CDROP_STACK(1) CALL CPUSH_STACK(CMPLX(DBLE(NUM),DBLE(NUM2),8)) CALL CPUSH_STACK(CMPLX(DBLE(DEN),DBLE(DEN2),8)) END SELECT ELSE IF (TRIM(STR) .EQ. 'D>R') THEN ! D>R SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(1)*PI/180.0D0 CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(1)*PI/180.0D0 CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = STACK(1)*PI/180.0D0 END SELECT ELSE IF (TRIM(STR) .EQ. 'DEC') THEN ! DEC BASE_MODE = 10 ELSE IF (TRIM(STR) .EQ. 'DEFAULT') THEN ! DEFAULT ANGLE_MODE = INITIAL_ANGLE_MODE SELECT CASE (ANGLE_MODE) CASE (1) ANGLE_FACTOR = PI/180.0D0 CASE (2) ANGLE_FACTOR = 1.0D0 CASE (3) ANGLE_FACTOR = PI/200.0D0 CASE (4) ANGLE_FACTOR = TWOPI END SELECT DISP_MODE = INITIAL_DISP_MODE DISP_DIGITS = INITIAL_DISP_DIGITS DOMAIN_MODE = INITIAL_DOMAIN_MODE BASE_MODE = INITIAL_BASE_MODE FRACTION_MODE = INITIAL_FRACTION_MODE ELSE IF (TRIM(STR) .EQ. 'DEG') THEN ! DEG ANGLE_MODE = 1 ANGLE_FACTOR = PI/180.0D0 ELSE IF (TRIM(STR) .EQ. 'DIGAMMA') THEN ! DIGAMMA SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = PSI(STACK(1)) CASE (2) WRITE (UNIT=*, FMT='(A)') ' DIGAMMA function not available in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = PSI(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'DUP') THEN ! DUP SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK(STACK(1)) CASE (2) CALL CPUSH_STACK(CSTACK(1)) CASE (3) CALL RPUSH_STACK(RNSTACK(1),RDSTACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'ECHG') THEN ! ECHG SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (ECHG) CASE (2) CALL CPUSH_STACK (CMPLX(ECHG,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (ECHG) END SELECT ELSE IF (STR(1:3) .EQ. 'ENG') THEN ! ENG IF (LEN_TRIM(STR) .EQ. 3) THEN WRITE (UNIT=*, FMT='(A)') ' ENG Error' ELSE READ (UNIT=STR(4:), FMT=*, IOSTAT=IERR) ITMP IF (IERR .NE. 0) THEN WRITE (UNIT=*, FMT='(A)') ' ENG Error' ELSE DISP_MODE = 3 DISP_DIGITS = ITMP END IF END IF ELSE IF (TRIM(STR) .EQ. 'EPS0') THEN ! EPS0 SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (EPS0) CASE (2) CALL CPUSH_STACK (CMPLX(EPS0,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (EPS0) END SELECT ELSE IF (TRIM(STR) .EQ. 'ERF') THEN ! ERF SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = DERF(STACK(1)) CASE (2) WRITE (UNIT=*, FMT='(A)') ' ERF function not available in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = DERF(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'ERFC') THEN ! ERFC SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = DERFC(STACK(1)) CASE (2) WRITE (UNIT=*, FMT='(A)') ' ERFC function not available in COMPLEX mode.' CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = DERFC(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'EULER') THEN ! EULER SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (EULER) CASE (2) CALL CPUSH_STACK (CMPLX(EULER,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (EULER) END SELECT ELSE IF (TRIM(STR) .EQ. 'EXP') THEN ! EXP SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = EXP(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = EXP(CSTACK(1)) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = EXP(STACK(1)) END SELECT ELSE IF (TRIM(STR) .EQ. 'EXSEC') THEN ! EXSEC SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = EXSEC(STACK(1)*ANGLE_FACTOR) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CEXSEC(CSTACK(1)*ANGLE_FACTOR) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = EXSEC(STACK(1)*ANGLE_FACTOR) END SELECT ELSE IF (TRIM(STR) .EQ. 'F>C') THEN ! F>C SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = (5.0D0/9.0D0)*(STACK(1)-32.0D0) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = (5.0D0/9.0D0)*(CSTACK(1)-32.0D0) CASE (3) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) CALL RSUB (RNSTACK(1),RDSTACK(1),32,1,NUM,DEN) CALL RMUL (5,9,NUM,DEN,NUM2,DEN2) RNSTACK(1) = NUM2 RDSTACK(1) = DEN2 END SELECT ELSE IF (STR(1:3) .EQ. 'FIX') THEN ! FIX IF (LEN_TRIM(STR) .EQ. 3) THEN WRITE (UNIT=*, FMT='(A)') ' FIX Error' ELSE READ (UNIT=STR(4:), FMT=*, IOSTAT=IERR) ITMP IF (IERR .NE. 0) THEN WRITE (UNIT=*, FMT='(A)') ' FIX Error' ELSE DISP_MODE = 1 DISP_DIGITS = ITMP END IF END IF ELSE IF (TRIM(STR) .EQ. 'FRAC') THEN ! FRAC SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = FRAC(STACK(1)) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CFRAC(CSTACK(1)) CASE (3) CALL RFRAC(RNSTACK(1),RDSTACK(1),NUM,DEN) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NUM RDSTACK(1) = DEN END SELECT ELSE IF (TRIM(STR) .EQ. 'FRACTOL') THEN ! FRACTOL SELECT CASE (DOMAIN_MODE) CASE (1) FRACTOL = STACK(1) CALL DROP_STACK(1) CASE (2) FRACTOL = DBLE(CSTACK(1)) CALL CDROP_STACK(1) CASE (3) FRACTOL = DBLE(RNSTACK(1))/DBLE(RDSTACK(1)) CALL RDROP_STACK(1) END SELECT ELSE IF (TRIM(STR) .EQ. 'G') THEN ! G SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (G) CASE (2) CALL CPUSH_STACK (CMPLX(G,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (G) END SELECT ELSE IF (TRIM(STR) .EQ. 'GAL>L') THEN ! GAL>L SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(1) * L_PER_GAL CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(1) * L_PER_GAL CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = STACK(1) * L_PER_GAL END SELECT ELSE IF (TRIM(STR) .EQ. 'GAMMA') THEN ! GAMMA SELECT CASE (DOMAIN_MODE) CASE (1) IF (ISINT(STACK(1)).AND.(STACK(1).LE.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' GAMMA Error' ELSE LASTX = STACK(1) STACK(1) = DGAMMA(STACK(1)) END IF CASE (2) IF (CSTACK(1) .EQ. (0.0D0,0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' GAMMA Error' ELSE CLASTX = CSTACK(1) CSTACK(1) = CGAMMA(CSTACK(1)) END IF CASE (3) IF ((RDSTACK(1).EQ.1).AND.(RNSTACK(1).LE.0)) THEN WRITE (UNIT=*, FMT='(A)') ' GAMMA Error' ELSE IF (RDSTACK(1).EQ.1) THEN ITMP = RNSTACK(1) IF (ITMP.LE.0) THEN WRITE (UNIT=*, FMT='(A)') ' GAMMA Error' ELSE ITMP2 = 1 DO I = 2, ITMP-1 ITMP2 = ITMP2 * I END DO RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = ITMP2 RDSTACK(1) = 1 END IF ELSE CALL SWITCH_RAT_TO_REAL IF (ISINT(STACK(1)).AND.(STACK(1).LE.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' GAMMA Error' ELSE LASTX = STACK(1) STACK(1) = DGAMMA(STACK(1)) END IF END IF END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'GCD') THEN ! GCD SELECT CASE (DOMAIN_MODE) CASE (1) IF (ISFRAC(STACK(1)).OR.ISFRAC(STACK(2))) THEN WRITE (UNIT=*, FMT='(A)') ' GCD Error' ELSE LASTX = STACK(1) STACK(1) = GCD(NINT(STACK(2)),NINT(STACK(1))) CALL DROP_STACK(2) END IF CASE (2) IF (ISFRAC(DBLE(CSTACK(1))).OR.ISFRAC(DBLE(CSTACK(2))).OR. & (AIMAG(CSTACK(2)).NE.0.0D0).OR.(AIMAG(CSTACK(2)).NE.0.0D0)) THEN WRITE (UNIT=*, FMT='(A)') ' GCD Error' ELSE CLASTX = CSTACK(1) CSTACK(1) = GCD(NINT(DBLE(CSTACK(2))),NINT(DBLE(CSTACK(1)))) CALL CDROP_STACK(2) END IF CASE (3) IF ((RDSTACK(1).NE.1).OR.(RDSTACK(2).NE.1)) THEN WRITE (UNIT=*, FMT='(A)') ' GCD Error' ELSE RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(2) RNSTACK(1) = GCD(RNSTACK(2),RNSTACK(1)) RDSTACK(1) = 1 CALL RDROP_STACK(2) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'GOLDEN') THEN ! GOLDEN SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (GOLDEN) CASE (2) CALL CPUSH_STACK (CMPLX(GOLDEN,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (GOLDEN) END SELECT ELSE IF (TRIM(STR) .EQ. 'GRAD') THEN ! GRAD ANGLE_MODE = 3 ANGLE_FACTOR = PI/200.0D0 ELSE IF (TRIM(STR) .EQ. 'GRAV') THEN ! GRAV SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (GRAV) CASE (2) CALL CPUSH_STACK (CMPLX(GRAV,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (GRAV) END SELECT ELSE IF (TRIM(STR) .EQ. 'H') THEN ! H SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (H) CASE (2) CALL CPUSH_STACK (CMPLX(H,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (H) END SELECT ELSE IF (TRIM(STR) .EQ. 'H>HMS') THEN ! H>HMS SELECT CASE (DOMAIN_MODE) CASE (1) CALL H2HMSD (STACK(1), ITMP, ITMP2, TMP) LASTX = STACK(1) STACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP CASE (2) IF (AIMAG(CSTACK(1)) .NE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' H>HMS Error' ELSE CALL H2HMSD (DBLE(CSTACK(1)), ITMP, ITMP2, TMP) CLASTX = CSTACK(1) CSTACK(1) = CMPLX(DBLE(ITMP)+1.0D-2*ITMP2+1.0D-4*TMP, 0.0D0, 8) END IF CASE (3) CALL SWITCH_RAT_TO_REAL CALL H2HMSD (STACK(1), ITMP, ITMP2, TMP) LASTX = STACK(1) STACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP END SELECT ELSE IF (TRIM(STR) .EQ. 'HBAR') THEN ! HBAR SELECT CASE (DOMAIN_MODE) CASE (1) CALL PUSH_STACK (HBAR) CASE (2) CALL CPUSH_STACK (CMPLX(HBAR,0.0D0,8)) CASE (3) CALL SWITCH_RAT_TO_REAL CALL PUSH_STACK (HBAR) END SELECT ELSE IF (TRIM(STR) .EQ. 'HEX') THEN ! HEX BASE_MODE = 16 ELSE IF (TRIM(STR) .EQ. 'HMS>H') THEN ! HMS>H SELECT CASE (DOMAIN_MODE) CASE (1) ITMP = INT(STACK(1)) ITMP2 = INT(FRAC(STACK(1))*1.0D2) TMP = (STACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) LASTX = STACK(1) STACK(1) = TMP2 CASE (2) IF (AIMAG(CSTACK(1)) .NE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' HMS>H Error' ELSE ITMP = INT(DBLE(CSTACK(1))) ITMP2 = INT(FRAC(DBLE(CSTACK(1)))*1.0D2) TMP = (DBLE(CSTACK(1)) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) CLASTX = CSTACK(1) CSTACK(1) = CMPLX(TMP2,0.0D0,8) END IF CASE (3) CALL SWITCH_RAT_TO_REAL ITMP = INT(STACK(1)) ITMP2 = INT(FRAC(STACK(1))*1.0D2) TMP = (STACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) LASTX = STACK(1) STACK(1) = TMP2 END SELECT ELSE IF (TRIM(STR) .EQ. 'HMS+') THEN ! HMS+ SELECT CASE (DOMAIN_MODE) CASE (1) ITMP = INT(STACK(1)) ITMP2 = INT(FRAC(STACK(1))*1.0D2) TMP = (STACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) ITMP = INT(STACK(2)) ITMP2 = INT(FRAC(STACK(2))*1.0D2) TMP = (STACK(2) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP3) CALL H2HMSD (TMP2+TMP3, ITMP, ITMP2, TMP) LASTX = STACK(1) STACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP CALL DROP_STACK(2) CASE (2) IF (AIMAG(CSTACK(1)) .NE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' HMS+ Error' ELSE ITMP = INT(CSTACK(1)) ITMP2 = INT(FRAC(CSTACK(1))*1.0D2) TMP = (CSTACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) ITMP = INT(CSTACK(2)) ITMP2 = INT(FRAC(CSTACK(2))*1.0D2) TMP = (CSTACK(2) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP3) CALL H2HMSD (TMP2+TMP3, ITMP, ITMP2, TMP) CLASTX = CSTACK(1) CSTACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP CALL CDROP_STACK(2) END IF CASE (3) CALL SWITCH_RAT_TO_REAL ITMP = INT(STACK(1)) ITMP2 = INT(FRAC(STACK(1))*1.0D2) TMP = (STACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) ITMP = INT(STACK(2)) ITMP2 = INT(FRAC(STACK(2))*1.0D2) TMP = (STACK(2) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP3) CALL H2HMSD (TMP2+TMP3, ITMP, ITMP2, TMP) LASTX = STACK(1) STACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP CALL DROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. 'HMS-') THEN ! HMS- SELECT CASE (DOMAIN_MODE) CASE (1) ITMP = INT(STACK(1)) ITMP2 = INT(FRAC(STACK(1))*1.0D2) TMP = (STACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) ITMP = INT(STACK(2)) ITMP2 = INT(FRAC(STACK(2))*1.0D2) TMP = (STACK(2) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP3) CALL H2HMSD (TMP3-TMP2, ITMP, ITMP2, TMP) LASTX = STACK(1) STACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP CALL DROP_STACK(2) CASE (2) IF (AIMAG(CSTACK(1)) .NE. 0.0D0) THEN WRITE (UNIT=*, FMT='(A)') ' HMS- Error' ELSE ITMP = INT(CSTACK(1)) ITMP2 = INT(FRAC(CSTACK(1))*1.0D2) TMP = (CSTACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) ITMP = INT(CSTACK(2)) ITMP2 = INT(FRAC(CSTACK(2))*1.0D2) TMP = (CSTACK(2) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP3) CALL H2HMSD (TMP3-TMP2, ITMP, ITMP2, TMP) CLASTX = CSTACK(1) CSTACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP CALL CDROP_STACK(2) END IF CASE (3) CALL SWITCH_RAT_TO_REAL ITMP = INT(STACK(1)) ITMP2 = INT(FRAC(STACK(1))*1.0D2) TMP = (STACK(1) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP2) ITMP = INT(STACK(2)) ITMP2 = INT(FRAC(STACK(2))*1.0D2) TMP = (STACK(2) - ITMP - ITMP2*1.0D-2)*1.0D4 CALL HMS2H (ITMP, ITMP2, TMP, TMP3) CALL H2HMSD (TMP3-TMP2, ITMP, ITMP2, TMP) LASTX = STACK(1) STACK(1) = DBLE(ITMP) + 1.0D-2*ITMP2 + 1.0D-4*TMP CALL DROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. 'HAV') THEN ! HAV SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = HAV(STACK(1)*ANGLE_FACTOR) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CHAV(CSTACK(1)*ANGLE_FACTOR) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = HAV(STACK(1)*ANGLE_FACTOR) END SELECT ELSE IF (TRIM(STR) .EQ. 'HYPOT') THEN ! HYPOT SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = SQRT(STACK(1)**2+STACK(2)**2) CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = SQRT(CSTACK(1)**2+CSTACK(2)**2) CALL CDROP_STACK(2) CASE (3) NUM = RNSTACK(1) DEN = RDSTACK(1) NUM2 = RNSTACK(2) DEN2 = RDSTACK(2) CALL RMUL (NUM,DEN,NUM,DEN,NUM3,DEN3) CALL RMUL (NUM2,DEN2,NUM2,DEN2,NUM4,DEN4) CALL RADD (NUM3,DEN3,NUM4,DEN4,NUM,DEN) TMP = SQRT(DBLE(NUM)) TMP2 = SQRT(DBLE(DEN)) IF (ISFRAC(TMP).OR.ISFRAC(TMP2)) THEN CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = SQRT(STACK(1)**2+STACK(2)**2) CALL DROP_STACK(2) ELSE RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = NINT(SQRT(DBLE(NUM))) RDSTACK(1) = NINT(SQRT(DBLE(DEN))) CALL RDROP_STACK(2) END IF END SELECT ELSE IF (TRIM(STR) .EQ. 'HYPOT3') THEN ! HYPOT3 SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = SQRT(STACK(1)**2+STACK(2)**2+STACK(3)**2) CALL DROP_STACK(3) CALL DROP_STACK(2) CASE (2) CLASTX = CSTACK(1) CSTACK(1) = SQRT(CSTACK(1)**2+CSTACK(2)**2+CSTACK(3)**2) CALL CDROP_STACK(3) CALL CDROP_STACK(2) CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = SQRT(STACK(1)**2+STACK(2)**2+STACK(3)**2) CALL DROP_STACK(3) CALL DROP_STACK(2) END SELECT ELSE IF (TRIM(STR) .EQ. 'I') THEN ! I SELECT CASE (DOMAIN_MODE) CASE (1) WRITE (UNIT=*, FMT='(A)') ' i not available in REAL mode' CASE (2) CALL CPUSH_STACK (II) CASE (3) WRITE (UNIT=*, FMT='(A)') ' i not available in RATIONAL mode' END SELECT ELSE IF (TRIM(STR) .EQ. 'IM') THEN ! IM SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = 0.0D0 CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CMPLX(AIMAG(CSTACK(1)),0.0D0,8) CASE (3) RNLASTX = RNSTACK(1) RDLASTX = RDSTACK(1) RNSTACK(1) = 0 RDSTACK(1) = 1 END SELECT ELSE IF (TRIM(STR) .EQ. 'IMPROPER') THEN ! IMPROPER FRACTION_MODE = 1 ELSE IF (TRIM(STR) .EQ. 'IN>CM') THEN ! IN>CM SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = STACK(1) * CM_PER_IN CASE (2) CLASTX = CSTACK(1) CSTACK(1) = CSTACK(1) * CM_PER_IN CASE (3) CALL SWITCH_RAT_TO_REAL LASTX = STACK(1) STACK(1) = STACK(1) * CM_PER_IN END SELECT ELSE IF (TRIM(STR) .EQ. 'INT') THEN ! INT SELECT CASE (DOMAIN_MODE) CASE (1) LASTX = STACK(1) STACK(1) = AINT(STACK(1)) CASE (2) CLASTX = C