MODULE checkTests
USE, INTRINSIC :: ieee_exceptions
USE, INTRINSIC :: ieee_arithmetic
USE set_precision, ONLY : skind, dkind
! Module to check the results obtained for each test case
! are correct and to output results at a level of detail 
! chosen by the tester.
!
! We currently allow three levels:
! 1. Detailed --- full output of all test results
! 2. Intermediate --- compressed output of all results
! 3. Concise --- only details of unexpected results are output
!
! By default the output level is 3, any attempt to set this value
! out of range will result in the default level being chosen. This
! value may only be changed via a call to the mutator routine 
! setOutputLevel
! 
! In all arrays that store status information regarding the IEEE 
! trap flags the ordering used is
! 1. overflow
! 2. divide by zero
! 3. invalid
! 4. underflow
! 5. inexact
!
! Module variables
!
! outputLevel controls the amount of output generated during the
! running of the test suite (see above for details)
! maxLevel and minLevel provide the accepted range
! defaultLevel is set to the default and is also used if a user
! supplied value is out of range
  INTEGER, PARAMETER :: defaultLevel = 3
  INTEGER, PARAMETER :: minLevel = 1, maxLevel = 3
  INTEGER, PRIVATE :: outputLevel = 3

! Logical to control whether or not status flags are checked
! and reported. The value used here is set using setJustValues
  LOGICAL :: justValues

! Parameterize the number of IEEE status flags tested for
  INTEGER, PARAMETER :: nStatus = 5

! Define characters used in output/template array
  CHARACTER, PARAMETER :: chTrue = 'T', chFalse = 'F', &
    chUnsupported = 'X', space = ' '

! Template array that records the IEEE status flags supported
  CHARACTER :: template(nStatus)

! Variable used to count the number of tests and the number
! of failed tests when running the test suite
  INTEGER :: nFailedTests, nTests

! Variable allPassed is set TRUE if all supported status flags
! are as expected
  LOGICAL :: allPassed

! Format string used to output a real finite value this
! can change with the precision used
  CHARACTER (LEN=*), PARAMETER :: realFormatSp = '(e14.6)'
  CHARACTER (LEN=*), PARAMETER :: realFormatDp = '(e23.15)'

  REAL(dkind), PARAMETER :: zeroDp = 0.0e0_dkind
  REAL(skind), PARAMETER :: zeroSp = 0.0e0_skind

  INTERFACE setTemplate
    MODULE PROCEDURE setTemplateSp, setTemplateDp
  END INTERFACE setTemplate

  INTERFACE outputNonFinite
    MODULE PROCEDURE outputNonFiniteSp, outputNonFiniteDp
  END INTERFACE outputNonFinite

  INTERFACE outputError
    MODULE PROCEDURE outputErrorSp, outputErrorDp
  END INTERFACE outputError

  INTERFACE compareRes
    MODULE PROCEDURE compareResSp, compareResDp
  END INTERFACE compareRes

  INTERFACE outputRes
    MODULE PROCEDURE outputResSp, outputResDp
  END INTERFACE outputRes

  INTERFACE outputNone
    MODULE PROCEDURE outputNoneSp, outputNoneDp
  END INTERFACE outputNone

  INTERFACE outputHead
    MODULE PROCEDURE outputHeadSp, outputHeadDp
  END INTERFACE outputHead

  INTERFACE outputFlagsSpace
    MODULE PROCEDURE outputFlagsSpaceSp, outputFlagsSpaceDp
  END INTERFACE outputFlagsSpace

  PRIVATE outputResSp, outputResDp, outputNonFiniteSp, &
          outputNonFiniteDp, outputErrorSp, outputErrorDp, &
          compareResSp, compareResDp, outputNoneSp, outputNoneDp, &
          outputHeadSp, outputHeadDp, outputFlagsSpaceSp, &
          outputFlagsSpaceDp

CONTAINS

  SUBROUTINE setOutputLevel(newLevel)
  INTEGER, INTENT(IN) :: newLevel
! Mutator for the module variable outputLevel used to control the
! amount of output generated when running the test suite.
! newLevel should be one of 1, 2 or 3. If the user supplies a value
! outside of this range the value is silently set to the default value
! (see above)
  IF(newLevel<minLevel .OR. newLevel>maxLevel) THEN
    outputLevel = defaultLevel
  ELSE
    outputLevel = newLevel
  END IF

  END SUBROUTINE setOutputLevel

  SUBROUTINE setJustValues(value)
  LOGICAL, INTENT(IN) :: value
