cafut.f90 Source File


Contents

Source Code


Source Code

module cafut

use iso_fortran_env, only: real64

implicit none

!> Define real number kind.
integer, private, parameter :: wp = real64

!> Define maximum name length.
integer, private, parameter :: NAME_LENGTH = 20

!> Define margin of floating point error for real value comparissons.
real(kind=real64), private, parameter :: default_eps = 1.0d-5

!> Format of the start of a unit test.
character(len=*), private, parameter :: TEST_START = &
    '("==================== ", A, " ====================")'

!> Format of the end of a unit test.
character(len=*), private, parameter :: TEST_END = &
    '(A, " FINISHED WITH ", I3, "/", I3, " TESTS PASSED")'

!> Format of the start of a unit test.
character(len=*), private, parameter :: SUBTEST_START = &
    '("> ", A20)'

!> Format of the end of a unit test.
character(len=*), private, parameter :: SUBTEST_END = &
    '("finished with" , I3, "/", I3, " images passed")'

!> Format of the failure description of an image comparing real values.
character(len=*), private, parameter :: SINGLE_VAL_FMT = &
    '(">> TEST FAILED | Image: ", I3, " | Got: ", F10.5, " | Expected: ", F10.5)'

!> Format of the header for a failed test of an image comparring arrays.
character(len=*), private, parameter :: ARR_VAL_IMG = &
    '(">> Image: ", I3)'

!> String preceeding result array.
character(len=*), private, parameter :: ARR_VAL_RES = &
    ">>> Got: "

!> String preceeding expected array.
character(len=*), private, parameter :: ARR_VAL_EXP = &
    ">>> Expected: "

type, public :: TestSuite
    !! Holds tests and manages their executtion.
    !! Represents a set of procedures to test a certain feature.
    !! First node of the test linked list.

    integer, private :: n_tests
        !! Number of tests in a test suite.
    character(len=NAME_LENGTH), private :: test_suite_name
        !! Name of the test suite.
    class(Test), public, pointer :: test
        !! Current test whose attributes are available to be set.

contains

    procedure, public, pass :: addUnitTest
    procedure, private, pass :: addTestRealVal
    procedure, private, pass :: addTestRealArrVal
    generic, public :: add => addUnitTest, addTestRealVal, addTestRealArrVal

    procedure, public, pass :: runTests
    final :: deleteTestSuite

end type TestSuite

interface TestSuite
    !! Constructor interface for a TestSuite object.

    module procedure newTestSuite
end interface TestSuite

type, abstract, private :: Test
    !! Abstract class for a single test case. A node in the test linked list.

    character(len=NAME_LENGTH), public :: test_name
        !! Name of the test case.
    class(Test), private, pointer :: next
        !! Next test case or null() if this is the first test inserted (last
        !! test in the linked list).
contains
    procedure(runInterface), deferred, pass :: run
end type Test

abstract interface
    function runInterface(self) result(tests_passed)
        !! Abstract function interface for running a test.

        import Test
        class(Test), intent(in) :: self
            !! The test itself. The Test object should contain all information
            !! needed to run the test.
        integer :: tests_passed
            !! Return total number of tests which passed in the linked list
            !! up to and including this test.
    end function runInterface
end interface

type, public, extends(Test) :: TestRealVal
    !! Test performed on single real values.

    procedure(realCompInterface), public, nopass, pointer :: compare
        !! Pointer to a comparisson function used to perform the test.
    real(kind=wp), private :: eps
        !! Allowed margin of error between real numbers
    real(kind=wp), public :: res
        !! Real value result from some process.
    real(kind=wp), public :: tgt
        !! Target real value result for some process.
contains
    procedure, public, pass :: run => runTestRealVal
    procedure, private, nopass :: printFail => printFailTestRealVal
    final :: deleteTestRealVal
end type TestRealVal

interface TestRealVal
    !! Constructor interface for a TestRealVal object.

    module procedure newTestRealVal_name
end interface TestRealVal

