|
| 1 | +! SPDX-Identifier: MIT |
| 2 | + |
| 3 | +#:include "common.fypp" |
| 4 | +#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES |
| 5 | +#:set RANKS = range(1, MAXRANK + 1) |
| 6 | +#:set INDEXINGS = ["default", "xy", "ij"] |
| 7 | + |
| 8 | +#:def OPTIONAL_PART_IN_SIGNATURE(indexing) |
| 9 | +#:if indexing in ("xy", "ij") |
| 10 | + ${f', "{indexing}"'}$ |
| 11 | +#:endif |
| 12 | +#:enddef |
| 13 | + |
| 14 | +module test_meshgrid |
| 15 | + use testdrive, only : new_unittest, unittest_type, error_type, check |
| 16 | + use stdlib_math, only: meshgrid |
| 17 | + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp |
| 18 | + implicit none |
| 19 | + |
| 20 | + public :: collect_meshgrid |
| 21 | + |
| 22 | + #:for k1 in REAL_KINDS |
| 23 | + real(kind=${k1}$), parameter :: PI_${k1}$ = acos(-1.0_${k1}$) |
| 24 | + #:endfor |
| 25 | + |
| 26 | +contains |
| 27 | + |
| 28 | + !> Collect all exported unit tests |
| 29 | + subroutine collect_meshgrid(testsuite) |
| 30 | + !> Collection of tests |
| 31 | + type(unittest_type), allocatable, intent(out) :: testsuite(:) |
| 32 | + |
| 33 | + testsuite = [ & |
| 34 | + #:for k1, t1 in IR_KINDS_TYPES |
| 35 | + #:for rank in RANKS |
| 36 | + #:for INDEXING in INDEXINGS |
| 37 | + #: set RName = rname(f"meshgrid_{INDEXING}", rank, t1, k1) |
| 38 | + new_unittest("${RName}$", test_${RName}$), & |
| 39 | + #:endfor |
| 40 | + #:endfor |
| 41 | + #:endfor |
| 42 | + new_unittest("dummy", test_dummy) & |
| 43 | + ] |
| 44 | + |
| 45 | + end subroutine collect_meshgrid |
| 46 | + |
| 47 | + #:for k1, t1 in IR_KINDS_TYPES |
| 48 | + #:for rank in RANKS |
| 49 | + #:for INDEXING in INDEXINGS |
| 50 | + #:if rank == 1 |
| 51 | + #:set INDICES = [1] |
| 52 | + #:else |
| 53 | + #:if INDEXING in ("default", "xy") |
| 54 | + #:set INDICES = [2, 1] + [j for j in range(3, rank + 1)] |
| 55 | + #:elif INDEXING == "ij" |
| 56 | + #:set INDICES = [1, 2] + [j for j in range(3, rank + 1)] |
| 57 | + #:endif |
| 58 | + #:endif |
| 59 | + #: set RName = rname(f"meshgrid_{INDEXING}", rank, t1, k1) |
| 60 | + #: set GRIDSHAPE = "".join("length," for j in range(rank)).removesuffix(",") |
| 61 | + subroutine test_${RName}$(error) |
| 62 | + !> Error handling |
| 63 | + type(error_type), allocatable, intent(out) :: error |
| 64 | + integer, parameter :: length = 3 |
| 65 | + ${t1}$ :: ${"".join(f"x{j}(length)," for j in range(1, rank + 1)).removesuffix(",")}$ |
| 66 | + ${t1}$ :: ${"".join(f"xm{j}({GRIDSHAPE})," for j in range(1, rank + 1)).removesuffix(",")}$ |
| 67 | + ${t1}$ :: ${"".join(f"xm{j}_exact({GRIDSHAPE})," for j in range(1, rank + 1)).removesuffix(",")}$ |
| 68 | + integer :: i |
| 69 | + integer :: ${"".join(f"i{j}," for j in range(1, rank + 1)).removesuffix(",")}$ |
| 70 | + ${t1}$, parameter :: ZERO = 0 |
| 71 | + ! valid test case |
| 72 | + #:for index in range(1, rank + 1) |
| 73 | + x${index}$ = [(i, i = length * ${index - 1}$ + 1, length * ${index}$)] |
| 74 | + #:endfor |
| 75 | + #:for j in range(1, rank + 1) |
| 76 | + xm${j}$_exact = reshape( & |
| 77 | + [${"".join("(" for dummy in range(rank)) + f"x{j}(i{j})" + "".join(f", i{index} = 1, size(x{index}))" for index in INDICES)}$], & |
| 78 | + shape=[${GRIDSHAPE}$] & |
| 79 | + ) |
| 80 | + #:endfor |
| 81 | + call meshgrid( & |
| 82 | + ${"".join(f"x{j}," for j in range(1, rank + 1))}$ & |
| 83 | + ${"".join(f"xm{j}," for j in range(1, rank + 1)).removesuffix(",")}$ & |
| 84 | + ${OPTIONAL_PART_IN_SIGNATURE(INDEXING)}$ ) |
| 85 | + #:for j in range(1, rank + 1) |
| 86 | + call check(error, abs(maxval(xm${j}$ - xm${j}$_exact)), ZERO) |
| 87 | + if (allocated(error)) return |
| 88 | + #:endfor |
| 89 | + end subroutine test_${RName}$ |
| 90 | + #:endfor |
| 91 | + #:endfor |
| 92 | + #:endfor |
| 93 | + |
| 94 | + subroutine test_dummy(error) |
| 95 | + !> Error handling |
| 96 | + type(error_type), allocatable, intent(out) :: error |
| 97 | + end subroutine |
| 98 | + |
| 99 | +end module test_meshgrid |
| 100 | + |
| 101 | +program tester |
| 102 | + use, intrinsic :: iso_fortran_env, only : error_unit |
| 103 | + use testdrive, only : run_testsuite, new_testsuite, testsuite_type |
| 104 | + use test_meshgrid, only : collect_meshgrid |
| 105 | + implicit none |
| 106 | + integer :: stat, is |
| 107 | + type(testsuite_type), allocatable :: testsuites(:) |
| 108 | + character(len=*), parameter :: fmt = '("#", *(1x, a))' |
| 109 | + |
| 110 | + stat = 0 |
| 111 | + |
| 112 | + testsuites = [ & |
| 113 | + new_testsuite("meshgrid", collect_meshgrid) & |
| 114 | + ] |
| 115 | + |
| 116 | + do is = 1, size(testsuites) |
| 117 | + write(error_unit, fmt) "Testing:", testsuites(is)%name |
| 118 | + call run_testsuite(testsuites(is)%collect, error_unit, stat) |
| 119 | + end do |
| 120 | + |
| 121 | + if (stat > 0) then |
| 122 | + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" |
| 123 | + error stop |
| 124 | + end if |
| 125 | +end program tester |
0 commit comments