MODULE oracle
! This module provides routines to
!  a) generate sp and dp random vectors with values 
!     and length user defined.
!  b) use an extended precision square and add loop
!     to compute an oracle value for the Euclidean norm
!  c) compute the relative error between a given value 
!     (computed by one of the routines under test) and the
!     currently stored oracle value. These routines also
!     return this error in terms of the number of ulps.
!     If the oracle value is zero the absolute error is used.

USE set_precision, ONLY : sp=>skind, dp=>dkind
USE randMod, ONLY : seed, rand=>dpPortRand
USE mpmodule

REAL(KIND=sp), PARAMETER :: spZero = 0.0E0_sp
REAL(KIND=sp), PARAMETER :: spThreeHalves = 1.5E0_sp
REAL(KIND=sp), PARAMETER :: spOne = 1.0E0_sp
REAL(KIND=sp), PARAMETER :: spTwo = 2.0E0_sp
REAL(KIND=dp), PARAMETER :: dpZero = 0.0E0_dp
REAL(KIND=dp), PARAMETER :: dpThreeHalves = 1.5E0_dp
REAL(KIND=dp), PARAMETER :: dpOne = 1.0E0_dp
REAL(KIND=dp), PARAMETER :: dpTwo = 2.0E0_dp
REAL(KIND=sp), PARAMETER :: spEps = epsilon(spZero)/spTwo
REAL(KIND=sp), PARAMETER :: maxSpReal = huge(spZero)
REAL(KIND=dp), PARAMETER :: dpEps = epsilon(dpZero)/spTwo
REAL(KIND=dp), PARAMETER :: maxDpReal = huge(dpZero)

! The logical variable normOverFlow is used
! to communicate the (hopefully) never occuring
! situation where the random vector generated for benchmarking
! would cause an overflow if used in the requested precision.
! Note: the oracle is always computed using both extended
! precision and an extended exponent range.
! 
! If the data range has been set to (0,1) then there is some
! major problem with the software. Otherwise the situation
! could occur if the range of values requested was inappropriate
! for the precision.
!
! In both cases the best course of action is probably to output
! an appropriate message and STOP. We choose to do this in
! the codes that use the VecOracle routines in the current
! package.
LOGICAL :: normOverFlow

TYPE(mp_real) :: mpOracle
REAL(KIND=dp) :: dpOracle

INTERFACE VecOracle
  MODULE PROCEDURE dpVecOracle, spVecOracle
END INTERFACE VecOracle

INTERFACE Errors
  MODULE PROCEDURE dpErrors, spErrors
END INTERFACE Errors

CONTAINS

  SUBROUTINE spVecOracle(x)
  REAL(KIND=sp), INTENT(IN) :: x(:)
! Use a double precision square and add loop to obtain
! an oracle value for the Euclidean norm of x. This will
! work without overflow for IEEE sp input provided n is
! not so big the program won't run for years!
!
! The value is stored in the module variable dpOracle
  INTEGER ::  i

  dpOracle = dpZero
  DO i = 1, SIZE(x)
    dpOracle = dpOracle + REAL(x(i), KIND=dp)*REAL(x(i), KIND=dp)
  END DO

  dpOracle = SQRT(dpOracle)

! Test for overflow if calculation performed in sp
  normOverFlow = (dpOracle > maxSpReal)

  END SUBROUTINE spVecOracle

  SUBROUTINE dpVecOracle(x)
  REAL(KIND=dp), INTENT(IN) :: x(:)
! Use a multiple precision square and add loop to obtain
! an oracle value for the Euclidean norm of x. This will
! work without overflow for IEEE dp input provided n is
! not so big the program won't run for years!
!
! The value is stored in the module variable mpOracle
  TYPE(mp_real) :: mpTemp
  INTEGER :: i

  mpOracle = dpZero
  DO i = 1, SIZE(x)
    mpTemp = x(i)
    mpOracle = mpOracle + mpTemp*mpTemp
  END DO

  mpOracle = SQRT(mpOracle)

! Test for overflow if calculation performed in dp
  normOverFlow = (mpOracle > maxDpReal)

  END SUBROUTINE dpVecOracle

  SUBROUTINE initialize(dpSet)
  LOGICAL, INTENT(IN) :: dpset
! Initialize a number of values required by the random
! number generators and the multiple precision package
!
! For multiple precision we certainly don't require accuracy
! of more than twice the precision available from double
! precision and we could get away with a lot less!
! The exponent range is more than enough to cope with IEEE
! double precision.

  INTEGER, PARAMETER :: dpPrec = 2*precision(dpZero)
! Only initialize the multiple precision package if
! it's going to be required -- i.e., double precision
! data is being benchmarked
  IF (dpSet) CALL mpinit(dpPrec)
!
! Initialize the double precision random number generator
! Changing the two values will provide different sequences
! of random numbers.
!
! For the uni64 generator
! CALL fillu(123456789, 987654321)
!
! For the simple portrand generator (needs calling for both
! single and double precision data)
  CALL seed(42)

! A call to random_seed may also be used here to change the
! sequence of single precision random numbers used.
! Note: that this call may be platform dependent.
!
  END SUBROUTINE initialize

  SUBROUTINE spErrors(valComp, relErr, Ulps)
  REAL(KIND=sp), INTENT(IN) :: valComp
  REAL(KIND=sp), INTENT(OUT) :: relErr, Ulps
! Calculates the relative error and the number of ulps between
! the value of valComp and the current oracle value, dpOracle
! Returns the absolute difference if dpOracle is zero.
! 
  REAL(KIND=dp) :: error

  error = dpOracle - REAL(valComp, KIND=dp)

  IF (dpOracle /= dpZero) THEN
    error = error/ABS(dpOracle)
  END IF

  relErr = REAL(error, KIND=sp)
  Ulps = spZero
  IF (ABS(relErr)>=speps) THEN
    Ulps = REAL(INT(relErr/spEps), KIND=sp)
  END IF

  END SUBROUTINE spErrors

  SUBROUTINE dpErrors(valComp, relErr, Ulps)
  REAL(KIND=dp), INTENT(IN) :: valComp
  REAL(KIND=sp), INTENT(OUT) :: relErr, Ulps
! Calculates the relative error and the number of ulps between
! the value of valComp and the current oracle value, mpOracle
! Returns the absolute difference if mpOracle is zero.
! 
  TYPE(mp_real) :: error
  REAL(KIND=dp) :: temp

  error = mpOracle - valComp

  IF (mpOracle /= dpZero) THEN
    error = error/ABS(mpOracle)
  END IF

  temp = error
  relErr = REAL(temp, KIND=sp)
  Ulps = REAL(INT(error/dpEps), KIND=sp)

  END SUBROUTINE dpErrors

END MODULE oracle