interface
    function realCompInterface(res, tgt, eps) result(comp)
        !! Abstract function interface for a value comparisson function.

        import wp
        real(kind=wp), intent(in) :: res
            !! Result being tested.
        real(kind=wp), intent(in) :: tgt
            !! Target value used to compare result to.
        real(kind=wp) :: eps
            !! Allowed margin of error
        logical :: comp
            !! Return whether or not the test succeeded based on a comparrison.
    end function realCompInterface
end interface

type, public, extends(Test) :: TestRealArrVal
        !! Test performed on an array of real values.

    procedure(realArrCompInterface), nopass, pointer :: compare
        !! Pointer to a comparisson function used to perform the test.

    real(kind=wp), private :: eps
        !! Allowed margin of error between real numbers
    real(kind=wp), public, allocatable, dimension(:) :: res
        !! Real array result from some process.
    real(kind=wp), public, allocatable, dimension(:) :: tgt
        !! Target real array result for some process.
contains
    procedure, public, pass :: run => runTestRealArrVal
    procedure, private, nopass :: printFail => printFailTestRealArrVal
    final :: deleteTestRealArrVal
end type TestRealArrVal

interface TestRealArrVal
    !! Constructor interface for a TestRealArrVal object.

    module procedure newTestRealArrVal_name
end interface TestRealArrVal

interface
    function realArrCompInterface(res, tgt, eps) result(comp)
        !! Abstract function interface for an array comparisson function.
        import wp
        real(kind=wp), dimension(:), intent(in) :: res, tgt
            !! See res and tgt in TestRealArrVal class.
        real(kind=wp) :: eps
            !! Allowed margin of error
        logical :: comp
            !! Return whether or not the test succeeded based on a comparrison.
    end function realArrCompInterface
end interface

contains

! TestSuite
! =========

function newTestSuite(ts_name) result(new_ts)
    !! Construct a new test suite.

    character(len=*), intent(in) :: ts_name
        !! Name of the test suite.
    type(TestSuite) :: new_ts
        !! Return the new test suite.

    new_ts%n_tests = 0
    new_ts%test => null()

    new_ts%test_suite_name = ts_name
end function newTestSuite

subroutine deleteTestSuite(self)
    !! Destruct a test suite by deallocating its test pointer attribute.
    type(TestSuite), intent(inout) :: self

    deallocate(self%test)
end subroutine deleteTestSuite

subroutine runTests(self)
    !! Run all tests contained in a test suite.

    class(TestSuite), intent(in) :: self

    integer :: tot_passed

    if (this_image() == 1) then
        print TEST_START, trim(self%test_suite_name)
    end if

    tot_passed = 0
    if (associated(self%test)) tot_passed = self%test%run()

    if (this_image() == 1) then
        print TEST_END, trim(self%test_suite_name), tot_passed, self%n_tests
    end if
end subroutine runTests

subroutine addUnitTest(self, ut)
    !! Add a Test object to the test suite and make it available for setup.

    class(TestSuite), intent(inout) :: self
    class(Test), target, intent(inout) :: ut
        !! Object derived from the Test abstract type.

    class(Test), pointer :: next

    if (this_image() == 1) self%n_tests = self%n_tests + 1

    if (associated(self%test)) allocate(next, source=self%test)
    next => self%test

    ut%next => next
    self%test => ut
end subroutine addUnitTest

subroutine addTestRealVal(self, ut, res, tgt)
    !! Compact alternative to add a TestRealVal object to the test suite.

    class(TestSuite), intent(inout) :: self
    type(TestRealVal), intent(in) :: ut
        !! An initialized TestRealVal object with the desired name.
    real(kind=wp), intent(in) :: res, tgt
        !! See TestRealVal.

    class(Test), pointer :: next

    if (this_image() == 1) self%n_tests = self%n_tests + 1

    if (associated(self%test)) allocate(next, source=self%test)
    next => self%test

    allocate(self%test, source=ut)

    associate (t => self%test)
    select type(t)
    type is (TestRealVal)
        t%next => next
        t%test_name = ut%test_name
        t%res = res
        t%tgt = tgt
    end select
    end associate
