!*********************************************************************************************************************************** ! ! F R A C T I O N ! ! Module: FRACTION ! ! Programmer: David G. Simpson ! NASA Goddard Space Flight Center ! Greenbelt, Maryland 20771 ! ! Date: August 8, 2005 ! ! Language: Fortran-90 ! ! Version: 1.00e (January 2, 2006) ! ! Description: This module implements a "fraction" data type for Fortran-90. ! ! Files: Source files: ! ! fraction.f90 Module ! ! Notes: Available operators and functions: ! ! + Addtion; unary + ! - Subtraction; unary - ! * Multiplication ! / Division ! ** Exponentiation ! .EQ. == Equals ! .NE. /= Not equals ! .GT. > Greater than ! .GE. >= Greater than or equal to ! .LT. < Less than ! .LE. <= Less than or equal to ! = Assignment ! ABS Absolute value ! AINT Truncation ! ANINT Nearest whole number ! ACOS Arccosine ! ASIN Arcsine ! ATAN Arctangent ! ATAN2 Arctangent (2 arguments) ! CEILING Ceiling ! CMPLX Convert FRAC to COMPLEX ! COS Cosine ! COSH Hyperbolic cosine ! DBLE Convert FRAC to DOUBLE PRECISION ! DIM Positive difference ! EXP Exponential ! FLOOR Floor ! INT Convert FRAC to INTEGER ! LOG Natural logarithm ! LOG10 Common logarithm ! MOD Remainder ! MODULO Modulo ! NINT Nearest integer ! REAL Convert FRAC to REAL ! SIGN Transfer of sign ! SIN Sine ! SINH Hyperbolic sine ! TAN Tangent ! TANH Hyperbolic tangent ! SQRT Square root ! DEC_TO_FRAC Convert decimal number to fraction (rational number) ! FRAC_TO_MIXED Convert fraction to "mixed" form (e.g. 5-1/2) ! ! All binary operators will work with two fractions, or with a fraction an an integer, real, or double-precision ! number. ! In this module, all fractions are in "improper" form (e.g. 11/2), rather than "mixed" form (e.g. 5-1/2). ! ! Usage: Include the module with USE FRACTION. Fractions may then be defined using the FRAC derived type. ! The numerator and denominator are in elements NUM and DEN of type FRAC (respectively). ! ! Example: USE FRACTION ! TYPE (FRAC) :: A, B, C ! A = FRAC (2,3) ! 2/3 ! B = FRAC (1,2) ! 1/2 ! C = A + B ! 7/6 ! PRINT *, C%NUM, '/', C%DEN ! 7/6 ! PRINT *, C .GT. 1 ! T ! !*********************************************************************************************************************************** MODULE FRACTION IMPLICIT NONE PRIVATE ! default to PRIVATE PUBLIC :: FRAC PUBLIC :: OPERATOR(+), OPERATOR(-), OPERATOR(*), OPERATOR(/), OPERATOR(**), & OPERATOR (.EQ.), OPERATOR(.NE.), OPERATOR(.GT.), OPERATOR(.GE.), & OPERATOR (.LT.), OPERATOR(.LE.), ASSIGNMENT(=), ABS, AINT, ANINT, ACOS, & ASIN, ATAN, ATAN2, CEILING, CMPLX, COS, COSH, DBLE, DIM, EXP, FLOOR, & INT, LOG, LOG10, MOD, MODULO, NINT, REAL, SIGN, SIN, SINH, SQRT, TAN, & TANH, DEC_TO_FRAC, FRAC_TO_MIXED TYPE :: FRAC INTEGER :: NUM, DEN END TYPE FRAC INTERFACE OPERATOR (+) MODULE PROCEDURE FRAC_FADDF, FRAC_FADDI, FRAC_IADDF, FRAC_ADDF, & FRAC_FADDR, FRAC_RADDF, FRAC_FADDD, FRAC_DADDF END INTERFACE INTERFACE OPERATOR (-) MODULE PROCEDURE FRAC_FSUBF, FRAC_FSUBI, FRAC_ISUBF, FRAC_SUBF, & FRAC_FSUBR, FRAC_RSUBF, FRAC_FSUBD, FRAC_DSUBF END INTERFACE INTERFACE OPERATOR (*) MODULE PROCEDURE FRAC_FMULF, FRAC_FMULI, FRAC_IMULF, FRAC_FMULR, & FRAC_RMULF, FRAC_FMULD, FRAC_DMULF END INTERFACE INTERFACE OPERATOR (/) MODULE PROCEDURE FRAC_FDIVF, FRAC_FDIVI, FRAC_IDIVF, FRAC_FDIVR, & FRAC_RDIVF, FRAC_FDIVD, FRAC_DDIVF END INTERFACE INTERFACE OPERATOR (**) MODULE PROCEDURE FRAC_FPWRF, FRAC_FPWRI, FRAC_IPWRF, FRAC_FPWRR, & FRAC_RPWRF, FRAC_FPWRD, FRAC_DPWRF END INTERFACE INTERFACE OPERATOR (.EQ.) MODULE PROCEDURE FRAC_FEQF, FRAC_FEQI, FRAC_IEQF, FRAC_FEQR, & FRAC_REQF, FRAC_FEQD, FRAC_DEQF END INTERFACE INTERFACE OPERATOR (.NE.) MODULE PROCEDURE FRAC_FNEF, FRAC_FNEI, FRAC_INEF, FRAC_FNER, & FRAC_RNEF, FRAC_FNED, FRAC_DNEF END INTERFACE INTERFACE OPERATOR (.GT.) MODULE PROCEDURE FRAC_FGTF, FRAC_FGTI, FRAC_IGTF, FRAC_FGTR, & FRAC_RGTF, FRAC_FGTD, FRAC_DGTF END INTERFACE INTERFACE OPERATOR (.GE.) MODULE PROCEDURE FRAC_FGEF, FRAC_FGEI, FRAC_IGEF, FRAC_FGER, & FRAC_RGEF, FRAC_FGED, FRAC_DGEF END INTERFACE INTERFACE OPERATOR (.LT.) MODULE PROCEDURE FRAC_FLTF, FRAC_FLTI, FRAC_ILTF, FRAC_FLTR, & FRAC_RLTF, FRAC_FLTD, FRAC_DLTF END INTERFACE INTERFACE OPERATOR (.LE.) MODULE PROCEDURE FRAC_FLEF, FRAC_FLEI, FRAC_ILEF, FRAC_FLER, & FRAC_RLEF, FRAC_FLED, FRAC_DLEF END INTERFACE INTERFACE ASSIGNMENT (=) MODULE PROCEDURE FRAC_FEI, FRAC_IEF, FRAC_REF, FRAC_DEF END INTERFACE INTERFACE ABS MODULE PROCEDURE FRAC_ABS END INTERFACE INTERFACE ACOS MODULE PROCEDURE FRAC_ACOS END INTERFACE INTERFACE AINT MODULE PROCEDURE FRAC_AINT END INTERFACE INTERFACE ANINT MODULE PROCEDURE FRAC_ANINT END INTERFACE ANINT INTERFACE ASIN MODULE PROCEDURE FRAC_ASIN END INTERFACE INTERFACE ATAN MODULE PROCEDURE FRAC_ATAN END INTERFACE INTERFACE ATAN2 MODULE PROCEDURE FRAC_ATAN2 END INTERFACE INTERFACE CEILING MODULE PROCEDURE FRAC_CEILING END INTERFACE INTERFACE CMPLX MODULE PROCEDURE FRAC_FC END INTERFACE INTERFACE COS MODULE PROCEDURE FRAC_COS END INTERFACE INTERFACE COSH MODULE PROCEDURE FRAC_COSH END INTERFACE INTERFACE DBLE MODULE PROCEDURE FRAC_FD END INTERFACE INTERFACE DIM MODULE PROCEDURE FRAC_DIM END INTERFACE INTERFACE EXP MODULE PROCEDURE FRAC_EXP END INTERFACE EXP INTERFACE FLOOR MODULE PROCEDURE FRAC_FLOOR END INTERFACE INTERFACE INT MODULE PROCEDURE FRAC_FI END INTERFACE INTERFACE LOG MODULE PROCEDURE FRAC_LOG END INTERFACE INTERFACE LOG10 MODULE PROCEDURE FRAC_LOG10 END INTERFACE INTERFACE MOD MODULE PROCEDURE FRAC_MOD END INTERFACE INTERFACE MODULO MODULE PROCEDURE FRAC_MODULO END INTERFACE INTERFACE NINT MODULE PROCEDURE FRAC_NINT END INTERFACE INTERFACE REAL MODULE PROCEDURE FRAC_FR END INTERFACE INTERFACE SIGN MODULE PROCEDURE FRAC_SIGN END INTERFACE INTERFACE SIN MODULE PROCEDURE FRAC_SIN END INTERFACE INTERFACE SINH MODULE PROCEDURE FRAC_SINH END INTERFACE INTERFACE SQRT MODULE PROCEDURE FRAC_SQRT END INTERFACE INTERFACE TAN MODULE PROCEDURE FRAC_TAN END INTERFACE INTERFACE TANH MODULE PROCEDURE FRAC_TANH END INTERFACE INTERFACE DEC_TO_FRAC MODULE PROCEDURE DEC_TO_FRACR, DEC_TO_FRACD END INTERFACE CONTAINS !----------------------------------------------------------------------------------------------------------------------------------- ! GCD - Greatest common divisor. ! Find the greatest common divisor of two integers using Euclid's algorithm. !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION GCD (A, B) RESULT (G) IMPLICIT NONE INTEGER, INTENT(IN) :: A, B INTEGER :: G INTEGER :: A1, B1, T A1 = A B1 = B DO WHILE (B1 .NE. 0) T = B1 B1 = MOD (A1,B1) A1 = T END DO G = A1 RETURN END FUNCTION GCD !----------------------------------------------------------------------------------------------------------------------------------- ! NORM - Normalize a fraction. ! Check for a denominator or numerator of 0; make the denominator positive; and reduce the fraction. !----------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE NORM (A) IMPLICIT NONE TYPE (FRAC), INTENT(IN OUT) :: A INTEGER :: G LOGICAL :: NEGFLAG IF (A%DEN .EQ. 0) THEN ! check for zero denominator WRITE (UNIT=*, FMT='(A)') ' Error in module FRACTION: denominator is zero.' A%NUM = 0 A%DEN = 1 RETURN END IF IF (A%NUM .EQ. 0) THEN ! if zero numerator, just return 0/1 A%NUM = 0 A%DEN = 1 RETURN END IF NEGFLAG = (A%NUM .LT. 0) .NEQV. (A%DEN .LT. 0) ! save sign of fraction in NEGFLAG A%NUM = ABS(A%NUM) ! take absolute value of NUM and DEN A%DEN = ABS(A%DEN) G = GCD (A%NUM, A%DEN) ! find GCD of NUM and DEN A%NUM = A%NUM / G ! reduce the fraction A%DEN = A%DEN / G IF (NEGFLAG) A%NUM = -A%NUM ! restore the sign to the numerator RETURN END SUBROUTINE NORM !----------------------------------------------------------------------------------------------------------------------------------- ! Addition (+). !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FADDF (A, B) RESULT (C) ! FRAC + FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C C = FRAC (A%NUM*B%DEN+A%DEN*B%NUM, A%DEN*B%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_FADDF FUNCTION FRAC_FADDI (A, N) RESULT (C) ! FRAC + INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N TYPE (FRAC) :: C C = FRAC (A%NUM+A%DEN*N, A%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_FADDI FUNCTION FRAC_IADDF (N, A) RESULT (C) ! INTEGER + FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C C = FRAC (A%NUM+A%DEN*N, A%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_IADDF FUNCTION FRAC_ADDF (A) RESULT (C) ! unary + IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C C = A CALL NORM (C) RETURN END FUNCTION FRAC_ADDF FUNCTION FRAC_FADDR (A, X) RESULT (Y) ! FRAC + REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) + X RETURN END FUNCTION FRAC_FADDR FUNCTION FRAC_RADDF (X, A) RESULT (Y) ! REAL + FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X + (REAL(AN%NUM)/REAL(AN%DEN)) RETURN END FUNCTION FRAC_RADDF FUNCTION FRAC_FADDD (A, X) RESULT (Y) ! FRAC + (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) + X RETURN END FUNCTION FRAC_FADDD FUNCTION FRAC_DADDF (X, A) RESULT (Y) ! (DOUBLE PRECISION) + FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X + (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_DADDF !----------------------------------------------------------------------------------------------------------------------------------- ! Subtraction (-). !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FSUBF (A, B) RESULT (C) ! FRAC - FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C C = FRAC (A%NUM*B%DEN-A%DEN*B%NUM, A%DEN*B%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_FSUBF FUNCTION FRAC_FSUBI (A, N) RESULT (C) ! FRAC - INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N TYPE (FRAC) :: C C = FRAC (A%NUM-A%DEN*N, A%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_FSUBI FUNCTION FRAC_ISUBF (N, A) RESULT (C) ! INTEGER - FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C C = FRAC (N*A%DEN-A%NUM, A%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_ISUBF FUNCTION FRAC_SUBF (A) RESULT (C) ! unary - IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C C = FRAC (-A%NUM, A%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_SUBF FUNCTION FRAC_FSUBR (A, X) RESULT (Y) ! FRAC - REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) - X RETURN END FUNCTION FRAC_FSUBR FUNCTION FRAC_RSUBF (X, A) RESULT (Y) ! REAL - FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X - (REAL(AN%NUM)/REAL(AN%DEN)) RETURN END FUNCTION FRAC_RSUBF FUNCTION FRAC_FSUBD (A, X) RESULT (Y) ! FRAC - (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) - X RETURN END FUNCTION FRAC_FSUBD FUNCTION FRAC_DSUBF (X, A) RESULT (Y) ! (DOUBLE PRECISION) - FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X - (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_DSUBF !----------------------------------------------------------------------------------------------------------------------------------- ! Multiplication (*). !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FMULF (A, B) RESULT (C) ! FRAC * FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C C = FRAC (A%NUM*B%NUM, A%DEN*B%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_FMULF FUNCTION FRAC_FMULI (A, N) RESULT (C) ! FRAC * INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N TYPE (FRAC) :: C C = FRAC (A%NUM*N, A%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_FMULI FUNCTION FRAC_IMULF (N, A) RESULT (C) ! INTEGER * FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C C = FRAC (A%NUM*N, A%DEN) CALL NORM (C) RETURN END FUNCTION FRAC_IMULF FUNCTION FRAC_FMULR (A, X) RESULT (Y) ! FRAC * REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) * X RETURN END FUNCTION FRAC_FMULR FUNCTION FRAC_RMULF (X, A) RESULT (Y) ! REAL * FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X * (REAL(AN%NUM)/REAL(AN%DEN)) RETURN END FUNCTION FRAC_RMULF FUNCTION FRAC_FMULD (A, X) RESULT (Y) ! FRAC * (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) * X RETURN END FUNCTION FRAC_FMULD FUNCTION FRAC_DMULF (X, A) RESULT (Y) ! (DOUBLE PRECISION) * FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X * (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_DMULF !----------------------------------------------------------------------------------------------------------------------------------- ! Division (/). !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FDIVF (A, B) RESULT (C) ! FRAC / FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C C = FRAC (A%NUM*B%DEN, A%DEN*B%NUM) CALL NORM (C) RETURN END FUNCTION FRAC_FDIVF FUNCTION FRAC_FDIVI (A, N) RESULT (C) ! FRAC / INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N TYPE (FRAC) :: C C = FRAC (A%NUM, A%DEN*N) CALL NORM (C) RETURN END FUNCTION FRAC_FDIVI FUNCTION FRAC_IDIVF (N, A) RESULT (C) ! INTEGER / FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C C = FRAC (N*A%DEN, A%NUM) CALL NORM (C) RETURN END FUNCTION FRAC_IDIVF FUNCTION FRAC_FDIVR (A, X) RESULT (Y) ! FRAC / REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) / X RETURN END FUNCTION FRAC_FDIVR FUNCTION FRAC_RDIVF (X, A) RESULT (Y) ! REAL / FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X / (REAL(AN%NUM)/REAL(AN%DEN)) RETURN END FUNCTION FRAC_RDIVF FUNCTION FRAC_FDIVD (A, X) RESULT (Y) ! FRAC / (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) / X RETURN END FUNCTION FRAC_FDIVD FUNCTION FRAC_DDIVF (X, A) RESULT (Y) ! (DOUBLE PRECISION) / FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X / (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_DDIVF !----------------------------------------------------------------------------------------------------------------------------------- ! Exponentiation (**). !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FPWRF (A, B) RESULT (Y) ! FRAC ** FRAC (DOUBLE PRECISION result) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B DOUBLE PRECISION :: Y TYPE (FRAC) :: AN, BN AN = A BN = B CALL NORM (AN) CALL NORM (BN) Y = (DBLE(A%NUM)/DBLE(A%DEN))**(DBLE(B%NUM)/DBLE(B%DEN)) RETURN END FUNCTION FRAC_FPWRF FUNCTION FRAC_FPWRI (A, N) RESULT (C) ! FRAC ** INTEGER (FRAC result) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N TYPE (FRAC) :: C C = FRAC (A%NUM**N, A%DEN**N) CALL NORM (C) RETURN END FUNCTION FRAC_FPWRI FUNCTION FRAC_IPWRF (N, A) RESULT (Y) ! INTEGER ** FRAC (DOUBLE PRECISION result) IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = DBLE(N)**(DBLE(A%NUM)/DBLE(A%DEN)) RETURN END FUNCTION FRAC_IPWRF FUNCTION FRAC_FPWRR (A, X) RESULT (Y) ! FRAC ** REAL (REAL result) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (REAL(A%NUM)/REAL(A%DEN))**X RETURN END FUNCTION FRAC_FPWRR FUNCTION FRAC_RPWRF (X, A) RESULT (Y) ! REAL ** FRAC (REAL result) IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A REAL :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X**(REAL(A%NUM)/REAL(A%DEN)) RETURN END FUNCTION FRAC_RPWRF FUNCTION FRAC_FPWRD (A, X) RESULT (Y) ! FRAC ** (DOUBLE PRECISION) (D.P. result) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = (DBLE(A%NUM)/DBLE(A%DEN))**X RETURN END FUNCTION FRAC_FPWRD FUNCTION FRAC_DPWRF (X, A) RESULT (Y) ! (DOUBLE PRECISION) ** FRAC (D.P. result) IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: Y TYPE (FRAC) :: AN AN = A CALL NORM (AN) Y = X**(DBLE(A%NUM)/DBLE(A%DEN)) RETURN END FUNCTION FRAC_DPWRF !----------------------------------------------------------------------------------------------------------------------------------- ! .EQ. !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FEQF (A, B) RESULT (L) ! FRAC .EQ. FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B LOGICAL :: L TYPE (FRAC) :: AN, BN AN = A BN = B CALL NORM (AN) CALL NORM (BN) L = (AN%NUM .EQ. BN%NUM) .AND. (AN%DEN .EQ. BN%DEN) RETURN END FUNCTION FRAC_FEQF FUNCTION FRAC_FEQI (A, N) RESULT (L) ! FRAC .EQ. INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (AN%NUM .EQ. N) .AND. (AN%DEN .EQ. 1) RETURN END FUNCTION FRAC_FEQI FUNCTION FRAC_IEQF (N, A) RESULT (L) ! INTEGER .EQ. FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (AN%NUM .EQ. N) .AND. (AN%DEN .EQ. 1) RETURN END FUNCTION FRAC_IEQF FUNCTION FRAC_FEQR (A, X) RESULT (L) ! FRAC .EQ. REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (REAL(AN%NUM)/REAL(AN%DEN)) .EQ. X RETURN END FUNCTION FRAC_FEQR FUNCTION FRAC_REQF (X, A) RESULT (L) ! REAL .EQ. FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = X .EQ. (REAL(AN%NUM)/REAL(AN%DEN)) RETURN END FUNCTION FRAC_REQF FUNCTION FRAC_FEQD (A, X) RESULT (L) ! FRAC .EQ. (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (DBLE(AN%NUM)/DBLE(AN%DEN)) .EQ. X RETURN END FUNCTION FRAC_FEQD FUNCTION FRAC_DEQF (X, A) RESULT (L) ! (DOUBLE PRECISION) .EQ. FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = X .EQ. (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_DEQF !----------------------------------------------------------------------------------------------------------------------------------- ! .NE. !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FNEF (A, B) RESULT (L) ! FRAC .NE. FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B LOGICAL :: L TYPE (FRAC) :: AN, BN AN = A BN = B CALL NORM (AN) CALL NORM (BN) L = (AN%NUM .NE. BN%NUM) .OR. (AN%DEN .NE. BN%DEN) RETURN END FUNCTION FRAC_FNEF FUNCTION FRAC_FNEI (A, N) RESULT (L) ! FRAC .NE. INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (AN%NUM .NE. N) .OR. (AN%DEN .NE. 1) RETURN END FUNCTION FRAC_FNEI FUNCTION FRAC_INEF (N, A) RESULT (L) ! INTEGER .NE. FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (AN%NUM .NE. N) .OR. (AN%DEN .NE. 1) RETURN END FUNCTION FRAC_INEF FUNCTION FRAC_FNER (A, X) RESULT (L) ! FRAC .NE. REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (REAL(AN%NUM)/REAL(AN%DEN)) .NE. X RETURN END FUNCTION FRAC_FNER FUNCTION FRAC_RNEF (X, A) RESULT (L) ! REAL .NE. FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = X .NE. (REAL(AN%NUM)/REAL(AN%DEN)) RETURN END FUNCTION FRAC_RNEF FUNCTION FRAC_FNED (A, X) RESULT (L) ! FRAC .NE. (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = (DBLE(AN%NUM)/DBLE(AN%DEN)) .NE. X RETURN END FUNCTION FRAC_FNED FUNCTION FRAC_DNEF (X, A) RESULT (L) ! (DOUBLE PRECISION) .NE. FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN AN = A CALL NORM (AN) L = X .NE. (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_DNEF !----------------------------------------------------------------------------------------------------------------------------------- ! .GT. !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FGTF (A, B) RESULT (L) ! FRAC .GT. FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B LOGICAL :: L TYPE (FRAC) :: C C = A - B L = C%NUM .GT. 0 RETURN END FUNCTION FRAC_FGTF FUNCTION FRAC_FGTI (A, N) RESULT (L) ! FRAC .GT. INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N LOGICAL :: L TYPE (FRAC) :: C C = A - N L = C%NUM .GT. 0 RETURN END FUNCTION FRAC_FGTI FUNCTION FRAC_IGTF (N, A) RESULT (L) ! INTEGER .GT. FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: C C = N - A L = C%NUM .GT. 0 RETURN END FUNCTION FRAC_IGTF FUNCTION FRAC_FGTR (A, X) RESULT (L) ! FRAC .GT. REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) - X L = Y .GT. 0 RETURN END FUNCTION FRAC_FGTR FUNCTION FRAC_RGTF (X, A) RESULT (L) ! REAL .GT. FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = X - (REAL(AN%NUM)/REAL(AN%DEN)) L = Y .GT. 0 RETURN END FUNCTION FRAC_RGTF FUNCTION FRAC_FGTD (A, X) RESULT (L) ! FRAC .GT. (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) - X L = Y .GT. 0 RETURN END FUNCTION FRAC_FGTD FUNCTION FRAC_DGTF (X, A) RESULT (L) ! (DOUBLE PRECISION) .GT. FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = X - (DBLE(AN%NUM)/DBLE(AN%DEN)) L = Y .GT. 0 RETURN END FUNCTION FRAC_DGTF !----------------------------------------------------------------------------------------------------------------------------------- ! .GE. !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FGEF (A, B) RESULT (L) ! FRAC .GE. FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B LOGICAL :: L TYPE (FRAC) :: C C = A - B L = C%NUM .GE. 0 RETURN END FUNCTION FRAC_FGEF FUNCTION FRAC_FGEI (A, N) RESULT (L) ! FRAC .GE. INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N LOGICAL :: L TYPE (FRAC) :: C C = A - N L = C%NUM .GE. 0 RETURN END FUNCTION FRAC_FGEI FUNCTION FRAC_IGEF (N, A) RESULT (L) ! INTEGER .GE. FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: C C = N - A L = C%NUM .GE. 0 RETURN END FUNCTION FRAC_IGEF FUNCTION FRAC_FGER (A, X) RESULT (L) ! FRAC .GE. REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) - X L = Y .GE. 0 RETURN END FUNCTION FRAC_FGER FUNCTION FRAC_RGEF (X, A) RESULT (L) ! REAL .GE. FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = X - (REAL(AN%NUM)/REAL(AN%DEN)) L = Y .GE. 0 RETURN END FUNCTION FRAC_RGEF FUNCTION FRAC_FGED (A, X) RESULT (L) ! FRAC .GE. (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) - X L = Y .GE. 0 RETURN END FUNCTION FRAC_FGED FUNCTION FRAC_DGEF (X, A) RESULT (L) ! (DOUBLE PRECISION) .GE. FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = X - (DBLE(AN%NUM)/DBLE(AN%DEN)) L = Y .GE. 0 RETURN END FUNCTION FRAC_DGEF !----------------------------------------------------------------------------------------------------------------------------------- ! .LT. !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FLTF (A, B) RESULT (L) ! FRAC .LT. FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B LOGICAL :: L TYPE (FRAC) :: C C = A - B L = C%NUM .LT. 0 RETURN END FUNCTION FRAC_FLTF FUNCTION FRAC_FLTI (A, N) RESULT (L) ! FRAC .LT. INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N LOGICAL :: L TYPE (FRAC) :: C C = A - N L = C%NUM .LT. 0 RETURN END FUNCTION FRAC_FLTI FUNCTION FRAC_ILTF (N, A) RESULT (L) ! INTEGER .LT. FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: C C = N - A L = C%NUM .LT. 0 RETURN END FUNCTION FRAC_ILTF FUNCTION FRAC_FLTR (A, X) RESULT (L) ! FRAC .LT. REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) - X L = Y .LT. 0 RETURN END FUNCTION FRAC_FLTR FUNCTION FRAC_RLTF (X, A) RESULT (L) ! REAL .LT. FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = X - (REAL(AN%NUM)/REAL(AN%DEN)) L = Y .LT. 0 RETURN END FUNCTION FRAC_RLTF FUNCTION FRAC_FLTD (A, X) RESULT (L) ! FRAC .LT. (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) - X L = Y .LT. 0 RETURN END FUNCTION FRAC_FLTD FUNCTION FRAC_DLTF (X, A) RESULT (L) ! (DOUBLE PRECISION) .LT. FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = X - (DBLE(AN%NUM)/DBLE(AN%DEN)) L = Y .LT. 0 RETURN END FUNCTION FRAC_DLTF !----------------------------------------------------------------------------------------------------------------------------------- ! .LE. !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FLEF (A, B) RESULT (L) ! FRAC .LE. FRAC IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B LOGICAL :: L TYPE (FRAC) :: C C = A - B L = C%NUM .LE. 0 RETURN END FUNCTION FRAC_FLEF FUNCTION FRAC_FLEI (A, N) RESULT (L) ! FRAC .LE. INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(IN) :: N LOGICAL :: L TYPE (FRAC) :: C C = A - N L = C%NUM .LE. 0 RETURN END FUNCTION FRAC_FLEI FUNCTION FRAC_ILEF (N, A) RESULT (L) ! INTEGER .LE. FRAC IMPLICIT NONE INTEGER, INTENT(IN) :: N TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: C C = N - A L = C%NUM .LE. 0 RETURN END FUNCTION FRAC_ILEF FUNCTION FRAC_FLER (A, X) RESULT (L) ! FRAC .LE. REAL IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = (REAL(AN%NUM)/REAL(AN%DEN)) - X L = Y .LE. 0 RETURN END FUNCTION FRAC_FLER FUNCTION FRAC_RLEF (X, A) RESULT (L) ! REAL .LE. FRAC IMPLICIT NONE REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN REAL :: Y AN = A CALL NORM (AN) Y = X - (REAL(AN%NUM)/REAL(AN%DEN)) L = Y .LE. 0 RETURN END FUNCTION FRAC_RLEF FUNCTION FRAC_FLED (A, X) RESULT (L) ! FRAC .LE. (DOUBLE PRECISION) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION, INTENT(IN) :: X LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = (DBLE(AN%NUM)/DBLE(AN%DEN)) - X L = Y .LE. 0 RETURN END FUNCTION FRAC_FLED FUNCTION FRAC_DLEF (X, A) RESULT (L) ! (DOUBLE PRECISION) .LE. FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(IN) :: A LOGICAL :: L TYPE (FRAC) :: AN DOUBLE PRECISION :: Y AN = A CALL NORM (AN) Y = X - (DBLE(AN%NUM)/DBLE(AN%DEN)) L = Y .LE. 0 RETURN END FUNCTION FRAC_DLEF !----------------------------------------------------------------------------------------------------------------------------------- ! Assignment operator (=). !----------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE FRAC_FEI (A, N) ! FRAC = INTEGER IMPLICIT NONE TYPE (FRAC), INTENT(OUT) :: A INTEGER, INTENT(IN) :: N A%NUM = N A%DEN = 1 RETURN END SUBROUTINE FRAC_FEI SUBROUTINE FRAC_IEF (N, A) ! INTEGER = FRAC IMPLICIT NONE INTEGER, INTENT(OUT) :: N TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: AN AN = A CALL NORM (AN) N = AN%NUM / AN%DEN RETURN END SUBROUTINE FRAC_IEF SUBROUTINE FRAC_REF (X, A) ! REAL = FRAC IMPLICIT NONE REAL, INTENT(OUT) :: X TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = REAL(AN%NUM) / REAL(AN%DEN) RETURN END SUBROUTINE FRAC_REF SUBROUTINE FRAC_DEF (X, A) ! DOUBLE PRECISION = FRAC IMPLICIT NONE DOUBLE PRECISION, INTENT(OUT) :: X TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = DBLE(AN%NUM) / DBLE(AN%DEN) RETURN END SUBROUTINE FRAC_DEF !----------------------------------------------------------------------------------------------------------------------------------- ! ABS !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_ABS (A) RESULT (C) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C C = A CALL NORM (C) C%NUM = ABS(C%NUM) RETURN END FUNCTION FRAC_ABS !----------------------------------------------------------------------------------------------------------------------------------- ! ACOS !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_ACOS (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = ACOS (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_ACOS !----------------------------------------------------------------------------------------------------------------------------------- ! AINT !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_AINT (A) RESULT (C) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C TYPE (FRAC) :: AN AN = A CALL NORM (AN) C = AN%NUM / AN%DEN RETURN END FUNCTION FRAC_AINT !----------------------------------------------------------------------------------------------------------------------------------- ! ANINT !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_ANINT (A) RESULT (C) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A TYPE (FRAC) :: C TYPE (FRAC) :: AN, T AN = A CALL NORM (AN) IF (AN .GE. 0) THEN T = AN + FRAC(1,2) C%NUM = T%NUM / T%DEN C%DEN = 1 ELSE T = AN - FRAC(1,2) C%NUM = T%NUM / T%DEN C%DEN = 1 END IF RETURN END FUNCTION FRAC_ANINT !----------------------------------------------------------------------------------------------------------------------------------- ! ASIN !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_ASIN (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = ASIN (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_ASIN !----------------------------------------------------------------------------------------------------------------------------------- ! ATAN !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_ATAN (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = ATAN (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_ATAN !----------------------------------------------------------------------------------------------------------------------------------- ! ATAN2 !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_ATAN2 (A, B) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B DOUBLE PRECISION :: X TYPE (FRAC) :: AN, BN AN = A BN = B CALL NORM (AN) CALL NORM (BN) X = ATAN2 (DBLE(AN%NUM)/DBLE(AN%DEN), DBLE(BN%NUM)/DBLE(BN%DEN)) RETURN END FUNCTION FRAC_ATAN2 !----------------------------------------------------------------------------------------------------------------------------------- ! CEILING !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_CEILING (A) RESULT (N) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER :: N TYPE (FRAC) :: AN AN = A CALL NORM (AN) N = CEILING (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_CEILING !----------------------------------------------------------------------------------------------------------------------------------- ! CMPLX !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FC (A) RESULT (XC) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A COMPLEX :: XC TYPE (FRAC) :: AN AN = A CALL NORM (AN) XC = CMPLX(REAL(AN%NUM) / REAL(AN%DEN), 0.0) RETURN END FUNCTION FRAC_FC !----------------------------------------------------------------------------------------------------------------------------------- ! COS !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_COS (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = COS (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_COS !----------------------------------------------------------------------------------------------------------------------------------- ! COSH !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_COSH (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = COSH (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_COSH !----------------------------------------------------------------------------------------------------------------------------------- ! DBLE !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FD (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = DBLE(AN%NUM) / DBLE(AN%DEN) RETURN END FUNCTION FRAC_FD !----------------------------------------------------------------------------------------------------------------------------------- ! DIM !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_DIM (A, B) RESULT (C) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C TYPE (FRAC) :: AN, BN, T AN = A BN = B CALL NORM (AN) CALL NORM (BN) T = AN - BN IF (T .GT. 0) THEN C = T ELSE C = 0 END IF RETURN END FUNCTION FRAC_DIM !----------------------------------------------------------------------------------------------------------------------------------- ! EXP !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_EXP (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = EXP (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_EXP !----------------------------------------------------------------------------------------------------------------------------------- ! FLOOR !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FLOOR (A) RESULT (N) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER :: N TYPE (FRAC) :: AN AN = A CALL NORM (AN) N = FLOOR (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_FLOOR !----------------------------------------------------------------------------------------------------------------------------------- ! INT !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FI (A) RESULT (N) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER :: N TYPE (FRAC) :: AN AN = A CALL NORM (AN) N = AN%NUM / AN%DEN RETURN END FUNCTION FRAC_FI !----------------------------------------------------------------------------------------------------------------------------------- ! LOG !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_LOG (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = LOG (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_LOG !----------------------------------------------------------------------------------------------------------------------------------- ! LOG10 !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_LOG10 (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = LOG10 (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_LOG10 !----------------------------------------------------------------------------------------------------------------------------------- ! MOD !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_MOD (A, B) RESULT (C) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C TYPE (FRAC) :: AN, BN AN = A BN = B CALL NORM (AN) CALL NORM (BN) C = AN - INT(AN/BN)*BN RETURN END FUNCTION FRAC_MOD !----------------------------------------------------------------------------------------------------------------------------------- ! MODULO !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_MODULO (A, B) RESULT (C) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C TYPE (FRAC) :: AN, BN AN = A BN = B CALL NORM (AN) CALL NORM (BN) C = AN - FLOOR(AN/BN)*BN RETURN END FUNCTION FRAC_MODULO !----------------------------------------------------------------------------------------------------------------------------------- ! NINT !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_NINT (A) RESULT (N) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER :: N TYPE (FRAC) :: AN, T AN = A CALL NORM (AN) IF (AN .GE. 0) THEN T = AN + FRAC(1,2) N = T%NUM / T%DEN ELSE T = AN - FRAC(1,2) N = T%NUM / T%DEN END IF RETURN END FUNCTION FRAC_NINT !----------------------------------------------------------------------------------------------------------------------------------- ! REAL !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_FR (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A REAL :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = REAL(AN%NUM) / REAL(AN%DEN) RETURN END FUNCTION FRAC_FR !----------------------------------------------------------------------------------------------------------------------------------- ! SIGN !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_SIGN (A, B) RESULT (C) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A, B TYPE (FRAC) :: C TYPE (FRAC) :: AN, BN AN = A BN = B CALL NORM (AN) CALL NORM (BN) IF (B .GE. 0) THEN C = ABS(A) ELSE C = -ABS(A) END IF RETURN END FUNCTION FRAC_SIGN !----------------------------------------------------------------------------------------------------------------------------------- ! SIN !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_SIN (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = SIN (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_SIN !----------------------------------------------------------------------------------------------------------------------------------- ! SINH !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_SINH (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = SINH (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_SINH !----------------------------------------------------------------------------------------------------------------------------------- ! SQRT !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_SQRT (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = SQRT (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_SQRT !----------------------------------------------------------------------------------------------------------------------------------- ! TAN !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_TAN (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = TAN (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_TAN !----------------------------------------------------------------------------------------------------------------------------------- ! TANH !----------------------------------------------------------------------------------------------------------------------------------- FUNCTION FRAC_TANH (A) RESULT (X) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A DOUBLE PRECISION :: X TYPE (FRAC) :: AN AN = A CALL NORM (AN) X = TANH (DBLE(AN%NUM)/DBLE(AN%DEN)) RETURN END FUNCTION FRAC_TANH !----------------------------------------------------------------------------------------------------------------------------------- ! DEC_TO_FRAC ! ! Algorithm from "An Atlas of Functions" by Spanier and Oldham, Springer-Verlag, 1987, pp. 665-667. !----------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE DEC_TO_FRACR (X, A, TOL) ! single-precision version IMPLICIT NONE REAL, PARAMETER :: TOL_DEF = 1.0E-6 ! default value of tolerance REAL, INTENT(IN) :: X TYPE (FRAC), INTENT(OUT) :: A REAL, INTENT(IN), OPTIONAL :: TOL REAL :: TOL1, NU, R, T, EPS, M INTEGER :: N1, N2, D1, D2 LOGICAL :: SGN ! ! Set a default value for TOL if TOL was not provided. ! IF (PRESENT(TOL)) THEN TOL1 = TOL ELSE TOL1 = TOL_DEF END IF ! ! Save the sign of X, and make it positive. ! NU = X SGN = NU .LT. 0.0 ! save sign NU = ABS(NU) ! remove sign from X ! ! Compute the rational equivalent of X. ! D1 = 1 D2 = 1 N1 = INT(NU) N2 = N1 + 1 GO TO 300 100 IF (R .GT. 1.0) GO TO 200 R = 1.0/R 200 N2 = N2 + N1*INT(R) D2 = D2 + D1*INT(R) N1 = N1 + N2 D1 = D1 + D2 300 R = 0.0 IF (NU*D1 .EQ. REAL(N1)) GO TO 400 R = (N2-NU*D2)/(NU*D1-N1) IF (R .GT. 1.0) GO TO 400 T = N2 N2 = N1 N1 = T T = D2 D2 = D1 D1 = T 400 EPS = ABS(1.0 - (N1/(NU*D1))) IF (EPS .LE. TOL1) GO TO 600 M = 1.0 500 M = 10*M IF (M*EPS .LT. 1.0) GO TO 500 EPS = (1.0/M)*INT(0.5+M*EPS) 600 IF (EPS .LE. TOL1) THEN A%NUM = N1 A%DEN = D1 IF (SGN) A%NUM = -A%NUM ! negate numerator if needed RETURN END IF IF (R .NE. 0.0) GO TO 100 END SUBROUTINE DEC_TO_FRACR !----------------------------------------------------------------- SUBROUTINE DEC_TO_FRACD (X, A, TOL) ! double-precision version IMPLICIT NONE DOUBLE PRECISION, PARAMETER :: TOL_DEF = 1.0D-6 ! default value of tolerance DOUBLE PRECISION, INTENT(IN) :: X TYPE (FRAC), INTENT(OUT) :: A DOUBLE PRECISION, INTENT(IN), OPTIONAL :: TOL DOUBLE PRECISION :: TOL1, NU, R, T, EPS, M INTEGER :: N1, N2, D1, D2 LOGICAL :: SGN ! ! Set a default value for TOL if TOL was not provided. ! IF (PRESENT(TOL)) THEN TOL1 = TOL ELSE TOL1 = TOL_DEF END IF ! ! Save the sign of X, and make it positive. ! NU = X ! make a local copy of X SGN = NU .LT. 0.0D0 ! save sign NU = ABS(NU) ! remove sign from X ! ! Compute the rational equivalent of X. ! D1 = 1 D2 = 1 N1 = INT(NU) N2 = N1 + 1 GO TO 1300 1100 IF (R .GT. 1.0D0) GO TO 1200 R = 1.0D0/R 1200 N2 = N2 + N1*INT(R) D2 = D2 + D1*INT(R) N1 = N1 + N2 D1 = D1 + D2 1300 R = 0.0D0 IF (NU*D1 .EQ. DBLE(N1)) GO TO 1400 R = (N2-NU*D2)/(NU*D1-N1) IF (R .GT. 1.0D0) GO TO 1400 T = N2 N2 = N1 N1 = T T = D2 D2 = D1 D1 = T 1400 EPS = ABS(1.0D0 - (N1/(NU*D1))) IF (EPS .LE. TOL1) GO TO 1600 M = 1.0D0 1500 M = 10*M IF (M*EPS .LT. 1.0D0) GO TO 1500 EPS = (1.0D0/M)*INT(0.5D0+M*EPS) 1600 IF (EPS .LE. TOL1) THEN A%NUM = N1 A%DEN = D1 IF (SGN) A%NUM = -A%NUM ! negate numerator if needed RETURN END IF IF (R .NE. 0.0D0) GO TO 1100 END SUBROUTINE DEC_TO_FRACD !----------------------------------------------------------------------------------------------------------------------------------- ! FRAC_TO_MIXED !----------------------------------------------------------------------------------------------------------------------------------- SUBROUTINE FRAC_TO_MIXED (A, A1, A2, A3) IMPLICIT NONE TYPE (FRAC), INTENT(IN) :: A INTEGER, INTENT(OUT) :: A1, A2, A3 TYPE (FRAC) :: AN LOGICAL :: NEGFLAG AN = A ! normalize the input fraction CALL NORM (AN) NEGFLAG = AN%NUM .LT. 0 ! save the sign of the fraction.. AN%NUM = ABS (AN%NUM) ! ..and take its absolute value A1 = AN%NUM / AN%DEN ! find components of mixed fraction A2 = AN%NUM - A1*AN%DEN A3 = AN%DEN IF (NEGFLAG) A1 = -A1 ! restore the sign (assign to A1) RETURN END SUBROUTINE FRAC_TO_MIXED END MODULE FRACTION