! Mutator used to (re)set the value of justValues. If this
! is set to true than only the values of the test are compared
! and reported. To include the status flags in the comparison 
! set justValues to false.
  justValues = value
  END SUBROUTINE setJustValues

  FUNCTION getOutputLevel() RESULT(level)
  INTEGER :: level
! Accessor to obtain current value of outputLevel
! Default value is 3 but this may be reset via
! the mutator function setOutputLevel

  level = outputLevel

  END FUNCTION getOutputLevel

  FUNCTION getJustValues() RESULT(res)
  LOGICAL :: res
! Mutator used to (re)set the value of justValues. If this
! is set to true then only the values of the test are compared
! and reported. To include the status flags in the comparison 
! set justValues to false.
  res = justValues
  END FUNCTION getJustValues

  SUBROUTINE setTemplateDp(zeroDp)
! Set the template array of characters. The individual values are space
! if the IEEE trap for the condition with the real precision being tested
! is available and chUnsupported otherwise.
  REAL(dkind), INTENT(IN) :: zeroDp
  
  template(1:nStatus) = space

  IF (.NOT.ieee_support_flag(ieee_overflow, zeroDp)) &
    template(1) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_divide_by_zero, zeroDp)) &
    template(2) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_invalid, zeroDp)) &
    template(3) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_underflow, zeroDp)) &
    template(4) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_inexact, zeroDp)) &
    template(5) = chUnsupported

  END SUBROUTINE setTemplateDp

  SUBROUTINE setTemplateSp(zeroSp)
! Set the template array of characters. The individual values are space
! if the IEEE trap for the condition with the real precision being tested
! is available and chUnsupported otherwise.
  REAL(skind), INTENT(IN) :: zeroSp
  
  template(1:nStatus) = space

  IF (.NOT.ieee_support_flag(ieee_overflow, zeroSp)) &
    template(1) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_divide_by_zero, zeroSp)) &
    template(2) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_invalid, zeroSp)) &
    template(3) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_underflow, zeroSp)) &
    template(4) = chUnsupported
  IF (.NOT.ieee_support_flag(ieee_inexact, zeroSp)) &
    template(5) = chUnsupported

  END SUBROUTINE setTemplateSp

  SUBROUTINE setStatusChars(flagsSet, flagChars)
  LOGICAL, INTENT(IN) :: flagsSet(nStatus)
  CHARACTER, INTENT(OUT) :: flagChars(nStatus)
! Given a logical array of status flags, return a character array
! such that flagChars(i) = chTrue or chFalse if the status flag
! is supported and set to .TRUE. and .FALSE. respectively and to
! chUnsupported if it is not supported.
! It is assumed that the routine setTemplate has been called prior
! to any calls to this routine so that unsupported flags have already
! been recorded in the template array: chUnsupported if unsupported
! and space otherwise.
  INTEGER :: i
  flagChars(1:nStatus) = template(1:nStatus)
  DO i = 1, nStatus
    IF (flagChars(i) == chUnsupported) CYCLE

! Flag is supported so set to either chTrue or chFlase
    IF (flagsSet(i)) THEN
      flagChars(i) = chTrue
    ELSE
      flagChars(i) = chFalse
    END IF
  END DO

  END SUBROUTINE setStatusChars

  FUNCTION checkStatusFlags(expFlags, retFlags) RESULT(passed)
  LOGICAL, INTENT(IN) :: expFlags(nStatus), retFlags(nStatus)
  LOGICAL :: passed
! Routine that sets the module variable allPassed to TRUE if all supported
! status flags are as expected and false otherwise
  INTEGER :: i
  
  passed = .TRUE.
  DO i = 1, nStatus
    IF (template(i) == chUnsupported) CYCLE
    passed = passed .AND. (expFlags(i) .EQV. retFlags(i))
  END DO

  END FUNCTION checkStatusFlags

  SUBROUTINE outputFlagChars(flags)
  LOGICAL, INTENT(IN) :: flags(nStatus)
! Routine to translate logical flags into characters and to
! output the character values. Values output can be chFalse,
! chTrue or chUnsupported
  CHARACTER :: chFlags(nStatus)

  CALL setStatusChars(flags, chFlags)

  WRITE(*, ADVANCE='NO', fmt='(3x,5(1x,a1))') chFlags
 
  END SUBROUTINE outputFlagChars

  SUBROUTINE outputResDp(res)
  REAL(dkind), INTENT(IN) :: res

! Routine to output a real value which could be finite or
! non-finite (NaN or Inf). A finite values is output using
! a normal formatted write; the non-finite value is output
! as a character string.

  IF (ieee_is_finite(res)) THEN
    WRITE(*, ADVANCE='NO', fmt=realFormatDp) res
  ELSE
    CALL outputNonFinite(res)
  END IF

  END SUBROUTINE outputResDp

  SUBROUTINE outputNonFiniteDp(res)
  REAL(dkind), INTENT(IN) :: res