end subroutine addTestRealVal

subroutine addTestRealArrVal(self, ut, res, tgt)
    !! Compact alternative to add a TestRealArrVal object to the test suite.

    class(TestSuite), intent(inout) :: self
    type(TestRealArrVal), intent(in) :: ut
        !! An initialized TestRealArrVal object with the desired name.
    real(kind=wp), allocatable, dimension(:) :: res, tgt
        !! See TestRealArrVal.

    class(Test), pointer :: next

    if (this_image() == 1) self%n_tests = self%n_tests + 1

    if (associated(self%test)) allocate(next, source=self%test)
    next => self%test

    allocate(self%test, source=ut)

    associate (t => self%test)
    select type(t)
    type is (TestRealArrVal)
        t%next => next
        t%test_name = ut%test_name
        t%res = res
        t%tgt = tgt
    end select
    end associate
end subroutine addTestRealArrVal

! Test
! ====

! Comparison Functions

function realEq(res, tgt, eps) result(comp)
    !! Test if two real values are equal. Uses an epsilon value to account
    !! for floating point error.

    real(kind=wp), intent(in) :: res
        !! Real value result being tested.
    real(kind=wp), intent(in) :: tgt
        !! Target real value to compare result to.
    real(kind=wp) :: eps
        !! Allowed margin of error
    logical :: comp
        !! Return whether both values are equal.

    comp = abs(res-tgt) < eps
end function realEq

function realArrEq(res, tgt, eps) result(comp)
    !! Test if two real arrays are _exactly_ equal. Arrays must be of the
    !! same length and have the same values in the same positions. Uses
    !! epsilon value to account for floating point error.

    real(kind=wp), dimension(:), intent(in) :: res
        !! Real value result being tested.
    real(kind=wp), dimension(:), intent(in) :: tgt
        !! Target real value to compare result to.
    real(kind=wp) :: eps
        !! Allowed margin of error
    logical :: comp

    if (size(res) /= size(tgt)) then
        comp = .false.
        return
    end if

    comp = all(abs(res-tgt) < eps)
end function realArrEq

! Constructors

function newTestRealVal_name(ts_name, eps) result(new_ts)
    !! Construct new TestRealVal given a name.

    character(len=*), intent(in) :: ts_name
        !! Name of the new TestRealVal object.
    real(kind=wp), optional :: eps
        !! Allowed margin of error
    type(TestRealVal) :: new_ts
        !! Return new TestRealVal object.

    new_ts%test_name = ts_name
    if (present(eps)) then
        new_ts%eps = eps
    else
        new_ts%eps = default_eps
    end if
    new_ts%next => null()
    new_ts%compare => realEq
    !TODO: create a bunch of subclasses with different comparisson
    ! operators.
    new_ts%res = 0
    new_ts%tgt = 0
end function newTestRealVal_name

function newTestRealArrVal_name(ts_name, eps) result(new_ts)
    !! Construct new TestRealArrVal given a name.

    character(len=*), intent(in) :: ts_name
        !! Name of the new TestRealArrVal object.
    real(kind=wp), optional :: eps
        !! Allowed margin of error
    type(TestRealArrVal) :: new_ts
        !! Return new TestRealArrVal object.

    new_ts%test_name = ts_name
    if (present(eps)) then
        new_ts%eps = eps
    else
        new_ts%eps = default_eps
    end if
    new_ts%next => null()
    new_ts%compare => realArrEq
    !TODO: create a bunch of subclasses with different comparisson
    ! operators.
end function newTestRealArrVal_name

! Destructors

subroutine deleteTestRealVal(self)
    !! Destruct TestRealVal object by deallocating its next object pointer.

    type(TestRealVal), intent(inout) :: self
    deallocate(self%next)
end subroutine deleteTestRealVal

