Next: B.2.4 MaxVal_Real_Scalar Procedure Up: B.2 Real Class Code Previous: B.2.2 Finalize_Real Procedure
The main documentation of the Valid_State_Real Procedure contains additional explanation of this code listing.
! Turn off checking which involves division by zero for some compilers
! that allow error trapping.
! For Suns, you could either
! - not set DIVISION_BY_ZERO and use no compiler flags, or
! - set DIVISION_BY_ZERO and use -ftrap=%none.
! For Intel/NAGWare, you could either
! - not set DIVISION_BY_ZERO and use no compiler flags, or
! - set DIVISION_BY_ZERO and use -ieee=full.
ifelse(
ARCHITECTURE, Sun,
[],
ARCHITECTURE, SGI,
[define([DIVISION_BY_ZERO],1)],
ARCHITECTURE, Intel, [
ifelse(
COMPILER, NAGWare,
[],
[define([DIVISION_BY_ZERO],1)]
)],
ARCHITECTURE, Apple,
[define([DIVISION_BY_ZERO],1)]
)
define([REPLICATE_ROUTINE],[
ifelse(POINTER_TOGGLE, [TRUE], [
pushdef([TYPE], [real,$1])
pushdef([Valid_State_Real_P_DIM], expand(Valid_State_Real_P_$1))
pushdef([POINTER_ONLY], [])
],[
pushdef([TYPE], [real,$1,np])
pushdef([Valid_State_Real_P_DIM], expand(Valid_State_Real_NP_$1))
pushdef([POINTER_ONLY], [!])
])
function Valid_State_Real_P_DIM (R) result(Valid)
! Use association information.
SCALAR_ONLY use Caesar_Flags_Module, only: finalize_real_flag
SCALAR_ONLY use Caesar_Logical_Class, only: ALL
! Input variable.
type(TYPE) :: R ! Variable to be checked.
! Output variable.
type(logical) :: Valid ! Logical state.
! Internal variables.
type(real) :: one, ten, zero ! Numbers are not parameterized
! to fool smart compilers.
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Set numbers carefully (so that the compiler
! doesn't know that zero=0).
ten = 1.d1
one = 1.d0
zero = one - one
! Start out true.
Valid = .true.
! First, make sure that the variable has been allocated.
POINTER_ONLY ARRAY_ONLY Valid = Valid .and. ASSOCIATED(R)
POINTER_ONLY ARRAY_ONLY if (.not.Valid) return
! Make sure the variable has not been finalized.
SCALAR_ONLY Valid = Valid .and. R /= finalize_real_flag
! Check for Infs. This check determines whether R(1-e) = R, where e
! is a small number. This should only be true if R = 0 or if R is
! not a valid number.
!
! Pass Table:
! Intel Intel Intel Intel Apple Sun SGI IBM
! Lahey Absoft NAGWare PGI Absoft
! Infinity Fail Fail Fail Fail Fail Fail Fail Fail
! -Infinity Fail Fail Fail Fail Fail Fail Fail Fail
! NaN Pass Pass Pass Pass Pass Pass Pass Pass
Valid = Valid .and. ALL(R == zero .or. R*(one - ten*EPSILON(one)) /= R)
TESTWRITE (6,100) 'Test 1, R(1-e) = R ==>', &
IF_UNIT_TEST ALL(R == zero .or. R*(one - ten*EPSILON(one)) /= R)
! For IEEE-conforming reals, the following is (supposedly) a check
! for NaNs.
!
! Pass Table (test 2):
! Intel Intel Intel Intel Apple Sun SGI IBM
! Lahey Absoft NAGWare PGI Absoft
! Infinity Pass Pass Pass Pass Pass Pass Pass Pass
! -Infinity Pass Pass Pass Pass Pass Pass Pass Pass
! NaN Pass Fail Fail Pass Fail Fail Pass Fail
!
! NaN behavior details:
!
! Intel/Lahey (pre-L6.20c), Intel/Absoft, Intel/NAGWare
! (with -ieee=full), Apple/Absoft and Sun (with -ftrap=%none):
! Fail on tests 2 and 2a, but pass on 2b, for scalars.
! Fail on test 2, but pass on 2a and 2b, for arrays.
! Intel/Lahey:
! With the L6.20c compiler, the behavior is:
! Fail on test2a, but pass on 2 and 2b, for scalars.
! Passes on tests 2, 2a and 2b, for arrays.
! In other words, since test 2 passes for both scalars and arrays,
! this is not a good test for the Lahey compiler.
! Sun:
! Changed behavior after the 107356-02 patch; the new behavior
! is reflected here. So, with the Sun 5.0 compiler with 107377-02
! and 107356-02 patches, and the -ftrap=%none flag set to disable
! exception trapping, this now works as a check for NaNs.
! IBM:
! Fails on tests 2 and 2a, but passes on 2b. (Recheck behavior with
! arrays to see if it is the same as some other compilers above if
! IBM access is regained.)
Valid = Valid .and. ALL(R == R)
TESTWRITE (6,100) 'Test 2, R == R ==>', ALL(R == R)
TESTWRITE (6,100) 'Test 2a, .not.(R /= R) ==>', .not. ALL((R /= R))
TESTWRITE (6,100) 'Test 2b, .not.(R < R) ==>', .not. ALL((R < R))
! Create an infinity and check to verify inequality.
!
! Pass Table:
! Intel Intel Intel Intel Apple Sun SGI IBM
! Lahey Absoft NAGWare PGI Absoft
! Infinity Fail Fail Fail Fail Fail Fail Fail Fail
! -Infinity Pass Pass Pass Pass Pass Pass Pass Pass
! NaN Pass Pass Pass Fail Pass Pass Pass Pass
ifdef([DIVISION_BY_ZERO],[
Valid = Valid .and. ALL(one/zero /= R)
TESTWRITE (6,100) 'Test 3, Infinity /= R ==>', ALL(one/zero /= R)
])
! Create a negative infinity and check to verify inequality.
!
! Pass Table:
! Intel Intel Intel Intel Apple Sun SGI IBM
! Lahey Absoft NAGWare PGI Absoft
! Infinity Pass Pass Pass Pass Pass Pass Pass Pass
! -Infinity Fail Fail Fail Fail Fail Fail Fail Fail
! NaN Pass Pass Pass Fail Pass Pass Pass Pass
ifdef([DIVISION_BY_ZERO],[
Valid = Valid .and. ALL(-one/zero /= R)
TESTWRITE (6,100) 'Test 4, -Infinity /= R ==>', ALL(-one/zero /= R)
])
! Create a NaN and check to verify inequality.
!
! Pass Table:
! Intel Intel Intel Intel Apple Sun SGI IBM
! Lahey Absoft NAGWare PGI Absoft
! Infinity Pass Pass Pass Fail Pass Pass Pass Pass
! -Infinity Pass Pass Pass Fail Pass Pass Pass Pass
! NaN Pass Pass Pass Fail Pass Pass Pass Pass
!
! This test does not work for any compiler yet. It seems to work for
! Intel/PGI from the above table, but the test also fails for all valid
! real numbers, so it can't be used.
ifdef([DIVISION_BY_ZERO],[
ifelse(
COMPILER, PGI,
[], [
Valid = Valid .and. ALL(zero/zero /= R)
TESTWRITE (6,100) 'Test 5, NaN /= R ==>', ALL(zero/zero /= R)
])
])
! Check the top of the range.
!
! Pass Table:
! Intel Intel Intel Intel Apple Sun SGI IBM
! Lahey Absoft NAGWare PGI Absoft
! Infinity Fail Fail Fail Fail Fail Fail Fail Fail
! -Infinity Pass Pass Pass Pass Pass Pass Pass Pass
! NaN Fail Fail Fail Pass Fail Fail Fail Fail
Valid = Valid .and. ALL(R <= HUGE(R))
TESTWRITE (6,100) 'Test 6, R <= HUGE(R) ==>', ALL(R <= HUGE(R))
! Note that there is no explicit check for the bottom of the
! range, since there is no F90 intrinsic that returns the lowest
! negative number that a real can take.
! Format statement.
IF_UNIT_TEST 100 format (2x, a, 1x, l1)
return
end function Valid_State_Real_P_DIM
popdef([TYPE])
popdef([Valid_State_Real_P_DIM])
popdef([POINTER_ONLY])
])
define([POINTER_TOGGLE], [TRUE])
REPLICATE
define([POINTER_TOGGLE], [FALSE])
REPLICATE