! res is know to be a non-finite value when this routine is called.
! Output an appropriate character string. This string will be
! effectively left justified so the actual width used for a finite
! value should not matter.
  CHARACTER (LEN=:), ALLOCATABLE :: outstr

  IF (ieee_class(res) == ieee_signaling_nan) THEN
    outstr = 'Signal NaN'
  ELSE IF (ieee_class(res) == ieee_quiet_nan) THEN
    outstr = 'Quiet NaN'
  ELSE IF (ieee_class(res) == ieee_negative_inf) THEN
    outstr = '-Infinity'
  ELSE IF (ieee_class(res) == ieee_positive_inf) THEN
    outstr = '+Infinity'
  ELSE
    outstr = 'Illegal from routine outputNonFinite'
  ENDIF

  WRITE(*,ADVANCE='NO',fmt='(a23)') outstr

  END SUBROUTINE outputNonFiniteDp

  FUNCTION compareResDp(val1, val2) RESULT(passed)
  REAL(dkind), INTENT(IN) :: val1, val2
  LOGICAL :: passed
! Set pass to true if val1 and val2 are both non-finite
! and represent the same value; false otherwise.
! Set pass to false id one of val1, val2 is non-finite
! and the other is finite.
! Set pass to true if both values are finite and close
! enough (currently exact).
  IF (ieee_is_finite(val1) .NEQV. ieee_is_finite(val2)) THEN
! One is finite and the other non-finite
    passed = .FALSE.
  ELSE
! Both are finite or both are non-finite
    IF (ieee_is_finite(val1)) THEN
      passed = (val1 == val2)
    ELSE
      passed = (ieee_class(val1) == ieee_class(val2))
    END IF
  END IF

  END FUNCTION compareResDp

  SUBROUTINE outputErrorDp(expect, ret)
  REAL(dkind), INTENT(IN) :: expect, ret
! If expect and res are both finite then output the relative
! error; otherwise do nothing
  REAL(dkind) :: err

  IF (ieee_is_finite(expect) .AND. ieee_is_finite(ret)) THEN
    IF (expect == zeroDp) THEN
      err = ABS(ret)
    ELSE
      err = ABS((expect-ret)/expect)
    END IF
    CALL outputRes(err)
  END IF

  END SUBROUTINE outputErrorDp

  SUBROUTINE outputResSp(res)
  REAL(skind), INTENT(IN) :: res

! Routine to output a real value which could be finite or
! non-finite (NaN or Inf). A finite values is output using
! a normal formatted write; the non-finite value is output
! as a character string.

  IF (ieee_is_finite(res)) THEN
    WRITE(*, ADVANCE='NO', fmt=realFormatSp) res
  ELSE
    CALL outputNonFinite(res)
  END IF

  END SUBROUTINE outputResSp

  SUBROUTINE outputNonFiniteSp(res)
  REAL(skind), INTENT(IN) :: res
! res is know to be a non-finite value when this routine is called.
! Output an appropriate character string. This string will be
! effectively left justified so the actual width used for a finite
! value should not matter.
  CHARACTER (LEN=:), ALLOCATABLE :: outstr

  IF (ieee_class(res) == ieee_signaling_nan) THEN
    outstr = 'Signal NaN'
  ELSE IF (ieee_class(res) == ieee_quiet_nan) THEN
    outstr = 'Quiet NaN'
  ELSE IF (ieee_class(res) == ieee_negative_inf) THEN
    outstr = '-Infinity'
  ELSE IF (ieee_class(res) == ieee_positive_inf) THEN
    outstr = '+Infinity'
  ELSE
    outstr = 'Illegal from routine outputNonFinite'
  ENDIF

  WRITE(*,ADVANCE='NO',fmt='(a14)') outstr

  END SUBROUTINE outputNonFiniteSp

  FUNCTION compareResSp(val1, val2) RESULT(passed)
  REAL(skind), INTENT(IN) :: val1, val2
  LOGICAL :: passed
! Set pass to true if val1 and val2 are both non-finite
! and represent the same value; fasle otherwise.
! Set pass to false id one of val1, val2 is non-finite
! and the other is finite.
! Set pass to true if both values are finite and close
! enough (currently exact).
  IF (ieee_is_finite(val1) .NEQV. ieee_is_finite(val2)) THEN
! One is finite and the other non-finite
    passed = .FALSE.
  ELSE
