Alvaro Agustin Fernandez sent the indented text:
>
[...]
> and picked fullsource. Try as I might, I can't seem to pick machine
> constants that it likes. I'm running on a SUN Ultra, and F90
> doesn't like any of the constants given for the SUN by the R1MACH
> routine in ERFC.
>
I'm sure others have done this, and done it better, but one can
duplicate the functionality of D1MACH, I1MACH,, and R1MACH using F90
intrinsics:
MODULE constants
!!!-------------------------------------------------------------------
!!!
!!! This is intended to provide general use constants, with:
!!!
!!!
!!! -- INTEGER PARAMETERS --
!!!
!!! STDIN -- The standard input unit (terminal)
!!!
!!! STDOUT -- The standard output unit (terminal)
!!!
!!! DPKIND -- "Double Precision" kind.
!!!
!!! SPKIND -- "Single Precision" (or regular REAL) kind.
!!!
!!!
!!! -- FUNCTIONS --
!!!
!!! The three machine constant routines which follow agree exactly
!!! with the old style routines. Like the old style routines, their
!!! arguments are integers.
!!!
!!! REAL (DPKIND) FUNCTION D1MACH(i)
!!!
!!! REAL (SPKIND) FUNCTION R1MACH(i)
!!!
!!! INTEGER FUNCTION I1MACH(i)
!!!
!!!-------------------------------------------------------------------
! .. Implicit None Statement ..
IMPLICIT NONE
! ..
! .. Default Accessibility ..
PRIVATE
! ..
! .. Parameters ..
DOUBLE PRECISION, PARAMETER :: done = 1.0D0
REAL, PARAMETER :: sone = 1.0E0
INTEGER, PARAMETER, PUBLIC :: dpkind = kind(done)
INTEGER, PARAMETER, PUBLIC :: spkind = kind(sone)
INTEGER, PARAMETER, PUBLIC :: stdin = 5, stdout = 6
! ..
! .. Intrinsic Functions ..
INTRINSIC kind
! ..
! .. Public Statements ..
PUBLIC :: d1mach, i1mach, r1mach
! ..
CONTAINS
!!!===================================================================
FUNCTION d1mach(i)
!!!-------------------------------------------------------------------
!!!
!!! This function is intended to replace the old D1MACH by using F90
!!! intrinsic functions. The parameter DPKIND is described above.
!!!
!!!
!!! The traditional D1MACH constants are ...
!!!
!!!
!!! -- DOUBLE-PRECISION MACHINE CONSTANTS ( here REAL (DPKIND) ) --
!!!
!!! D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
!!!
!!! D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
!!!
!!! D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
!!!
!!! D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
!!!
!!! D1MACH( 5) = LOG10(B)
!!!
!!!-------------------------------------------------------------------
! .. Implicit None Statement ..
IMPLICIT NONE
! ..
! .. Function Return Value ..
REAL (dpkind) :: d1mach
! ..
! .. Scalar Arguments ..
INTEGER :: i
! ..
! .. Local Scalars ..
LOGICAL, SAVE :: qfirst_call = .TRUE.
! ..
! .. Local Arrays ..
REAL (dpkind), SAVE :: d1mach_values(5)
! ..
! .. Intrinsic Functions ..
INTRINSIC digits, epsilon, huge, log10, radix, real, tiny
! ..
! .. Executable Statements ..
IF (i<1 .OR. i>5) THEN
WRITE (stdout,'(1x,''D1MACH(I) - I out of bounds, I ='',i10)') i
STOP ' D1MACH(I) - I out of bounds'
END IF
IF (qfirst_call) THEN
d1mach_values = (/ tiny(1.0E0_dpkind), huge(1.0E0_dpkind), &
real(radix(1.0E0_dpkind),dpkind)**(-digits(1.0E0_dpkind)), &
epsilon(1.0E0_dpkind), log10(real(radix(1.0E0_dpkind),dpkind)) /)
qfirst_call = .FALSE.
END IF
d1mach = d1mach_values(i)
RETURN
END FUNCTION d1mach
!!!===================================================================
FUNCTION i1mach(i)
!!!-------------------------------------------------------------------
!!!
!!! This function is intended to replace the old I1MACH by using F90
!!! intrinsic functions and module parameters defined above (for I/O).
!!! The parameters STDIN, STDOUT, DPKIND, and SPKIND are described
!!! above.
!!!
!!!
!!! The traditional I1MACH constants are ...
!!!
!!!
!!! -- I/O UNIT NUMBERS --
!!!
!!! I1MACH( 1) = THE STANDARD INPUT UNIT. [STDIN]
!!!
!!! I1MACH( 2) = THE STANDARD OUTPUT UNIT. [STDOUT]
!!!
!!! I1MACH( 3) = THE STANDARD PUNCH UNIT. [STOPS w/mssg]
!!!
!!! I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT [STDOUT]
!!!
!!! -- WORDS --
!!!
!!! I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT.
!!! [BIT_SIZE(ione)]
!!!
!!! I1MACH( 6) = THE NUMBER OF CHARACTERS PER INTEGER STORAGE UNIT.
!!! FOR FORTRAN 77, THIS IS ALWAYS 1. FOR FORTRAN
!!! 66, CHARACTER STORAGE UNIT = INTEGER STORAGE UNIT.
!!! [STOPs w/mssg]
!!!
!!! -- INTEGERS --
!!!
!!! ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM
!!!
!!! SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
!!!
!!! WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1.
!!!
!!! I1MACH( 7) = A, THE BASE. [RADIX(ione)]
!!!
!!! I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. [DIGITS(ione)]
!!!
!!! I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE [HUGE(ione)]
!!!
!!! -- FLOATING-POINT NUMBERS --
!!!
!!! ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT,
!!! BASE-B FORM
!!!
!!! SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!!!
!!! WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T,
!!! 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX.
!!!
!!! I1MACH(10) = B, THE BASE. [RADIX(real)]
!!!
!!! -- SINGLE-PRECISION ( here REAL (SPKIND) ) --
!!!
!!! I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. [DIGITS(single)]
!!!
!!! I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. [MINEXPONENT(single)]
!!!
!!! I1MACH(13) = EMAX, THE LARGEST EXPONENT E. [MAXEXPONENT(single)]
!!!
!!! -- DOUBLE-PRECISION ( here REAL (DPKIND) ) --
!!!
!!! I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. [DIGITS(double)]
!!!
!!! I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. [MINEXPONENT(double)]
!!!
!!! I1MACH(16) = EMAX, THE LARGEST EXPONENT E. [MAXEXPONENT(double)]
!!!
!!!-------------------------------------------------------------------
! .. Implicit None Statement ..
IMPLICIT NONE
! ..
! .. Function Return Value ..
INTEGER :: i1mach
! ..
! .. Parameters ..
INTEGER, PARAMETER :: ione = 1
INTEGER, PARAMETER :: i1mach_values(16) = (/ stdin, stdout, -1, &
stdout, bit_size(ione), -1, radix(ione), digits(ione), huge(ione), &
radix(1.0E0_spkind), digits(1.0E0_spkind), &
minexponent(1.0E0_spkind), maxexponent(1.0E0_spkind), &
digits(1.0E0_dpkind), minexponent(1.0E0_dpkind), &
maxexponent(1.0E0_dpkind) /)
! ..
! .. Scalar Arguments ..
INTEGER :: i
! ..
! .. Intrinsic Functions ..
INTRINSIC bit_size, digits, huge, maxexponent, minexponent, radix
! ..
! .. Executable Statements ..
ARGUMENT: SELECT CASE (i)
CASE (:0,17:) ARGUMENT
WRITE (stdout,'(1x,''I1MACH(I) - I out of bounds, I ='',i10)') i
STOP ' I1MACH(I) - I out of bounds'
CASE (3) ARGUMENT
WRITE (stdout,'(1x,''I1MACH(3): The code tried to get &
&the standard punch unit number.''/,12x,''This unit &
&number is obsolete and the code should be updated.'')')
STOP ' I1MACH(3): Obsolete argument value (3 - Standard Punch)'
CASE (6) ARGUMENT
WRITE (stdout,'(1x,''I1MACH(6): The code tried to get &
&the number of character storage units per''/,12x,''integer &
&storage unit. It probably wants to do some trickery &
&like''/,12x,''EQUIVALENCE and the code should be updated.'')')
STOP ' I1MACH(6): Obsolete argument value (6 - #Characters/Integer)'
END SELECT ARGUMENT
i1mach = i1mach_values(i)
RETURN
END FUNCTION i1mach
!!!===================================================================
FUNCTION r1mach(i)
!!!-------------------------------------------------------------------
!!!
!!! This function is intended to replace the old R1MACH by using F90
!!! intrinsic functions. The parameter SPKIND is described above.
!!!
!!!
!!! The traditional R1MACH constants are ...
!!!
!!!
!!! -- SINGLE-PRECISION MACHINE CONSTANTS ( here REAL (SPKIND) ) --
!!!
!!! R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
!!!
!!! R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
!!!
!!! R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING.
!!!
!!! R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING.
!!!
!!! R1MACH(5) = LOG10(B)
!!!
!!!-------------------------------------------------------------------
! .. Implicit None Statement ..
IMPLICIT NONE
! ..
! .. Function Return Value ..
REAL (spkind) :: r1mach
! ..
! .. Scalar Arguments ..
INTEGER :: i
! ..
! .. Local Scalars ..
LOGICAL, SAVE :: qfirst_call = .TRUE.
! ..
! .. Local Arrays ..
REAL (spkind), SAVE :: r1mach_values(5)
! ..
! .. Intrinsic Functions ..
INTRINSIC digits, epsilon, huge, log10, radix, real, tiny
! ..
! .. Executable Statements ..
IF (i<1 .OR. i>5) THEN
WRITE (stdout,'(1x,''R1MACH(I) - I out of bounds, I ='',i10)') i
STOP ' R1MACH(I) - I out of bounds'
END IF
IF (qfirst_call) THEN
r1mach_values = (/ tiny(1.0E0_spkind), huge(1.0E0_spkind), &
real(radix(1.0E0_spkind),spkind)**(-digits(1.0E0_spkind)), &
epsilon(1.0E0_spkind), log10(real(radix(1.0E0_spkind),spkind)) /)
qfirst_call = .FALSE.
END IF
r1mach = r1mach_values(i)
RETURN
END FUNCTION r1mach
END MODULE constants
--
John Jeffrey Venier, B.A., M.Stat. Programmer Analyst III
Section of Computer Science Department of Biomathematics
The University of Texas M. D. Anderson Cancer Center, Houston, Texas
[log in to unmask] +1 713 792 2622
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
