unit_tests.f90 Source File

!> A module containing functions for running unit tests
module unit_tests
  implicit none

  private

  !> Is the relative error of the first argument with respect
  !> to the correct answer less than err?
  !> If the correct value is 0.0, then err is treated as an
  !> absolute error
  public :: agrees_with

  !> Announce the start of the given test (to let the user know
  !> which one failed!)
  public :: announce_test

  !> Take the logical result of the test (true for pass), and
  !> either announce its success or announce its failure then stop.
  public :: process_test


  !> Announce the start of the given partial test (to let the user know
  !> which one failed!)
  public :: announce_check

  !> Take the logical result of the check (partial test) (true for pass), and
  !> either announce its success or announce its failure.
  public :: process_check

  !> Returns true when the verbosity is greater than or equal to the argument
  public :: should_print

  !> Print a debug message if verbosity is higher than given verbosity_level.
  !> Also print list mode/trinity job id if appropriate
  public :: debug_message

  !> Set job id, for running in list mode or within trinity
  public :: set_job_id

  public :: announce_module_test
  public :: close_module_test

  public :: print_with_stars

  !> Trinity or list mode job id
  public :: job_id
  integer :: job_id

  interface agrees_with
     module procedure agrees_with_real
     module procedure agrees_with_real_1d_array
     module procedure agrees_with_complex_1d_array
     module procedure agrees_with_integer
  end interface agrees_with

  interface should_be
     module procedure should_be_int
     module procedure should_be_real
  end interface should_be

contains

  function proc_message()
    use mp, only: iproc
    character(16) :: proc_message
    write(proc_message, '(A10,I2)') ' on iproc ', iproc
  end function proc_message

  function agrees_with_integer(val, correct)
    integer, intent(in) :: val, correct
    logical :: agrees_with_integer
    call should_be(val, correct)
    agrees_with_integer = (val == correct)
  end function agrees_with_integer

  function agrees_with_complex_1d_array(val, correct, err)
    complex, dimension(:), intent(in) :: val, correct
    real, intent(in) :: err
    logical :: agrees_with_complex_1d_array
    integer :: n
    n = size(val)
    agrees_with_complex_1d_array = &
         agrees_with_real_1d_array(real(val), real(correct), err) .and.  &
         agrees_with_real_1d_array(aimag(val), aimag(correct), err)

  end function agrees_with_complex_1d_array

  function agrees_with_real_1d_array(val, correct, err)
    real, dimension(:), intent(in) :: val, correct
    real, intent(in) :: err
    logical :: agrees_with_real_1d_array
    integer :: n, i
    n = size(val)
    agrees_with_real_1d_array = .true.
    do i = 1,n

       !call should_be(val(i), correct(i))
       !if (correct(i) .eq. 0.0 .or. abs(correct(i)) .lt. 10.0**(-maxexponent(err)/4)) then
       !agrees_with_real_1d_array = agrees_with_real_1d_array .and. (abs(val(i)) .lt. err)
       !else
       !agrees_with_real_1d_array = agrees_with_real_1d_array .and. &
       !(abs((val(i)-correct(i))/correct(i)) .lt. err)
       !end if
       agrees_with_real_1d_array = agrees_with_real_1d_array .and. &
            agrees_with_real(val(i), correct(i), err)
       if (.not. agrees_with_real_1d_array) exit
    end do
  end function agrees_with_real_1d_array

  function agrees_with_real(val, correct, err)
    use warning_helpers, only: is_zero
    real, intent(in) :: val, correct, err
    logical :: agrees_with_real
    call should_be(val, correct)
    if (is_zero(correct) .or. abs(correct) < 10.0**(-maxexponent(err)/4)) then
       agrees_with_real = abs(val) < err
    else
       agrees_with_real = (abs((val-correct)/correct) < err)
    end if
  end function agrees_with_real

  function should_print(verbosity_level)
    use runtime_tests, only: verbosity
    use mp, only: proc0, mp_initialized
    integer, intent(in) :: verbosity_level
    logical :: should_print
    if (mp_initialized) then
      should_print = (proc0 .and. verbosity() >= verbosity_level) .or. verbosity() > 3
    else
      should_print = (verbosity() >= verbosity_level)
    end if
  end function should_print

  subroutine should_be_int(val, rslt)
    integer, intent(in) :: val, rslt
    if (should_print(3)) write (*,*) '      Value: ', val, ' should be ', rslt, proc_message()
  end subroutine should_be_int

  subroutine should_be_real(val, rslt)
    real, intent(in) :: val, rslt
    if (should_print(3)) write (*,*) '      Value: ', val, ' should be ', rslt, proc_message()
  end subroutine should_be_real

  subroutine announce_test(test_name)
    character(*), intent(in) :: test_name
    if (should_print(1)) write (*,*) '--> Testing ', test_name, proc_message()
  end subroutine announce_test

  subroutine process_test(rslt, test_name)
    use mp, only: mp_abort, mp_initialized
    logical, intent (in) :: rslt
    character(*), intent(in) :: test_name
    if (.not. rslt) then
      write(*,*) '--> ', test_name, ' failed', proc_message()
      if (mp_initialized) then
        call mp_abort('Failed test', .true.)
      else
        stop 1
      end if
    end if

    if (should_print(1)) write (*,*) '--> ', test_name, ' passed', proc_message()
  end subroutine process_test

  subroutine announce_check(test_name)
    character(*), intent(in) :: test_name
    if (should_print(2)) write (*,*) '   --> Checking ', test_name, proc_message()
  end subroutine announce_check

  subroutine process_check(test_result, rslt, test_name)
    logical, intent (inout) :: test_result
    logical, intent (in) :: rslt
    character(*), intent(in) :: test_name
    if (.not. rslt) then
       write(*,*) '   --> ', test_name, ' failed', proc_message()
    else
       if (should_print(2)) write (*,*) '   --> ', test_name, ' passed', proc_message()
    end if
    test_result = test_result .and. rslt
  end subroutine process_check

  subroutine announce_module_test(module_name)
    character(*), intent(in) :: module_name
    character(8), parameter :: message = 'Testing '
    if (should_print(1)) call print_with_stars(message, module_name)
  end subroutine announce_module_test

  subroutine close_module_test(module_name)
    character(*), intent(in) :: module_name
    character(17), parameter :: message = 'Finished testing '
    if (should_print(1)) then
       call print_with_stars(message, module_name)
       write (*,*)
    end if
  end subroutine close_module_test

  subroutine print_with_stars(str1, str2)
    character(*), intent (in) :: str1, str2
    character, dimension(:), allocatable :: stars
    integer :: i

    allocate(stars(len(str1) + len(str2) + len(proc_message()) ))
    do i = 1,len(str1)+len(str2)+len(proc_message())
       stars(i) = '*'
    end do

    write (*,*) stars
    write (*,*) str1, str2, proc_message()
    write (*,*) stars
  end subroutine print_with_stars

  subroutine debug_message(verbosity_level, message)
    use mp, only: iproc, mp_initialized
    integer, intent(in) :: verbosity_level
    character(*), intent(in) :: message
    if (mp_initialized) then
      if (should_print(verbosity_level)) write (*,"(A,A5,I6,A7,I6)") message, " jid=", job_id, &
        " iproc=", iproc
    else
      if (should_print(verbosity_level)) write (*,"(A,A5,I6,A7,I6)") message, " jid=", job_id
    end if
  end subroutine debug_message

  subroutine set_job_id(jid)
    integer, intent(in) :: jid
    job_id = jid
  end subroutine set_job_id

end module unit_tests