! Both are finite or both are non-finite
    IF (ieee_is_finite(val1)) THEN
      passed = (val1 == val2)
    ELSE
      passed = (ieee_class(val1) == ieee_class(val2))
    END IF
  END IF

  END FUNCTION compareResSp

  SUBROUTINE outputErrorSp(expect, ret)
  REAL(skind), INTENT(IN) :: expect, ret
! If expect and res are both finite then output the relative
! error; otherwise do nothing
  REAL(skind) :: err

  IF (ieee_is_finite(expect) .AND. ieee_is_finite(ret)) THEN
    IF (expect == zeroSp) THEN
      err = ABS(ret)
    ELSE
      err = ABS((expect-ret)/expect)
    END IF
    CALL outputRes(err)
  END IF

  END SUBROUTINE outputErrorSp

  SUBROUTINE outputNoOfFails
! Output the number of failed tests during an execution
! of the test suite. 
!
! nFailedTests: # of tests failing
! nTests: # of separate tests executed the total number
!        of tests run is twice this (real and complex)
  WRITE(*,'()')

  IF (nFailedTests == 0) THEN
    WRITE(*, '(''********************************************'')')
    WRITE(*, '(''****** All Tests Passed Successfully *******'')')
    WRITE(*, '(''********************************************'')')
  ELSE
    WRITE(*, '(''************************************'')')
    WRITE(*,'(''******'',i3, '' of '',i3,'' Tests Failed ******'')') &
      nFailedTests, 2*nTests
    WRITE(*, '(''************************************'')')
  END IF

  WRITE(*,'(/)')

  END SUBROUTINE outputNoOfFails

  SUBROUTINE zeroTestCounts
  nFailedTests = 0
  nTests = 0
  END SUBROUTINE zeroTestCounts

  SUBROUTINE outputNoneSp(val)
  REAL(skind), INTENT(IN) :: val
! val is just used to identify the routine as single
! precision

  WRITE(*, '(6x,''NONE'',4x)',ADVANCE='NO')

  END SUBROUTINE outputNoneSp

  SUBROUTINE outputNoneDp(val)
  REAL(dkind), INTENT(IN) :: val
! val is just used to identify the routine as single
! precision

  WRITE(*, '(10x,''NONE'',9x)',ADVANCE='NO')

  END SUBROUTINE outputNoneDp

  SUBROUTINE outputHeadSp(val, justValues)
  REAL(skind), INTENT(IN) :: val
  LOGICAL, INTENT(IN) :: justValues
! val is just used to identify the routine as single
! precision

  IF (justValues) THEN
    WRITE(*,'(1x,''Test '',15x,''Value'')') 
    WRITE(*,'(''Number'',6x,''Returned'',8X,''Error'')')
    WRITE(*,'(''------'',6x,''--------'',8x,''-----'')')
  ELSE
! Output header 
    WRITE(*,'(1x,''Test '',15x,''Value'',16x,''Flags'')') 
    WRITE(*,'(''Number'',6x,''Returned'',8x,''Error'',7x,''Expected'')')
    WRITE(*,'(''------'',6x,''--------'',8x,''-----'',7x,''--------'')')
  END IF
  END SUBROUTINE outputHeadSp

  SUBROUTINE outputHeadDp(val, justValues)
  REAL(dkind), INTENT(IN) :: val
  LOGICAL, INTENT(IN) :: justValues
! val is just used to identify the routine as single
! precision

  IF (justValues) THEN
    WRITE(*,'(1x,''Test '',26x,''Value'',18x)') 
    WRITE(*,'(''Number'',11x,''Returned'',16x,''Error'')')
    WRITE(*,'(''------'',11x,''--------'',16x,''-----'')')
  ELSE
! Output header 
    WRITE(*,'(1x,''Test '',26x,''Value'',23X,''Flags'')') 
    WRITE(*,'(''Number'',11x,''Returned'',16x,''Error'',12X,''Expected'')')
    WRITE(*,'(''------'',11x,''--------'',16x,''-----'',12X,''--------'')')
  END IF

  END SUBROUTINE outputHeadDp

  SUBROUTINE outputFlagsSpaceSp(val)
  REAL(skind), INTENT(IN) :: val
! val is just used to identify the routine as single
! precision

  WRITE(*,'(36x)', ADVANCE='NO')

  END SUBROUTINE outputFlagsSpaceSp

  SUBROUTINE outputFlagsSpaceDp(val)
  REAL(dkind), INTENT(IN) :: val
! val is just used to identify the routine as single
! precision

  WRITE(*,'(54X)', ADVANCE='NO')

  END SUBROUTINE outputFlagsSpaceDp

  

  END MODULE checkTests
