generalized indices: Modify unit tests to test nonstandard dimension orders

configure.ac

@@ -528,6 +528,7 @@ AC_CONFIG_FILES([
   test_fms/test-lib.sh
   test_fms/intel_coverage.sh
   test_fms/Makefile
+  test_fms/common/Makefile
   test_fms/astronomy/Makefile
   test_fms/diag_manager/Makefile
   test_fms/data_override/Makefile

test_fms/Makefile.am

@@ -24,7 +24,7 @@
 ACLOCAL_AMFLAGS = -I m4
 
 # Make targets will be run in each subdirectory. Order is significant.
-SUBDIRS = astronomy coupler diag_manager data_override exchange monin_obukhov drifters \
+SUBDIRS = common astronomy coupler diag_manager data_override exchange monin_obukhov drifters \
 mosaic2 interpolator fms mpp time_interp time_manager horiz_interp topography \
 field_manager axis_utils affinity fms2_io parser string_utils sat_vapor_pres tracer_manager \
 random_numbers diag_integral column_diagnostics tridiagonal block_control

test_fms/common/Makefile.am

@@ -0,0 +1,27 @@
+#***********************************************************************
+#*                   GNU Lesser General Public License
+#*
+#* This file is part of the GFDL Flexible Modeling System (FMS).
+#*
+#* FMS is free software: you can redistribute it and/or modify it under
+#* the terms of the GNU Lesser General Public License as published by
+#* the Free Software Foundation, either version 3 of the License, or (at
+#* your option) any later version.
+#*
+#* FMS is distributed in the hope that it will be useful, but WITHOUT
+#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+#* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+#* for more details.
+#*
+#* You should have received a copy of the GNU Lesser General Public
+#* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
+#***********************************************************************
+
+# Find the fms and mpp mod files.
+AM_CPPFLAGS = -I$(MODDIR)
+
+noinst_LIBRARIES = libtest_fms.a
+libtest_fms_a_SOURCES = test_fms.F90
+
+# Clean up
+CLEANFILES = *.o *.mod *.a

test_fms/common/include/test_fms.inc

@@ -0,0 +1,51 @@
+  subroutine ARR_INIT_2D_ (arr)
+    FMS_TEST_TYPE_ (FMS_TEST_KIND_), intent(out) :: arr(:,:)
+    real(r8_kind) :: unif(size(arr,1), size(arr,2))
+    type(randomNumberStream), save :: random_stream
+    logical, save :: initialized = .false.
+
+    if (.not.initialized) then
+      random_stream = initializeRandomNumberStream(0)
+      initialized = .true.
+    endif
+
+    call getRandomNumbers(random_stream, unif)
+
+    arr = TYPECAST_ (1e9_r8_kind * (unif - 0.5_r8_kind), FMS_TEST_KIND_)
+  end subroutine ARR_INIT_2D_
+
+  subroutine ARR_INIT_3D_ (arr)
+    FMS_TEST_TYPE_ (FMS_TEST_KIND_), intent(out) :: arr(:,:,:)
+    integer :: k
+
+    do k = 1, size(arr, 3)
+      call arr_init(arr(:, :, k))
+    enddo
+  end subroutine ARR_INIT_3D_
+
+  subroutine ARR_COMPARE_2D_ (arr0, arr1, msg)
+    FMS_TEST_TYPE_ (FMS_TEST_KIND_), intent(in), dimension(:,:) :: arr0, arr1
+    character(*), intent(in) :: msg
+
+    if (any(arr0.ne.arr1)) then
+      call mpp_error(FATAL, "[2D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_2D_
+
+  subroutine ARR_COMPARE_3D_ (arr0, arr1, msg)
+    FMS_TEST_TYPE_ (FMS_TEST_KIND_), intent(in), dimension(:,:,:) :: arr0, arr1
+    character(*), intent(in) :: msg
+
+    if (any(arr0.ne.arr1)) then
+      call mpp_error(FATAL, "[3D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_3D_
+
+  subroutine ARR_COMPARE_4D_ (arr0, arr1, msg)
+    FMS_TEST_TYPE_ (FMS_TEST_KIND_), intent(in), dimension(:,:,:,:) :: arr0, arr1
+    character(*), intent(in) :: msg
+
+    if (any(arr0.ne.arr1)) then
+      call mpp_error(FATAL, "[4D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_4D_

test_fms/common/include/test_fms_real.inc

@@ -0,0 +1,62 @@
+  subroutine ARR_COMPARE_TOL_2D_ (arr0, arr1, tol, msg)
+    real(FMS_TEST_KIND_), intent(in), dimension(:,:) :: arr0, arr1
+    real(FMS_TEST_KIND_), intent(in) :: tol
+    character(*), intent(in) :: msg
+
+    if (any(abs(arr1 - arr0).gt.tol)) then
+      call mpp_error(FATAL, "[2D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_TOL_2D_
+
+  subroutine ARR_COMPARE_TOL_3D_ (arr0, arr1, tol, msg)
+    real(FMS_TEST_KIND_), intent(in), dimension(:,:,:) :: arr0, arr1
+    real(FMS_TEST_KIND_), intent(in) :: tol
+    character(*), intent(in) :: msg
+
+    if (any(abs(arr1 - arr0).gt.tol)) then
+      call mpp_error(FATAL, "[3D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_TOL_3D_
+
+  subroutine ARR_COMPARE_TOL_4D_ (arr0, arr1, tol, msg)
+    real(FMS_TEST_KIND_), intent(in), dimension(:,:,:,:) :: arr0, arr1
+    real(FMS_TEST_KIND_), intent(in) :: tol
+    character(*), intent(in) :: msg
+
+    if (any(abs(arr1 - arr0).gt.tol)) then
+      call mpp_error(FATAL, "[4D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_TOL_4D_
+
+  subroutine ARR_COMPARE_TOL_2D_SCALAR_ (arr, ans, tol, msg)
+    real(FMS_TEST_KIND_), intent(in), dimension(:,:) :: arr
+    real(FMS_TEST_KIND_), intent(in) :: ans
+    real(FMS_TEST_KIND_), intent(in) :: tol
+    character(*), intent(in) :: msg
+
+    if (any(abs(arr - ans).gt.tol)) then
+      call mpp_error(FATAL, "[2D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_TOL_2D_SCALAR_
+
+  subroutine ARR_COMPARE_TOL_3D_SCALAR_ (arr, ans, tol, msg)
+    real(FMS_TEST_KIND_), intent(in), dimension(:,:,:) :: arr
+    real(FMS_TEST_KIND_), intent(in) :: ans
+    real(FMS_TEST_KIND_), intent(in) :: tol
+    character(*), intent(in) :: msg
+
+    if (any(abs(arr - ans).gt.tol)) then
+      call mpp_error(FATAL, "[3D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_TOL_3D_SCALAR_
+
+  subroutine ARR_COMPARE_TOL_4D_SCALAR_ (arr, ans, tol, msg)
+    real(FMS_TEST_KIND_), intent(in), dimension(:,:,:,:) :: arr
+    real(FMS_TEST_KIND_), intent(in) :: ans
+    real(FMS_TEST_KIND_), intent(in) :: tol
+    character(*), intent(in) :: msg
+
+    if (any(abs(arr - ans).gt.tol)) then
+      call mpp_error(FATAL, "[4D] Unexpected result: " // msg)
+    endif
+  end subroutine ARR_COMPARE_TOL_4D_SCALAR_

test_fms/common/test_fms.F90

@@ -0,0 +1,199 @@
+! This module allows arrays to be permuted, and provides a data type for the
+! purpose of storing permuted array bounds. It provides procedures for
+! initializing a 2D or 3D array with random data, and for comparing a 2D or
+! 3D array with reference answers.
+
+module fms_test_mod
+  use random_numbers_mod, only: randomNumberStream, initializeRandomNumberStream, getRandomNumbers
+  use mpp_mod,         only: mpp_error, FATAL
+  use platform_mod
+
+  implicit none
+
+  interface arr_init
+    module procedure :: arr_init_2d_r4, arr_init_2d_r8, arr_init_2d_i4, arr_init_2d_i8
+    module procedure :: arr_init_3d_r4, arr_init_3d_r8, arr_init_3d_i4, arr_init_3d_i8
+  end interface arr_init
+
+  interface arr_compare
+    module procedure :: arr_compare_2d_r4, arr_compare_2d_r8, arr_compare_2d_i4, arr_compare_2d_i8
+    module procedure :: arr_compare_3d_r4, arr_compare_3d_r8, arr_compare_3d_i4, arr_compare_3d_i8
+    module procedure :: arr_compare_4d_r4, arr_compare_4d_r8, arr_compare_4d_i4, arr_compare_4d_i8
+  end interface arr_compare
+
+  interface arr_compare_tol
+    module procedure :: arr_compare_tol_2d_r4, arr_compare_tol_2d_r8
+    module procedure :: arr_compare_tol_3d_r4, arr_compare_tol_3d_r8
+    module procedure :: arr_compare_tol_4d_r4, arr_compare_tol_4d_r8
+
+    module procedure :: arr_compare_tol_2d_scalar_r4, arr_compare_tol_2d_scalar_r8
+    module procedure :: arr_compare_tol_3d_scalar_r4, arr_compare_tol_3d_scalar_r8
+    module procedure :: arr_compare_tol_4d_scalar_r4, arr_compare_tol_4d_scalar_r8
+  end interface arr_compare_tol
+
+  type permutable_indices(ndim)
+    integer, len :: ndim
+    integer :: lb(ndim), ub(ndim)
+
+    contains
+
+    procedure :: permute => permutable_indices_permute
+    procedure :: n => permutable_indices_n
+  end type permutable_indices
+
+  contains
+
+#define FMS_TEST_TYPE_ real
+#define TYPECAST_ real
+
+#define FMS_TEST_KIND_ r4_kind
+
+#define ARR_INIT_2D_ arr_init_2d_r4
+#define ARR_INIT_3D_ arr_init_3d_r4
+#define ARR_COMPARE_2D_ arr_compare_2d_r4
+#define ARR_COMPARE_3D_ arr_compare_3d_r4
+#define ARR_COMPARE_4D_ arr_compare_4d_r4
+#include "include/test_fms.inc"
+#undef ARR_INIT_2D_
+#undef ARR_INIT_3D_
+#undef ARR_COMPARE_2D_
+#undef ARR_COMPARE_3D_
+#undef ARR_COMPARE_4D_
+
+#define ARR_COMPARE_TOL_2D_ arr_compare_tol_2d_r4
+#define ARR_COMPARE_TOL_3D_ arr_compare_tol_3d_r4
+#define ARR_COMPARE_TOL_4D_ arr_compare_tol_4d_r4
+#define ARR_COMPARE_TOL_2D_SCALAR_ arr_compare_tol_2d_scalar_r4
+#define ARR_COMPARE_TOL_3D_SCALAR_ arr_compare_tol_3d_scalar_r4
+#define ARR_COMPARE_TOL_4D_SCALAR_ arr_compare_tol_4d_scalar_r4
+#include "include/test_fms_real.inc"
+#undef ARR_COMPARE_TOL_2D_
+#undef ARR_COMPARE_TOL_3D_
+#undef ARR_COMPARE_TOL_4D_
+#undef ARR_COMPARE_TOL_2D_SCALAR_
+#undef ARR_COMPARE_TOL_3D_SCALAR_
+#undef ARR_COMPARE_TOL_4D_SCALAR_
+
+#undef FMS_TEST_KIND_
+#define FMS_TEST_KIND_ r8_kind
+
+#define ARR_INIT_2D_ arr_init_2d_r8
+#define ARR_INIT_3D_ arr_init_3d_r8
+#define ARR_COMPARE_2D_ arr_compare_2d_r8
+#define ARR_COMPARE_3D_ arr_compare_3d_r8
+#define ARR_COMPARE_4D_ arr_compare_4d_r8
+#include "include/test_fms.inc"
+#undef ARR_INIT_2D_
+#undef ARR_INIT_3D_
+#undef ARR_COMPARE_2D_
+#undef ARR_COMPARE_3D_
+#undef ARR_COMPARE_4D_
+#undef ARR_COMPARE_TOL_2D_SCALAR_
+#undef ARR_COMPARE_TOL_3D_SCALAR_
+#undef ARR_COMPARE_TOL_4D_SCALAR_
+
+#define ARR_COMPARE_TOL_2D_ arr_compare_tol_2d_r8
+#define ARR_COMPARE_TOL_3D_ arr_compare_tol_3d_r8
+#define ARR_COMPARE_TOL_4D_ arr_compare_tol_4d_r8
+#define ARR_COMPARE_TOL_2D_SCALAR_ arr_compare_tol_2d_scalar_r8
+#define ARR_COMPARE_TOL_3D_SCALAR_ arr_compare_tol_3d_scalar_r8
+#define ARR_COMPARE_TOL_4D_SCALAR_ arr_compare_tol_4d_scalar_r8
+#include "include/test_fms_real.inc"
+#undef ARR_COMPARE_TOL_2D_
+#undef ARR_COMPARE_TOL_3D_
+#undef ARR_COMPARE_TOL_4D_
+#undef ARR_COMPARE_TOL_2D_SCALAR_
+#undef ARR_COMPARE_TOL_3D_SCALAR_
+#undef ARR_COMPARE_TOL_4D_SCALAR_
+
+#undef FMS_TEST_KIND_
+
+#undef FMS_TEST_TYPE_
+#undef TYPECAST_
+
+#define FMS_TEST_TYPE_ integer
+#define TYPECAST_ int
+
+#define FMS_TEST_KIND_ i4_kind
+#define ARR_INIT_2D_ arr_init_2d_i4
+#define ARR_INIT_3D_ arr_init_3d_i4
+#define ARR_COMPARE_2D_ arr_compare_2d_i4
+#define ARR_COMPARE_3D_ arr_compare_3d_i4
+#define ARR_COMPARE_4D_ arr_compare_4d_i4
+#include "include/test_fms.inc"
+#undef FMS_TEST_KIND_
+#undef ARR_INIT_2D_
+#undef ARR_INIT_3D_
+#undef ARR_COMPARE_2D_
+#undef ARR_COMPARE_3D_
+#undef ARR_COMPARE_4D_
+
+#define FMS_TEST_KIND_ i8_kind
+#define ARR_INIT_2D_ arr_init_2d_i8
+#define ARR_INIT_3D_ arr_init_3d_i8
+#define ARR_COMPARE_2D_ arr_compare_2d_i8
+#define ARR_COMPARE_3D_ arr_compare_3d_i8
+#define ARR_COMPARE_4D_ arr_compare_4d_i8
+#include "include/test_fms.inc"
+#undef FMS_TEST_KIND_
+#undef ARR_INIT_2D_
+#undef ARR_INIT_3D_
+#undef ARR_COMPARE_2D_
+#undef ARR_COMPARE_3D_
+#undef ARR_COMPARE_4D_
+
+#undef FMS_TEST_TYPE_
+#undef TYPECAST_
+
+  subroutine permutable_indices_permute(self, p)
+    class(permutable_indices(*)), intent(inout) :: self
+    integer, intent(in) :: p
+
+    call permute_arr(self%lb, p)
+    call permute_arr(self%ub, p)
+  end subroutine permutable_indices_permute
+
+  function permutable_indices_n(self, i) result(n)
+    class(permutable_indices(*)), intent(inout) :: self
+    integer, intent(in) :: i
+    integer :: n
+
+    n = self%ub(i) - self%lb(i) + 1
+  end function permutable_indices_n
+
+  pure recursive function factorial(n) result(res)
+    integer, intent(in) :: n
+    integer :: res
+
+    if (n.eq.0) then
+      res = 1
+    else
+      res = n * factorial(n-1)
+    endif
+  end function factorial
+
+  subroutine permute_arr(arr, p)
+    integer, intent(inout) :: arr(:) !< List to be permuted
+    integer, intent(in) :: p !< Which permutation to produce: may range from 1 to size(arr)!
+    integer :: choices(size(arr))
+    integer :: n, k, i, f, indx
+
+    n = size(arr)
+    if (p.lt.1 .or. p.gt.factorial(n)) then
+      print *, "Error: p parameter is out of bounds"
+      stop 1
+    endif
+
+    choices = arr
+    k = p - 1
+
+    do i=1,n
+      f = factorial(n - i)
+      indx = k / f + 1
+      k = mod(k, f)
+
+      arr(i) = choices(indx)
+      choices(indx) = choices(n + 1 - i)
+    enddo
+  end subroutine permute_arr
+end module fms_test_mod

test_fms/data_override/Makefile.am

@@ -23,10 +23,10 @@
 # uramirez, Ed Hartnett
 
 # Find the needed mod and .inc files.
-AM_CPPFLAGS = -I$(MODDIR) -I$(top_srcdir)/include -I$(top_srcdir)/test_fms/data_override/include
+AM_CPPFLAGS = -I$(MODDIR) -I$(top_srcdir)/include -I$(top_srcdir)/test_fms/data_override/include -I$(top_srcdir)/test_fms/common
 
 # Link to the FMS library.
-LDADD = $(top_builddir)/libFMS/libFMS.la
+LDADD = $(top_builddir)/libFMS/libFMS.la $(top_builddir)/test_fms/common/libtest_fms.a
 
 # Build this test program.
 check_PROGRAMS = \