subroutine deleteTestRealArrVal(self)
    !! Destruct TestRealVal object by deallocating its next object pointer
    !! as well as its res and tgt arrays.

    type(TestRealArrVal), intent(inout) :: self
    deallocate(self%next)
    deallocate(self%res)
    deallocate(self%tgt)
end subroutine deleteTestRealArrVal

! Print Fail Functions

subroutine printFailTestRealVal(img, res, tgt)
    !! Print failure message of a real value comparrison.

    integer, intent(in) :: img
        !! Image where the failure occured.
    real(kind=wp), intent(in) :: res
        !! (Incorrect) result value of some procedure.
    real(kind=wp), intent(in) :: tgt
        !! (Correct) target result value of some procedure.

    print SINGLE_VAL_FMT, img, res, tgt
end subroutine printFailTestRealVal

subroutine printFailTestRealArrVal(img, res, tgt)
    !! Print failure message of a real array comparrison.

    integer, intent(in) :: img
        !! Image where the failure occured.
    real(kind=wp), dimension(:), intent(in) :: res
        !! (Incorrect) result array of some procedure.
    real(kind=wp), dimension(:), intent(in) :: tgt
        !! (Correct) target result array of some procedure.

    print ARR_VAL_IMG, img
    print '(A)', ARR_VAL_RES
    print *, res
    print '(A)', ARR_VAL_EXP
    print *, tgt
end subroutine printFailTestRealArrVal

! Run Functions

function runTestRealVal(self) result(tests_passed)
    !! Run test on real values and print summary report for images.

    class(TestRealVal), intent(in) :: self
    integer :: tests_passed
        !! Return the tests that passed up to and including this one in
        !! the linked list.

    real(kind=wp), allocatable, codimension[:] :: res, tgt
    integer :: img_passed, i

    if (associated(self%next)) then
        tests_passed = self%next%run()
    else
        tests_passed = 0
    end if

    allocate(res[*], tgt[*])
    res = self%res
    tgt = self%tgt

    sync all
    img_passed = 0
    if (this_image() == 1) then
        print SUBTEST_START, self%test_name
        do i=1, num_images()
            if (self%compare(res[i], tgt[i], self%eps)) then
                img_passed = img_passed + 1
            else
                call self%printFail(i, res[i], tgt[i])
            end if
        end do
        print SUBTEST_END, img_passed, num_images()
    end if

    if (img_passed == num_images()) tests_passed = tests_passed + 1
end function runTestRealVal

function runTestRealArrVal(self) result(tests_passed)
    !! Run test on real arrays and print summary report for images.

    class(TestRealArrVal), intent(in) :: self
    integer :: tests_passed
        !! Return the tests that passed up to and including this one in
        !! the linked list.

    real(kind=wp), allocatable, dimension(:), codimension[:] :: res, tgt
    integer, allocatable, codimension[:] :: res_n, tgt_n

    integer :: max_res_n, max_tgt_n
    integer :: img_passed, i

    if (associated(self%next)) then
        tests_passed = self%next%run()
    else
        tests_passed = 0
    end if

    allocate(res_n[*], tgt_n[*])
    res_n = size(self%res)
    tgt_n = size(self%tgt)

    max_res_n = res_n
    call co_max(max_res_n)
    max_tgt_n = tgt_n
    call co_max(max_tgt_n)

    allocate(res(max_res_n)[*], tgt(max_tgt_n)[*])
    res(:res_n) = self%res
    tgt(:res_n) = self%tgt

    sync all
    img_passed = 0
    if (this_image() == 1) then
        print SUBTEST_START, self%test_name
        do i=1, num_images()
            if (self%compare(res(:res_n[i])[i], tgt(:tgt_n[i])[i], self%eps)) then
                img_passed = img_passed + 1
            else
                call self%printFail(i, res(:res_n[i])[i], tgt(:tgt_n[i])[i])
            end if
        end do
        print SUBTEST_END, img_passed, num_images()
    end if

    if (img_passed == num_images()) tests_passed = tests_passed + 1

    deallocate(res_n, tgt_n, res, tgt)
end function runTestRealArrVal

end module cafut