[mpich-commits] [mpich] MPICH primary repository branch, master, updated. v3.1.1-21-gd7cf8a8
Service Account
noreply at mpich.org
Thu Jun 19 09:35:49 CDT 2014
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "MPICH primary repository".
The branch, master has been updated
via d7cf8a8a6de76e8b831b12cd73022ba3f903662a (commit)
via f5e24289ef8d7a023d67265386cf99e56fa7d357 (commit)
via 7ff73edc12d5592a3ac8dfd23bfcd6cd7a82acf4 (commit)
via 491e85d6bc78dfdd2d958471a5e10ab3ee058626 (commit)
via 5ac7bfd62d7fb21c1e339625cf2adc61946016b5 (commit)
via d34a16488be7a7cf8f67d5b356068727a9d2b191 (commit)
via cfa1fa4bb909c7858628d1acd6b23e8390d27cc4 (commit)
from eb8837deabf00f339cc87dfaec9792dde004671d (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
http://git.mpich.org/mpich.git/commitdiff/d7cf8a8a6de76e8b831b12cd73022ba3f903662a
commit d7cf8a8a6de76e8b831b12cd73022ba3f903662a
Author: Junchao Zhang <jczhang at mcs.anl.gov>
Date: Tue Jun 17 18:58:16 2014 -0500
Move F08 hello test and ring test to dir misc
No review since F08 binding is experimental now.
diff --git a/test/mpi/configure.ac b/test/mpi/configure.ac
index 0af3ba0..82f9249 100644
--- a/test/mpi/configure.ac
+++ b/test/mpi/configure.ac
@@ -1546,8 +1546,7 @@ AC_OUTPUT(maint/testmerge \
f90/io/Makefile \
f90/misc/Makefile \
f90/profile/Makefile \
- f08/Makefile \
- f08/attr/Makefile \
+ f08/attr/Makefile \
f08/datatype/Makefile \
f08/util/Makefile \
f08/coll/Makefile \
diff --git a/test/mpi/f08/Makefile.am b/test/mpi/f08/Makefile.am
deleted file mode 100644
index 1f76bf8..0000000
--- a/test/mpi/f08/Makefile.am
+++ /dev/null
@@ -1,17 +0,0 @@
-# -*- Mode: Makefile; -*-
-# vim: set ft=automake :
-#
-# (C) 2014 by Argonne National Laboratory.
-# See COPYRIGHT in top-level directory.
-#
-
-include $(top_srcdir)/Makefile_f08.mtest
-
-# avoid having to write many "foo_SOURCES = foo.f90" lines
-AM_DEFAULT_SOURCE_EXT = .f90
-
-## for all programs that are just built from the single corresponding source
-## file, we don't need per-target _SOURCES rules, automake will infer them
-## correctly
-noinst_PROGRAMS = hello_usempif08 \
- ring_usempif08
diff --git a/test/mpi/f08/misc/Makefile.am b/test/mpi/f08/misc/Makefile.am
index 053dc97..414796e 100644
--- a/test/mpi/f08/misc/Makefile.am
+++ b/test/mpi/f08/misc/Makefile.am
@@ -9,6 +9,11 @@ include $(top_srcdir)/Makefile_f08.mtest
EXTRA_DIST = testlist
-noinst_PROGRAMS = sizeof2
-sizeof2_SOURCES = sizeof2.f90
+# avoid having to write many "foo_SOURCES = foo.f90" lines
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = sizeof2 \
+ hello \
+ ring
+
diff --git a/test/mpi/f08/hello_usempif08.f90 b/test/mpi/f08/misc/hello.f90
similarity index 100%
rename from test/mpi/f08/hello_usempif08.f90
rename to test/mpi/f08/misc/hello.f90
diff --git a/test/mpi/f08/ring_usempif08.f90 b/test/mpi/f08/misc/ring.f90
similarity index 100%
rename from test/mpi/f08/ring_usempif08.f90
rename to test/mpi/f08/misc/ring.f90
diff --git a/test/mpi/f08/misc/testlist b/test/mpi/f08/misc/testlist
index 37ae4d2..228b720 100644
--- a/test/mpi/f08/misc/testlist
+++ b/test/mpi/f08/misc/testlist
@@ -1 +1,3 @@
sizeof2 1
+hello 1
+ring 4
diff --git a/test/mpi/f08/testlist b/test/mpi/f08/testlist
index 0c0f42c..83bfded 100644
--- a/test/mpi/f08/testlist
+++ b/test/mpi/f08/testlist
@@ -1,5 +1,3 @@
-hello_usempif08 1
-ring_usempif08 4
attr
pt2pt
coll
http://git.mpich.org/mpich.git/commitdiff/f5e24289ef8d7a023d67265386cf99e56fa7d357
commit f5e24289ef8d7a023d67265386cf99e56fa7d357
Author: Junchao Zhang <jczhang at mcs.anl.gov>
Date: Tue Jun 17 18:19:51 2014 -0500
Fix bugs in MPI_Info_get and MPI_Info_get_valuelen
value and valuelen should keep unchanged when a false flag is returned.
No review since F08 binding is experimental now.
diff --git a/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_f08ts.F90 b/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_f08ts.F90
index a61bd68..3a5cdc0 100644
--- a/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_f08ts.F90
+++ b/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_f08ts.F90
@@ -37,9 +37,12 @@ subroutine MPI_Info_get_f08(info, key, valuelen, value, flag, ierror)
ierror_c = MPIR_Info_get_c(info_c, key_c, valuelen_c, value_c, flag_c)
end if
- call MPIR_Fortran_string_c2f(value_c, value)
-
flag = (flag_c /= 0)
+
+ if (flag) then ! value is unchanged when flag is false
+ call MPIR_Fortran_string_c2f(value_c, value)
+ end if
+
if (present(ierror)) ierror = ierror_c
end subroutine MPI_Info_get_f08
diff --git a/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_valuelen_f08ts.F90 b/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_valuelen_f08ts.F90
index e809d38..d0a3072 100644
--- a/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_valuelen_f08ts.F90
+++ b/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_valuelen_f08ts.F90
@@ -27,14 +27,15 @@ subroutine MPI_Info_get_valuelen_f08(info, key, valuelen, flag, ierror)
call MPIR_Fortran_string_f2c(key, key_c)
if (c_int == kind(0)) then
- ierror_c = MPIR_Info_get_valuelen_c(info%MPI_VAL, key_c, valuelen, flag_c)
+ ierror_c = MPIR_Info_get_valuelen_c(info%MPI_VAL, key_c, valuelen_c, flag_c)
else
info_c = info%MPI_VAL
ierror_c = MPIR_Info_get_valuelen_c(info_c, key_c, valuelen_c, flag_c)
- valuelen = valuelen_c
end if
flag = (flag_c /= 0)
+
+ if (flag) valuelen = valuelen_c
if (present(ierror)) ierror = ierror_c
end subroutine MPI_Info_get_valuelen_f08
http://git.mpich.org/mpich.git/commitdiff/7ff73edc12d5592a3ac8dfd23bfcd6cd7a82acf4
commit 7ff73edc12d5592a3ac8dfd23bfcd6cd7a82acf4
Author: Junchao Zhang <jczhang at mcs.anl.gov>
Date: Tue Jun 17 18:18:00 2014 -0500
Fix a bug when converting a Fortran string to a C string
We should also remove the leading blank characters.
No review since F08 binding is experimental now.
diff --git a/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90 b/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90
index 273d9a7..74d0f07 100644
--- a/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90
+++ b/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90
@@ -57,14 +57,24 @@ subroutine MPIR_Fortran_string_f2c(fstring, cstring)
implicit none
character(len=*), intent(in) :: fstring
character(kind=c_char), intent(out) :: cstring(:)
- integer :: i
+ integer :: i, j
+ logical :: met_non_blank
+ ! Trim the leading and trailing blank characters
+ j = 1
+ met_non_blank = .false.
do i = 1, len_trim(fstring)
- cstring(i) = fstring(i:i)
+ if (met_non_blank) then
+ cstring(j) = fstring(i:i)
+ j = j + 1
+ else if (fstring(i:i) /= ' ') then
+ met_non_blank = .true.
+ cstring(j) = fstring(i:i)
+ j = j + 1
+ end if
end do
- cstring(i) = C_NULL_CHAR
-
+ cstring(j) = C_NULL_CHAR
end subroutine MPIR_Fortran_string_f2c
! Copy C charater array to Fortran string
http://git.mpich.org/mpich.git/commitdiff/491e85d6bc78dfdd2d958471a5e10ab3ee058626
commit 491e85d6bc78dfdd2d958471a5e10ab3ee058626
Author: Junchao Zhang <jczhang at mcs.anl.gov>
Date: Tue Jun 17 10:40:18 2014 -0500
Code cleanup
No review since F08 binding is experimental now.
diff --git a/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90 b/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90
index 5d85714..273d9a7 100644
--- a/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90
+++ b/src/binding/fortran/use_mpi_f08/mpi_c_interface_glue.F90
@@ -76,13 +76,10 @@ subroutine MPIR_Fortran_string_c2f(cstring, fstring)
i = 1
do while (cstring(i) /= C_NULL_CHAR)
+ fstring(i:i) = cstring(i)
i = i + 1
end do
- do j = 1, i - 1
- fstring(j:j) = cstring(j)
- end do
-
! Zero out the trailing characters
length = len(fstring)
do j = i, length
diff --git a/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_nthkey_f08ts.F90 b/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_nthkey_f08ts.F90
index 629d952..0d491ec 100644
--- a/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_nthkey_f08ts.F90
+++ b/src/binding/fortran/use_mpi_f08/wrappers_f/info_get_nthkey_f08ts.F90
@@ -3,7 +3,7 @@
! (C) 2014 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
-subroutine MPI_Info_get_nthkey_f08(info, n,key, ierror)
+subroutine MPI_Info_get_nthkey_f08(info, n, key, ierror)
use, intrinsic :: iso_c_binding, only : c_int, c_char
use :: mpi_f08, only : MPI_Info
use :: mpi_c_interface, only : c_Info
http://git.mpich.org/mpich.git/commitdiff/5ac7bfd62d7fb21c1e339625cf2adc61946016b5
commit 5ac7bfd62d7fb21c1e339625cf2adc61946016b5
Author: Junchao Zhang <jczhang at mcs.anl.gov>
Date: Mon Jun 16 13:36:47 2014 -0500
Fix an MPI_Cancel bug in F08
The request argument should not have the value attribute due to an oversight in MPI-1.0.
See p72 of MPI-3.0
No review since F08 binding is experimental now.
diff --git a/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90 b/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90
index febc57c..11da8bf 100644
--- a/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90
+++ b/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90
@@ -23,7 +23,9 @@ function MPIR_Cancel_c(request) &
use, intrinsic :: iso_c_binding, only : c_int
use :: mpi_c_interface_types, only : c_Request
implicit none
- integer(c_Request), value, intent(in) :: request
+ ! No value attribute for request due to an oversight in MPI-1.0
+ ! See P72 of MPI-3.0
+ integer(c_Request), intent(in) :: request
integer(c_int) :: ierror
end function MPIR_Cancel_c
http://git.mpich.org/mpich.git/commitdiff/d34a16488be7a7cf8f67d5b356068727a9d2b191
commit d34a16488be7a7cf8f67d5b356068727a9d2b191
Author: Junchao Zhang <jczhang at mcs.anl.gov>
Date: Mon Jun 16 10:34:59 2014 -0500
Fix bugs in comm_spawn & comm_spawn_multiple
One bug is related to converting the array_of_argv argument in MPI_Comm_spawn_multiple
from a Fortran style, i.e. type CHARACTER(LEN=*), INTENT(IN) :: array_of_argv(count, *),
to a C style, i.e., char** array_of_argv[count]
No review since F08 binding is experimental now.
diff --git a/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90 b/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90
index c24e6f0..febc57c 100644
--- a/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90
+++ b/src/binding/fortran/use_mpi_f08/mpi_c_interface_nobuf.F90
@@ -2347,12 +2347,12 @@ function MPIR_Comm_spawn_multiple_c(count, array_of_commands, array_of_argv, arr
use, intrinsic :: iso_c_binding, only : c_int, c_char, c_ptr
use :: mpi_c_interface_types, only : c_Info, c_Comm
implicit none
- integer(c_int), intent(in) :: count
+ integer(c_int), value, intent(in) :: count
type(c_ptr), value, intent(in) :: array_of_commands
type(c_ptr), value, intent(in) :: array_of_argv
integer(c_int), intent(in) :: array_of_maxprocs(*)
integer(c_Info), intent(in) :: array_of_info(*)
- integer(c_int), intent(in) :: root
+ integer(c_int), value, intent(in) :: root
integer(c_Comm), value, intent(in) :: comm
integer(c_Comm), intent(out) :: intercomm
type(c_ptr), value, intent(in) :: array_of_errcodes
diff --git a/src/binding/fortran/use_mpi_f08/wrappers_c/buildiface b/src/binding/fortran/use_mpi_f08/wrappers_c/buildiface
index 2031629..ef15847 100755
--- a/src/binding/fortran/use_mpi_f08/wrappers_c/buildiface
+++ b/src/binding/fortran/use_mpi_f08/wrappers_c/buildiface
@@ -272,7 +272,7 @@ extern int MPIR_Fortran_array_of_string_f2c(const char* strs_f, char*** strs_c,
extern int MPIR_Comm_spawn_c(const char *command, char *argv_f, int maxprocs, MPI_Info info, int root,
MPI_Comm comm, MPI_Comm *intercomm, int* array_of_errcodes, int argv_elem_len);
extern int MPIR_Comm_spawn_multiple_c(int count, char *array_of_commands_f,
- char **array_of_argv_f, const int* array_of_maxprocs,
+ char *array_of_argv_f, const int* array_of_maxprocs,
const MPI_Info *array_of_info, int root, MPI_Comm comm,
MPI_Comm *intercomm, int* array_of_errcodes,
int commands_elem_len, int argv_elem_len);
diff --git a/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_c.c b/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_c.c
index b7a57f5..108dfeb 100644
--- a/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_c.c
+++ b/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_c.c
@@ -10,7 +10,8 @@ int MPIR_Comm_spawn_c(const char *command, char *argv_f, int maxprocs, MPI_Info
if ((char**)argv_f == MPI_ARGV_NULL) {
argv_c = MPI_ARGV_NULL;
} else {
- mpi_errno = MPIR_Fortran_array_of_string_f2c(argv_f, &argv_c, argv_elem_len, 0, 0); /* Don't know size */
+ mpi_errno = MPIR_Fortran_array_of_string_f2c(argv_f, &argv_c, argv_elem_len,
+ 0 /* Don't know size of argv_f */, 0);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
diff --git a/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_multiple_c.c b/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_multiple_c.c
index c83bd98..c87766c 100644
--- a/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_multiple_c.c
+++ b/src/binding/fortran/use_mpi_f08/wrappers_c/comm_spawn_multiple_c.c
@@ -5,38 +5,95 @@
#define FUNCNAME MPIR_Comm_spawn_multiple_c
#undef FCNAME
#define FCNAME MPIU_QUOTE(FUNCNAME)
-int MPIR_Comm_spawn_multiple_c(int count, char *array_of_commands_f,
- char **array_of_argv_f, const int* array_of_maxprocs,
- const MPI_Info *array_of_info, int root, MPI_Comm comm,
- MPI_Comm *intercomm, int* array_of_errcodes,
+int MPIR_Comm_spawn_multiple_c(int count, char* array_of_commands_f,
+ char* array_of_argv_f, const int* array_of_maxprocs,
+ const MPI_Info* array_of_info, int root, MPI_Comm comm,
+ MPI_Comm* intercomm, int* array_of_errcodes,
int commands_elem_len, int argv_elem_len)
{
int mpi_errno = MPI_SUCCESS;
- char*** array_of_argv_c = NULL;
char** array_of_commands_c = NULL;
- int i, j;
+ char*** array_of_argv_c = NULL;
+ int i, j, offset, len, terminate;
+ char *buf, *newbuf;
+
+ /* array_of_commands_f in Fortran has type CHARACTER(LEN=*), INTENT(IN) :: array_of_commands(*).
+ It contains commands array_of_commands(1), ..., array_of_commands(count). Each is a Fortran
+ string of length commands_elem_len, which equals to len(array_of_commands).
+ We need to convert array_of_commands_f into array_of_commands_c, which in C has type
+ char* array_of_commands_c[count], in other words, each element is a pointer to string.
+ */
mpi_errno = MPIR_Fortran_array_of_string_f2c(array_of_commands_f, &array_of_commands_c,
- commands_elem_len, 1, count); /* array_of_commands_f size is known */
+ commands_elem_len, 1 /* size of array_of_commands_f is known */, count);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
+ /* array_of_argv_f in Fortran has type CHARACTER(LEN=*), INTENT(IN) :: array_of_argv(count, *).
+ For a particular command number K (in the range 1..count), array_of_argv (K, 1) is the first
+ argument, array_of_argv(K,2) is the second argument, ... etc., until you get to array_of_argv(K,J)
+ being a string of all blank characters. That indicates that command K has J-1 arguments.
+ The value of J might be different from each command, but the size of the second dimension of
+ array_of_argv is the largest value of J for all the commands. The actual memory layout of
+ the array is (arg1 for command 1) (arg1 for command 2) ... (arg1 for command COUNT)
+ (arg2 for command 1) ...
+
+ We need to convert array_of_argv_f into array_of_argv_c, which in C has type
+ char** array_of_argv_c[count], with each element pointing to an array of pointers.
+ For example, array_of_argv_c[0] points to an array of pointers to string.
+ array_of_argv_c[0][0] points to 1st arg of command 0. array_of_argv_c[0][0] points
+ to 2nd arg of command 0, etc. If array_of_argv_c[0][J] is NULL, then command 0
+ has J args.
+ */
+
if ((char***)array_of_argv_f == MPI_ARGVS_NULL) {
array_of_argv_c = MPI_ARGVS_NULL;
} else {
array_of_argv_c = (char***) MPIU_Malloc(sizeof(char**)*count);
- if (array_of_argv_c == NULL) {
- MPIU_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**nomem");
- }
+ if (!array_of_argv_c) MPIU_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**nomem");
+
+ /* Allocate a temp buf to put args of a command */
+ len = 256; /* length of buf. Initialized with an arbitrary value */
+ buf = (char*)MPIU_Malloc(sizeof(char)*len);
+ if (!buf) MPIU_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**nomem");
for (i = 0; i < count; i++) {
- mpi_errno = MPIR_Fortran_array_of_string_f2c(array_of_argv_f[i],
- &(array_of_argv_c[i]), argv_elem_len, 0, 0); /* array_of_argv_f[i] size is unknown */
+ /* Extract args of command i, and put them in buf */
+ offset = 0; /* offset in bytes in buf to put next arg */
+ char* arg = array_of_argv_f + argv_elem_len * i; /* Point to 1st arg of command i */
+ do {
+ if (offset + argv_elem_len > len) { /* Make sure buf is big enough */
+ len = offset + argv_elem_len;
+ newbuf = (char*)MPIU_Realloc(buf, len);
+ if (!newbuf) {
+ MPIU_Free(buf);
+ MPIU_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**nomem");
+ }
+ buf = newbuf;
+ }
+
+ /* Check if arg is a terminating blank string */
+ j = 0;
+ while (arg[j] == ' ' && j < argv_elem_len) j++;
+ terminate = (j == argv_elem_len);
+
+ strncpy(buf + offset, arg, argv_elem_len); /* Copy it even it is all blank */
+ arg += argv_elem_len * count; /* Move to next arg of command i */
+ offset += argv_elem_len;
+ } while(!terminate);
+
+ /* Convert the args into C style. We indicate we don't know the count of strings so
+ that a NULL pointer will be appended at the end.
+ */
+ mpi_errno = MPIR_Fortran_array_of_string_f2c(buf, &(array_of_argv_c[i]), argv_elem_len, 0, 0);
if (mpi_errno != MPI_SUCCESS) {
for (j = i - 1; j >= 0; j--)
MPIU_Free(array_of_argv_c[j]);
+ MPIU_Free(buf);
goto fn_fail;
}
}
+
+ MPIU_Free(buf);
}
mpi_errno = PMPI_Comm_spawn_multiple(count, array_of_commands_c, array_of_argv_c,
http://git.mpich.org/mpich.git/commitdiff/cfa1fa4bb909c7858628d1acd6b23e8390d27cc4
commit cfa1fa4bb909c7858628d1acd6b23e8390d27cc4
Author: Junchao Zhang <jczhang at mcs.anl.gov>
Date: Tue Jun 10 16:11:39 2014 -0500
Ported more F90 tests to F08
The new tests include: io, spawn, topo, timer, profile, ext, info, init and misc
No review since F08 binding is experimental now.
diff --git a/test/mpi/configure.ac b/test/mpi/configure.ac
index 7ca2a6e..0af3ba0 100644
--- a/test/mpi/configure.ac
+++ b/test/mpi/configure.ac
@@ -1545,17 +1545,26 @@ AC_OUTPUT(maint/testmerge \
f90/ext/testlist \
f90/io/Makefile \
f90/misc/Makefile \
- f90/profile/Makefile \
+ f90/profile/Makefile \
f08/Makefile \
- f08/util/Makefile \
- f08/pt2pt/Makefile \
- f08/coll/Makefile \
- f08/datatype/Makefile \
- f08/attr/Makefile \
- f08/comm/Makefile \
- f08/rma/Makefile \
- f08/subarray/Makefile \
- cxx/Makefile \
+ f08/attr/Makefile \
+ f08/datatype/Makefile \
+ f08/util/Makefile \
+ f08/coll/Makefile \
+ f08/comm/Makefile \
+ f08/pt2pt/Makefile \
+ f08/rma/Makefile \
+ f08/subarray/Makefile \
+ f08/topo/Makefile \
+ f08/io/Makefile \
+ f08/init/Makefile \
+ f08/info/Makefile \
+ f08/spawn/Makefile \
+ f08/timer/Makefile \
+ f08/ext/Makefile \
+ f08/misc/Makefile \
+ f08/profile/Makefile \
+ cxx/Makefile \
cxx/util/Makefile \
cxx/attr/Makefile \
cxx/pt2pt/Makefile \
diff --git a/test/mpi/f08/ext/Makefile.am b/test/mpi/f08/ext/Makefile.am
new file mode 100644
index 0000000..426f9ed
--- /dev/null
+++ b/test/mpi/f08/ext/Makefile.am
@@ -0,0 +1,42 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist.in
+
+# allocmemf is an "extra" program because it requires a Fortran extension
+EXTRA_PROGRAMS = allocmemf90
+
+noinst_PROGRAMS = c2f2cf90 ctypesinf90 c2f90mult
+
+allocmemf90_SOURCES = allocmemf90.f90
+c2f2cf90_SOURCES = c2f2cf90.f90 c2f902c.c
+ctypesinf90_SOURCES = ctypesinf90.f90 ctypesfromc.c
+
+# C programs get a different mtest utility object
+c2f90mult_LDADD = $(top_builddir)/util/mtest.o
+c2f90mult_SOURCES = c2f90mult.c
+
+## add1size.h will be distributed because it's listed in AC_CONFIG_FILES/AC_OUTPUT
+
+# ensure that dependent tests will be rebuilt when add1size.h is updated
+
+# we don't get this from Makefile_f90.mtest and we don't include Makefile.mtest
+$(top_builddir)/util/mtest.o:
+ (cd $(top_builddir)/util && $(MAKE) mtest.o)
+
+BUILT_SOURCES = c2f902c.c ctypesfromc.c
+
+# FIXME what's up with these rules? They appear to copy a file to itself in
+# non-VPATH builds...
+c2f902c.c: $(srcdir)/../../f90/ext/c2f902c.c
+ cp $(srcdir)/../../f90/ext/c2f902c.c c2f902c.c
+ctypesfromc.c: $(srcdir)/../../f77/ext/ctypesfromc.c
+ cp $(srcdir)/../../f77/ext/ctypesfromc.c ctypesfromc.c
+
+
diff --git a/test/mpi/f08/ext/allocmemf90.f90 b/test/mpi/f08/ext/allocmemf90.f90
new file mode 100644
index 0000000..ba31e8d
--- /dev/null
+++ b/test/mpi/f08/ext/allocmemf90.f90
@@ -0,0 +1,36 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ use, intrinsic :: iso_c_binding
+ real, pointer :: a(:,:)
+ integer (kind=MPI_ADDRESS_KIND) asize
+ type(c_ptr) cptr
+
+ integer ierr, sizeofreal, errs
+ integer i,j
+!
+ errs = 0
+ call mtest_init(ierr)
+ call mpi_type_size( MPI_REAL, sizeofreal, ierr )
+! Make sure we pass in an integer of the correct type
+ asize = sizeofreal * 100 * 100
+ call mpi_alloc_mem( asize,MPI_INFO_NULL,cptr,ierr )
+
+ call c_f_pointer(cptr, a, [100, 100])
+
+ do i=1,100
+ do j=1,100
+ a(i,j) = -1
+ enddo
+ enddo
+ a(3,5) = 10.0
+
+ call mpi_free_mem( a, ierr )
+ call mtest_finalize(errs)
+ call mpi_finalize(ierr)
+
+ end
diff --git a/test/mpi/f08/ext/c2f2cf90.f90 b/test/mpi/f08/ext/c2f2cf90.f90
new file mode 100644
index 0000000..3e8ef13
--- /dev/null
+++ b/test/mpi/f08/ext/c2f2cf90.f90
@@ -0,0 +1,131 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer errs, toterrs, ierr
+ integer wrank, wsize
+ type(MPI_Group) wgroup
+ type(MPI_Info) info
+ type(MPI_Request) req
+
+ integer fsize, frank
+ !integer comm, group, type, op, errh, result
+
+ type(MPI_Comm) comm
+ type(MPI_Group) group
+ type(MPI_Datatype) type
+ type(MPI_Op) op
+ type(MPI_Errhandler) errh
+ integer result
+
+ integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest, &
+ & c2ferrhandler, c2fop
+ character value*100
+ logical flag
+ errs = 0
+
+ call mpi_init( ierr )
+
+!
+! Test passing a Fortran MPI object to C
+ call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
+ errs = errs + c2fcomm( MPI_COMM_WORLD%MPI_VAL)
+ call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr )
+ errs = errs + c2fgroup( wgroup%MPI_VAL )
+ call mpi_group_free( wgroup, ierr )
+
+ call mpi_info_create( info, ierr )
+ call mpi_info_set( info, "host", "myname", ierr )
+ call mpi_info_set( info, "wdir", "/rdir/foo", ierr )
+ errs = errs + c2finfo( info%MPI_VAL )
+ call mpi_info_free( info, ierr )
+
+ errs = errs + c2ftype( MPI_INTEGER%MPI_VAL )
+
+ call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG, &
+ & MPI_COMM_WORLD, req, ierr )
+ call mpi_cancel( req, ierr )
+ errs = errs + c2frequest( req%MPI_VAL )
+ call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
+
+ errs = errs + c2ferrhandler( MPI_ERRORS_RETURN%MPI_VAL )
+
+ errs = errs + c2fop( MPI_SUM%MPI_VAL )
+
+!
+! Test using a C routine to provide the Fortran handle
+ call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
+ call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
+
+ call f2ccomm( comm )
+ call mpi_comm_size( comm, fsize, ierr )
+ call mpi_comm_rank( comm, frank, ierr )
+ if (fsize.ne.wsize .or. frank.ne.wrank) then
+ errs = errs + 1
+ print *, "Comm(fortran) has wrong size or rank"
+ endif
+
+ call f2cgroup( group )
+ call mpi_group_size( group, fsize, ierr )
+ call mpi_group_rank( group, frank, ierr )
+ if (fsize.ne.wsize .or. frank.ne.wrank) then
+ errs = errs + 1
+ print *, "Group(fortran) has wrong size or rank"
+ endif
+ call mpi_group_free( group, ierr )
+
+ call f2ctype( type )
+ if (type .ne. MPI_INTEGER) then
+ errs = errs + 1
+ print *, "Datatype(fortran) is not MPI_INT"
+ endif
+
+ call f2cinfo( info )
+ call mpi_info_get( info, "host", 100, value, flag, ierr )
+ if (.not. flag) then
+ errs = errs + 1
+ print *, "Info test for host returned false"
+ else if (value .ne. "myname") then
+ errs = errs + 1
+ print *, "Info test for host returned ", value
+ endif
+ call mpi_info_get( info, "wdir", 100, value, flag, ierr )
+ if (.not. flag) then
+ errs = errs + 1
+ print *, "Info test for wdir returned false"
+ else if (value .ne. "/rdir/foo") then
+ errs = errs + 1
+ print *, "Info test for wdir returned ", value
+ endif
+ call mpi_info_free( info, ierr )
+
+ call f2cop( op )
+ if (op .ne. MPI_SUM) then
+ errs = errs + 1
+ print *, "Fortran MPI_SUM not MPI_SUM in C"
+ endif
+
+ call f2cerrhandler( errh )
+ if (errh .ne. MPI_ERRORS_RETURN) then
+ errs = errs + 1
+ print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C"
+ endif
+!
+! Summarize the errors
+!
+ call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
+ & MPI_COMM_WORLD, ierr )
+ if (wrank .eq. 0) then
+ if (toterrs .eq. 0) then
+ print *, ' No Errors'
+ else
+ print *, ' Found ', toterrs, ' errors'
+ endif
+ endif
+
+ call mpi_finalize( ierr )
+ end
+
diff --git a/test/mpi/f08/ext/c2f90mult.c b/test/mpi/f08/ext/c2f90mult.c
new file mode 100644
index 0000000..19b802b
--- /dev/null
+++ b/test/mpi/f08/ext/c2f90mult.c
@@ -0,0 +1,61 @@
+/* This file created from test/mpi/f77/ext/c2fmult.c with f77tof90 */
+/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
+/*
+ * (C) 2001 by Argonne National Laboratory.
+ * See COPYRIGHT in top-level directory.
+ */
+
+/*
+ Check that MPI_xxxx_c2f, applied to the same object several times,
+ yields the same handle. We do this because when MPI handles in
+ C are a different length than those in Fortran, care needs to
+ be exercised to ensure that the mapping from one to another is unique.
+ (Test added to test a potential problem in ROMIO for handling MPI_File
+ on 64-bit systems)
+*/
+#include "mpi.h"
+#include <stdio.h>
+#include "mpitest.h"
+
+int main( int argc, char *argv[] )
+{
+ MPI_Fint handleA, handleB;
+ int rc;
+ int errs = 0;
+ int buf[1];
+ MPI_Request cRequest;
+ MPI_Status st;
+ int tFlag;
+
+ MTest_Init( &argc, &argv );
+
+ /* Request */
+ rc = MPI_Irecv( buf, 1, MPI_INT, 0, 0, MPI_COMM_WORLD, &cRequest );
+ if (rc) {
+ errs++;
+ printf( "Unable to create request\n" );
+ }
+ else {
+ handleA = MPI_Request_c2f( cRequest );
+ handleB = MPI_Request_c2f( cRequest );
+ if (handleA != handleB) {
+ errs++;
+ printf( "MPI_Request_c2f does not give the same handle twice on the same MPI_Request\n" );
+ }
+ }
+ MPI_Cancel( &cRequest );
+ MPI_Test( &cRequest, &tFlag, &st );
+ MPI_Test_cancelled( &st, &tFlag );
+ if (!tFlag) {
+ errs++;
+ printf( "Unable to cancel MPI_Irecv request\n" );
+ }
+ /* Using MPI_Request_free should be ok, but some MPI implementations
+ object to it imediately after the cancel and that isn't essential to
+ this test */
+
+ MTest_Finalize( errs );
+ MPI_Finalize();
+
+ return 0;
+}
diff --git a/test/mpi/f08/ext/ctypesinf90.f90 b/test/mpi/f08/ext/ctypesinf90.f90
new file mode 100644
index 0000000..815d9b0
--- /dev/null
+++ b/test/mpi/f08/ext/ctypesinf90.f90
@@ -0,0 +1,49 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer ierr
+ integer errs, wrank
+ integer f2ctype
+!
+ call mtest_init( ierr )
+ call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
+!
+ errs = 0
+!
+ errs = errs + f2ctype( MPI_CHAR, 0 )
+ errs = errs + f2ctype( MPI_SIGNED_CHAR, 1 )
+ errs = errs + f2ctype( MPI_UNSIGNED_CHAR, 2 )
+ errs = errs + f2ctype( MPI_WCHAR, 3 )
+ errs = errs + f2ctype( MPI_SHORT, 4 )
+ errs = errs + f2ctype( MPI_UNSIGNED_SHORT, 5 )
+ errs = errs + f2ctype( MPI_INT, 6 )
+ errs = errs + f2ctype( MPI_UNSIGNED, 7 )
+ errs = errs + f2ctype( MPI_LONG, 8 )
+ errs = errs + f2ctype( MPI_UNSIGNED_LONG, 9 )
+ errs = errs + f2ctype( MPI_FLOAT, 10 )
+ errs = errs + f2ctype( MPI_DOUBLE, 11 )
+ errs = errs + f2ctype( MPI_FLOAT_INT, 12 )
+ errs = errs + f2ctype( MPI_DOUBLE_INT, 13 )
+ errs = errs + f2ctype( MPI_LONG_INT, 14 )
+ errs = errs + f2ctype( MPI_SHORT_INT, 15 )
+ errs = errs + f2ctype( MPI_2INT, 16 )
+ if (MPI_LONG_DOUBLE .ne. MPI_TYPE_NULL) then
+ errs = errs + f2ctype( MPI_LONG_DOUBLE, 17 )
+ errs = errs + f2ctype( MPI_LONG_DOUBLE_INT, 21 )
+ endif
+ if (MPI_LONG_LONG .ne. MPI_TYPE_NULL) then
+ errs = errs + f2ctype( MPI_LONG_LONG_INT, 18 )
+ errs = errs + f2ctype( MPI_LONG_LONG, 19 )
+ errs = errs + f2ctype( MPI_UNSIGNED_LONG_LONG, 20 )
+ endif
+!
+! Summarize the errors
+!
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
diff --git a/test/mpi/f08/ext/testlist b/test/mpi/f08/ext/testlist
new file mode 100644
index 0000000..5f03175
--- /dev/null
+++ b/test/mpi/f08/ext/testlist
@@ -0,0 +1,4 @@
+c2f2cf90 1
+c2f90mult 1
+ctypesinf90 1
+allocmemf90 1
diff --git a/test/mpi/f08/info/Makefile.am b/test/mpi/f08/info/Makefile.am
new file mode 100644
index 0000000..8a324f7
--- /dev/null
+++ b/test/mpi/f08/info/Makefile.am
@@ -0,0 +1,15 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+# avoid having to write many "foo_SOURCES = foo.f90" lines
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = infotestf90 infotest2f90
diff --git a/test/mpi/f08/info/infotest2f90.f90 b/test/mpi/f08/info/infotest2f90.f90
new file mode 100644
index 0000000..d0acc27
--- /dev/null
+++ b/test/mpi/f08/info/infotest2f90.f90
@@ -0,0 +1,140 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer ierr, errs
+ type(MPI_Info) i1, i2
+ integer nkeys, i, j, sumindex, vlen, ln, valuelen
+ logical found, flag
+ character*(MPI_MAX_INFO_KEY) keys(6)
+ character*(MPI_MAX_INFO_VAL) values(6)
+ character*(MPI_MAX_INFO_KEY) mykey
+ character*(MPI_MAX_INFO_VAL) myvalue
+!
+ data keys/"Key1", "key2", "KeY3", "A Key With Blanks","See Below", &
+ & "last"/
+ data values/"value 1", "value 2", "VaLue 3", "key=valu:3","false", &
+ & "no test"/
+!
+ errs = 0
+
+ call mtest_init( ierr )
+
+! Note that the MPI standard requires that leading an trailing blanks
+! are stripped from keys and values (Section 4.10, The Info Object)
+!
+! First, create and initialize an info
+ call mpi_info_create( i1, ierr )
+ call mpi_info_set( i1, keys(1), values(1), ierr )
+ call mpi_info_set( i1, keys(2), values(2), ierr )
+ call mpi_info_set( i1, keys(3), values(3), ierr )
+ call mpi_info_set( i1, keys(4), values(4), ierr )
+ call mpi_info_set( i1, " See Below", values(5), ierr )
+ call mpi_info_set( i1, keys(6), " no test ", ierr )
+!
+ call mpi_info_get_nkeys( i1, nkeys, ierr )
+ if (nkeys .ne. 6) then
+ print *, ' Number of keys should be 6, is ', nkeys
+ endif
+ sumindex = 0
+ do i=1, nkeys
+! keys are number from 0 to n-1, even in Fortran (Section 4.10)
+ call mpi_info_get_nthkey( i1, i-1, mykey, ierr )
+ found = .false.
+ do j=1, 6
+ if (mykey .eq. keys(j)) then
+ found = .true.
+ sumindex = sumindex + j
+ call mpi_info_get_valuelen( i1, mykey, vlen, flag, ierr )
+ if (.not.flag) then
+ errs = errs + 1
+ print *, ' no value for key', mykey
+ else
+ call mpi_info_get( i1, mykey, MPI_MAX_INFO_VAL, &
+ & myvalue, flag, ierr )
+ if (myvalue .ne. values(j)) then
+ errs = errs + 1
+ print *, ' Value for ', mykey, ' not expected'
+ else
+ do ln=MPI_MAX_INFO_VAL,1,-1
+ if (myvalue(ln:ln) .ne. ' ') then
+ if (vlen .ne. ln) then
+ errs = errs + 1
+ print *, ' length is ', ln, &
+ & ' but valuelen gave ', vlen, &
+ & ' for key ', mykey
+ endif
+ goto 100
+ endif
+ enddo
+ 100 continue
+ endif
+ endif
+ endif
+ enddo
+ if (.not.found) then
+ print *, i, 'th key ', mykey, ' not in list'
+ endif
+ enddo
+ if (sumindex .ne. 21) then
+ errs = errs + 1
+ print *, ' Not all keys found'
+ endif
+!
+! delete 2, then dup, then delete 2 more
+ call mpi_info_delete( i1, keys(1), ierr )
+ call mpi_info_delete( i1, keys(2), ierr )
+ call mpi_info_dup( i1, i2, ierr )
+ call mpi_info_delete( i1, keys(3), ierr )
+!
+! check the contents of i2
+! valuelen does not signal an error for unknown keys; instead, sets
+! flag to false
+ do i=1,2
+ flag = .true.
+ call mpi_info_get_valuelen( i2, keys(i), valuelen, flag, ierr )
+ if (flag) then
+ errs = errs + 1
+ print *, ' Found unexpected key ', keys(i)
+ endif
+ myvalue = 'A test'
+ call mpi_info_get( i2, keys(i), MPI_MAX_INFO_VAL, &
+ & myvalue, flag, ierr )
+ if (flag) then
+ errs = errs + 1
+ print *, ' Found unexpected key in MPI_Info_get ', keys(i)
+ else
+ if (myvalue .ne. 'A test') then
+ errs = errs + 1
+ print *, ' Returned value overwritten, is now ', myvalue
+ endif
+ endif
+
+ enddo
+ do i=3,6
+ myvalue = ' '
+ call mpi_info_get( i2, keys(i), MPI_MAX_INFO_VAL, &
+ & myvalue, flag, ierr )
+ if (.not. flag) then
+ errs = errs + 1
+ print *, ' Did not find key ', keys(i)
+ else
+ if (myvalue .ne. values(i)) then
+ errs = errs + 1
+ print *, ' Found wrong value (', myvalue, ') for key ', &
+ & keys(i)
+ endif
+ endif
+ enddo
+!
+! Free info
+ call mpi_info_free( i1, ierr )
+ call mpi_info_free( i2, ierr )
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
diff --git a/test/mpi/f08/info/infotestf90.f90 b/test/mpi/f08/info/infotestf90.f90
new file mode 100644
index 0000000..41edaea
--- /dev/null
+++ b/test/mpi/f08/info/infotestf90.f90
@@ -0,0 +1,56 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! Simple info test
+ program main
+ use mpi_f08
+ type(MPI_Info) i1, i2
+ integer i, errs, ierr
+ integer valuelen
+ parameter (valuelen=64)
+ character*(valuelen) value
+ logical flag
+!
+ errs = 0
+
+ call MTest_Init( ierr )
+
+ call mpi_info_create( i1, ierr )
+ call mpi_info_create( i2, ierr )
+
+ call mpi_info_set( i1, "key1", "value1", ierr )
+ call mpi_info_set( i2, "key2", "value2", ierr )
+
+ call mpi_info_get( i1, "key2", valuelen, value, flag, ierr )
+ if (flag) then
+ print *, "Found key2 in info1"
+ errs = errs + 1
+ endif
+
+ call MPI_Info_get( i1, "key1", 64, value, flag, ierr )
+ if (.not. flag ) then
+ print *, "Did not find key1 in info1"
+ errs = errs + 1
+ else
+ if (value .ne. "value1") then
+ print *, "Found wrong value (", value, "), expected value1"
+ errs = errs + 1
+ else
+! check for trailing blanks
+ do i=7,valuelen
+ if (value(i:i) .ne. " ") then
+ print *, "Found non blank in info value"
+ errs = errs + 1
+ endif
+ enddo
+ endif
+ endif
+
+ call mpi_info_free( i1, ierr )
+ call mpi_info_free( i2, ierr )
+
+ call MTest_Finalize( errs )
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/info/testlist b/test/mpi/f08/info/testlist
new file mode 100644
index 0000000..24070d1
--- /dev/null
+++ b/test/mpi/f08/info/testlist
@@ -0,0 +1,2 @@
+infotestf90 1
+infotest2f90 1
diff --git a/test/mpi/f08/init/Makefile.am b/test/mpi/f08/init/Makefile.am
new file mode 100644
index 0000000..00e2964
--- /dev/null
+++ b/test/mpi/f08/init/Makefile.am
@@ -0,0 +1,25 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+# avoid having to write many "foo_SOURCES = foo.f90" lines
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = baseenvf90
+
+EXTRA_PROGRAMS = checksizes
+# Checksizes is created by configure, and is a C program that tests that
+# configure has correctly computed the sizes of MPI_Aint and MPI_Offset
+# for Fortran. This is not run by default but can be used to check
+# that configure found the correct values.
+checksizes_LDADD =
+nodist_checksizes_SOURCES = checksizes.c
+
+DISTCLEANFILES = checksizes.c
diff --git a/test/mpi/f08/init/baseenvf90.f90 b/test/mpi/f08/init/baseenvf90.f90
new file mode 100644
index 0000000..d1f9a48
--- /dev/null
+++ b/test/mpi/f08/init/baseenvf90.f90
@@ -0,0 +1,89 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer ierr, provided, errs, rank, size
+ integer iv, isubv, qprovided
+ logical flag
+
+ errs = 0
+ flag = .true.
+ call mpi_finalized( flag, ierr )
+ if (flag) then
+ errs = errs + 1
+ print *, 'Returned true for finalized before init'
+ endif
+ flag = .true.
+ call mpi_initialized( flag, ierr )
+ if (flag) then
+ errs = errs + 1
+ print *, 'Return true for initialized before init'
+ endif
+
+ provided = -1
+ call mpi_init_thread( MPI_THREAD_MULTIPLE, provided, ierr )
+
+ if (provided .ne. MPI_THREAD_MULTIPLE .and. &
+ & provided .ne. MPI_THREAD_SERIALIZED .and. &
+ & provided .ne. MPI_THREAD_FUNNELED .and. &
+ & provided .ne. MPI_THREAD_SINGLE) then
+ errs = errs + 1
+ print *, ' Unrecognized value for provided = ', provided
+ endif
+
+ iv = -1
+ isubv = -1
+ call mpi_get_version( iv, isubv, ierr )
+ if (iv .ne. MPI_VERSION .or. isubv .ne. MPI_SUBVERSION) then
+ errs = errs + 1
+ print *, 'Version in mpif.h and get_version do not agree'
+ print *, 'Version in mpif.h is ', MPI_VERSION, '.', &
+ & MPI_SUBVERSION
+ print *, 'Version in get_version is ', iv, '.', isubv
+ endif
+ if (iv .lt. 1 .or. iv .gt. 3) then
+ errs = errs + 1
+ print *, 'Version of MPI is invalid (=', iv, ')'
+ endif
+ if (isubv.lt.0 .or. isubv.gt.2) then
+ errs = errs + 1
+ print *, 'Subversion of MPI is invalid (=', isubv, ')'
+ endif
+
+ call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+ call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
+
+ flag = .false.
+ call mpi_is_thread_main( flag, ierr )
+ if (.not.flag) then
+ errs = errs + 1
+ print *, 'is_thread_main returned false for main thread'
+ endif
+
+ call mpi_query_thread( qprovided, ierr )
+ if (qprovided .ne. provided) then
+ errs = errs + 1
+ print *,'query thread and init thread disagree on'// &
+ & ' thread level'
+ endif
+
+ call mpi_finalize( ierr )
+ flag = .false.
+ call mpi_finalized( flag, ierr )
+ if (.not. flag) then
+ errs = errs + 1
+ print *, 'finalized returned false after finalize'
+ endif
+
+ if (rank .eq. 0) then
+ if (errs .eq. 0) then
+ print *, ' No Errors'
+ else
+ print *, ' Found ', errs, ' errors'
+ endif
+ endif
+
+ end
diff --git a/test/mpi/f08/init/testlist b/test/mpi/f08/init/testlist
new file mode 100644
index 0000000..7648cd8
--- /dev/null
+++ b/test/mpi/f08/init/testlist
@@ -0,0 +1 @@
+baseenvf90 1
diff --git a/test/mpi/f08/io/Makefile.am b/test/mpi/f08/io/Makefile.am
new file mode 100644
index 0000000..e69d4de
--- /dev/null
+++ b/test/mpi/f08/io/Makefile.am
@@ -0,0 +1,130 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+# avoid having to write many "foo_SOURCES = foo.f90" lines
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = \
+ iwriteatf90 \
+ iwritef90 \
+ iwriteshf90 \
+ writef90 \
+ writeatf90 \
+ writeallf90 \
+ writeallbef90 \
+ writeordf90 \
+ writeordbef90 \
+ writeshf90 \
+ writeatallf90 \
+ writeatallbef90 \
+ fileerrf90 \
+ fileinfof90 \
+ shpositionf90 \
+ atomicityf90 \
+ miscfilef90 \
+ setviewcurf90 \
+ c2f90multio \
+ c2f2ciof90
+
+
+# We don't want to distribute these source files because they are created by
+# "testmerge", hence "nodist_foo_SOURCES"
+nodist_iwriteatf90_SOURCES = iwriteatf90.f90
+nodist_iwritef90_SOURCES = iwritef90.f90
+nodist_iwriteshf90_SOURCES = iwriteshf90.f90
+nodist_writeallbef90_SOURCES = writeallbef90.f90
+nodist_writeallf90_SOURCES = writeallf90.f90
+nodist_writeatallbef90_SOURCES = writeatallbef90.f90
+nodist_writeatallf90_SOURCES = writeatallf90.f90
+nodist_writeatf90_SOURCES = writeatf90.f90
+nodist_writef90_SOURCES = writef90.f90
+nodist_writeordbef90_SOURCES = writeordbef90.f90
+nodist_writeordf90_SOURCES = writeordf90.f90
+nodist_writeshf90_SOURCES = writeshf90.f90
+
+c2f90multio_SOURCES = c2f90multio.c
+# this is a C only program, so we must either:
+# A) prevent the makefile-wide "LDADD=mtestf90.o" from affecting this program, or
+# B) link with the fortran compiler, otherwise we'll get link failures from
+# compilers with runtime support libs, such as PGI
+c2f90multio_LDADD =
+
+c2f2ciof90_SOURCES = c2f2ciof90.f90 c2f902cio.c
+
+## these header files will be distributed because they're listed in
+## AC_CONFIG_FILES/AC_OUTPUT
+
+# ensure that dependent tests will be rebuilt when headers are updated
+
+
+# these files are genereated using testmerge (see below)
+generated_io_sources = \
+ iwriteatf90.f90 \
+ iwritef90.f90 \
+ iwriteshf90.f90 \
+ writeallbef90.f90 \
+ writeallf90.f90 \
+ writeatallbef90.f90 \
+ writeatallf90.f90 \
+ writeatf90.f90 \
+ writef90.f90 \
+ writeordbef90.f90 \
+ writeordf90.f90 \
+ writeshf90.f90
+
+EXTRA_DIST += ioharness.defn ioharness.tlt
+
+# a parallel-safe scheme to generate the tests, see the automake-1.11.1 manual,
+# section 27.9 "Handling Tools That Produce Multiple Outputs" for an explanation
+#
+# Note that using testmerge at make-time adds a dependency on perl for users.
+# It's been like this for a long time, so I don't think it's a problem in
+# practice. The best way to fix this is to drop the nodist_foo_SOURCES lines,
+# modify testmerge to output the stamp file, and then enclose modified versions
+# of these rules in an "if MAINAINER_MODE". The files also should then move to
+# MAINTAINERCLEANFILES from DISTCLEANFILES. [goodell@ 2011-07-11]
+gen-src-stamp: $(srcdir)/ioharness.defn $(srcdir)/ioharness.tlt
+ @rm -f gen-src-tmp
+ @touch gen-src-tmp
+ $(top_builddir)/maint/testmerge -defn=$(top_srcdir)/maint/common.defn \
+ $(srcdir)/ioharness.defn $(srcdir)/ioharness.tlt
+ @mv -f gen-src-tmp $@
+
+$(generated_io_sources): gen-src-stamp
+## Recover from the removal of $@
+ @if test -f $@; then :; else \
+ trap 'rm -rf gen-src-lock gen-src-stamp' 1 2 13 15; \
+## mkdir is a portable test-and-set
+ if mkdir gen-src-lock 2>/dev/null; then \
+## This code is being executed by the first process.
+ rm -f gen-src-stamp; \
+ $(MAKE) $(AM_MAKEFLAGS) gen-src-stamp; \
+ rmdir gen-src-lock; \
+ else \
+## This code is being executed by the follower processes.
+## Wait until the first process is done.
+ while test -d gen-src-lock; do sleep 1; done; \
+## Succeed if and only if the first process succeeded.
+ test -f gen-src-stamp; exit $$?; \
+ fi; \
+ fi
+
+# just in case
+CLEANFILES += gen-src-tmp gen-src-stamp
+
+# clean up after the test programs
+clean-local:
+ -rm -f .iotest.txt.*
+
+DISTCLEANFILES = $(generated_io_sources)
+
+c2f902cio.c: $(srcdir)/../../f90/io/c2f902cio.c
+ cp $(srcdir)/../../f90/io/c2f902cio.c c2f902cio.c
diff --git a/test/mpi/f08/io/atomicityf90.f90 b/test/mpi/f08/io/atomicityf90.f90
new file mode 100644
index 0000000..3dbbe4d
--- /dev/null
+++ b/test/mpi/f08/io/atomicityf90.f90
@@ -0,0 +1,201 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer (kind=MPI_OFFSET_KIND) disp
+
+! tests whether atomicity semantics are satisfied for overlapping accesses
+! in atomic mode. The probability of detecting errors is higher if you run
+! it on 8 or more processes.
+! This is a version of the test in romio/test/atomicity.c .
+ integer BUFSIZE
+ parameter (BUFSIZE=10000)
+ integer writebuf(BUFSIZE), readbuf(BUFSIZE)
+ integer i, mynod, nprocs, len, ierr, errs, toterrs
+ character*50 filename
+ type(MPI_Datatype) newtype
+ type(MPI_File) fh
+ type(MPI_Info) info
+ type(MPI_Status) status
+
+ errs = 0
+
+ call MPI_Init(ierr)
+ call MPI_Comm_rank(MPI_COMM_WORLD, mynod, ierr )
+ call MPI_Comm_size(MPI_COMM_WORLD, nprocs, ierr )
+
+! Unlike the C version, we fix the filename because of the difficulties
+! in accessing the command line from different Fortran environments
+ filename = "testfile.txt"
+! test atomicity of contiguous accesses
+
+! initialize file to all zeros
+ if (mynod .eq. 0) then
+ call MPI_File_delete(filename, MPI_INFO_NULL, ierr )
+ call MPI_File_open(MPI_COMM_SELF, filename, MPI_MODE_CREATE + &
+ & MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr )
+ do i=1, BUFSIZE
+ writebuf(i) = 0
+ enddo
+ call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status, &
+ & ierr)
+ call MPI_File_close(fh, ierr )
+ endif
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+
+ do i=1, BUFSIZE
+ writebuf(i) = 10
+ readbuf(i) = 20
+ enddo
+
+ call MPI_File_open(MPI_COMM_WORLD, filename, MPI_MODE_CREATE + &
+ & MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr )
+
+! set atomicity to true
+ call MPI_File_set_atomicity(fh, .true., ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ print *, "Atomic mode not supported on this file system."
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
+ endif
+
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+
+! process 0 writes and others concurrently read. In atomic mode,
+! the data read must be either all old values or all new values; nothing
+! in between.
+
+ if (mynod .eq. 0) then
+ call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status, &
+ & ierr)
+ else
+ call MPI_File_read(fh, readbuf, BUFSIZE, MPI_INTEGER, status, &
+ & ierr )
+ if (ierr .eq. MPI_SUCCESS) then
+ if (readbuf(1) .eq. 0) then
+! the rest must also be 0
+ do i=2, BUFSIZE
+ if (readbuf(i) .ne. 0) then
+ errs = errs + 1
+ print *, "(contig)Process ", mynod, ": readbuf(", i &
+ & ,") is ", readbuf(i), ", should be 0"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
+ endif
+ enddo
+ else if (readbuf(1) .eq. 10) then
+! the rest must also be 10
+ do i=2, BUFSIZE
+ if (readbuf(i) .ne. 10) then
+ errs = errs + 1
+ print *, "(contig)Process ", mynod, ": readbuf(", i &
+ & ,") is ", readbuf(i), ", should be 10"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
+ endif
+ enddo
+ else
+ errs = errs + 1
+ print *, "(contig)Process ", mynod, ": readbuf(1) is ", &
+ & readbuf(1), ", should be either 0 or 10"
+ endif
+ endif
+ endif
+
+ call MPI_File_close( fh, ierr )
+
+ call MPI_Barrier( MPI_COMM_WORLD, ierr )
+
+
+! repeat the same test with a noncontiguous filetype
+
+ call MPI_Type_vector(BUFSIZE, 1, 2, MPI_INTEGER, newtype, ierr)
+ call MPI_Type_commit(newtype, ierr )
+
+ call MPI_Info_create(info, ierr )
+! I am setting these info values for testing purposes only. It is
+! better to use the default values in practice. */
+ call MPI_Info_set(info, "ind_rd_buffer_size", "1209", ierr )
+ call MPI_Info_set(info, "ind_wr_buffer_size", "1107", ierr )
+
+ if (mynod .eq. 0) then
+ call MPI_File_delete(filename, MPI_INFO_NULL, ierr )
+ call MPI_File_open(MPI_COMM_SELF, filename, MPI_MODE_CREATE + &
+ & MPI_MODE_RDWR, info, fh, ierr )
+ do i=1, BUFSIZE
+ writebuf(i) = 0
+ enddo
+ disp = 0
+ call MPI_File_set_view(fh, disp, MPI_INTEGER, newtype, "native" &
+ & ,info, ierr)
+ call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status, &
+ & ierr )
+ call MPI_File_close( fh, ierr )
+ endif
+ call MPI_Barrier( MPI_COMM_WORLD, ierr )
+
+ do i=1, BUFSIZE
+ writebuf(i) = 10
+ readbuf(i) = 20
+ enddo
+
+ call MPI_File_open(MPI_COMM_WORLD, filename, MPI_MODE_CREATE + &
+ & MPI_MODE_RDWR, info, fh, ierr )
+ call MPI_File_set_atomicity(fh, .true., ierr)
+ disp = 0
+ call MPI_File_set_view(fh, disp, MPI_INTEGER, newtype, "native", &
+ & info, ierr )
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+
+ if (mynod .eq. 0) then
+ call MPI_File_write(fh, writebuf, BUFSIZE, MPI_INTEGER, status, &
+ & ierr )
+ else
+ call MPI_File_read(fh, readbuf, BUFSIZE, MPI_INTEGER, status, &
+ & ierr )
+ if (ierr .eq. MPI_SUCCESS) then
+ if (readbuf(1) .eq. 0) then
+ do i=2, BUFSIZE
+ if (readbuf(i) .ne. 0) then
+ errs = errs + 1
+ print *, "(noncontig)Process ", mynod, ": readbuf(" &
+ & , i,") is ", readbuf(i), ", should be 0"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
+ endif
+ enddo
+ else if (readbuf(1) .eq. 10) then
+ do i=2, BUFSIZE
+ if (readbuf(i) .ne. 10) then
+ errs = errs + 1
+ print *, "(noncontig)Process ", mynod, ": readbuf(" &
+ & , i,") is ", readbuf(i), ", should be 10"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr )
+ endif
+ enddo
+ else
+ errs = errs + 1
+ print *, "(noncontig)Process ", mynod, ": readbuf(1) is " &
+ & ,readbuf(1), ", should be either 0 or 10"
+ endif
+ endif
+ endif
+
+ call MPI_File_close( fh, ierr )
+
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+
+ call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
+ & MPI_COMM_WORLD, ierr )
+ if (mynod .eq. 0) then
+ if( toterrs .gt. 0) then
+ print *, "Found ", toterrs, " errors"
+ else
+ print *, " No Errors"
+ endif
+ endif
+
+ call MPI_Type_free(newtype, ierr )
+ call MPI_Info_free(info, ierr )
+
+ call MPI_Finalize(ierr)
+ end
diff --git a/test/mpi/f08/io/c2f2ciof90.f90 b/test/mpi/f08/io/c2f2ciof90.f90
new file mode 100644
index 0000000..1352ed5
--- /dev/null
+++ b/test/mpi/f08/io/c2f2ciof90.f90
@@ -0,0 +1,62 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! Test just the MPI-IO FILE object
+ program main
+ use mpi_f08
+ integer errs, toterrs, ierr
+ integer wrank
+ type(MPI_Group) wgroup
+ integer fsize, frank
+ type(MPI_Comm) comm
+ type(MPI_File) file
+ type(MPI_Group) group
+ integer result
+ integer c2ffile
+
+ errs = 0
+
+ call mpi_init( ierr )
+
+ call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
+ call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr )
+
+ call mpi_file_open( MPI_COMM_WORLD, "temp", MPI_MODE_RDWR + &
+ & MPI_MODE_DELETE_ON_CLOSE + MPI_MODE_CREATE, MPI_INFO_NULL, &
+ & file, ierr )
+ if (ierr .ne. 0) then
+ errs = errs + 1
+ else
+ errs = errs + c2ffile( file )
+ call mpi_file_close( file, ierr )
+ endif
+
+ call f2cfile( file )
+! name is temp, in comm world, no info provided
+ call mpi_file_get_group( file, group, ierr )
+ call mpi_group_compare( group, wgroup, result, ierr )
+ if (result .ne. MPI_IDENT) then
+ errs = errs + 1
+ print *, "Group of file not the group of comm_world"
+ endif
+ call mpi_group_free( group, ierr )
+ call mpi_group_free( wgroup, ierr )
+ call mpi_file_close( file, ierr )
+!
+! Summarize the errors
+!
+ call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
+ & MPI_COMM_WORLD, ierr )
+ if (wrank .eq. 0) then
+ if (toterrs .eq. 0) then
+ print *, ' No Errors'
+ else
+ print *, ' Found ', toterrs, ' errors'
+ endif
+ endif
+
+ call mpi_finalize( ierr )
+ end
+
diff --git a/test/mpi/f08/io/c2f902cio.c b/test/mpi/f08/io/c2f902cio.c
new file mode 100644
index 0000000..20f434c
--- /dev/null
+++ b/test/mpi/f08/io/c2f902cio.c
@@ -0,0 +1,97 @@
+/* This file created from test/mpi/f77/io/c2f2cio.c with f77tof90 */
+/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
+/*
+ *
+ * (C) 2001 by Argonne National Laboratory.
+ * See COPYRIGHT in top-level directory.
+ */
+/*
+ * This file contains the C routines used in testing the c2f and f2c
+ * handle conversion functions for MPI_File
+ * The tests follow this pattern:
+ *
+ * Fortran main program
+ * calls c routine with each handle type, with a prepared
+ * and valid handle (often requires constructing an object)
+ *
+ * C routine uses xxx_f2c routine to get C handle, checks some
+ * properties (i.e., size and rank of communicator, contents of datatype)
+ *
+ * Then the Fortran main program calls a C routine that provides
+ * a handle, and the Fortran program performs similar checks.
+ *
+ * We also assume that a C int is a Fortran integer. If this is not the
+ * case, these tests must be modified.
+ */
+
+/* style: allow:fprintf:1 sig:0 */
+#include <stdio.h>
+#include "mpi.h"
+#include "../../include/mpitestconf.h"
+#include <string.h>
+
+/*
+ Name mapping. All routines are created with names that are lower case
+ with a single trailing underscore. This matches many compilers.
+ We use #define to change the name for Fortran compilers that do
+ not use the lowercase/underscore pattern
+*/
+
+#ifdef F77_NAME_UPPER
+#define c2ffile_ C2FFILE
+#define f2cfile_ F2CFILE
+
+#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED)
+/* Mixed is ok because we use lowercase in all uses */
+#define c2ffile_ c2ffile
+#define f2cfile_ f2cfile
+
+#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \
+ defined(F77_NAME_MIXED_USCORE)
+/* Else leave name alone (routines have no underscore, so both
+ of these map to a lowercase, single underscore) */
+#else
+#error 'Unrecognized Fortran name mapping'
+#endif
+
+/* Prototypes to keep compilers happy */
+int c2ffile_( int * );
+void f2cfile_( int * );
+
+int c2ffile_ ( int *file )
+{
+ MPI_File cFile = MPI_File_f2c( *file );
+ MPI_Group group, wgroup;
+ int result;
+
+ MPI_File_get_group( cFile, &group );
+ MPI_Comm_group( MPI_COMM_WORLD, &wgroup );
+
+ MPI_Group_compare( group, wgroup, &result );
+ if (result != MPI_IDENT) {
+ fprintf( stderr, "File: did not get expected group\n" );
+ return 1;
+ }
+
+ MPI_Group_free( &group );
+ MPI_Group_free( &wgroup );
+ return 0;
+}
+
+/*
+ * The following routines provide handles to the calling Fortran program
+ */
+void f2cfile_( int *file )
+{
+ MPI_File cFile;
+ int rc;
+ rc = MPI_File_open( MPI_COMM_WORLD, (char*)"temp",
+ MPI_MODE_RDWR | MPI_MODE_DELETE_ON_CLOSE | MPI_MODE_CREATE,
+ MPI_INFO_NULL, &cFile );
+ if (rc) {
+ *file = 0;
+ }
+ else {
+ *file = MPI_File_c2f( cFile );
+ }
+}
diff --git a/test/mpi/f08/io/c2f90multio.c b/test/mpi/f08/io/c2f90multio.c
new file mode 100644
index 0000000..c6ae682
--- /dev/null
+++ b/test/mpi/f08/io/c2f90multio.c
@@ -0,0 +1,59 @@
+/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
+/*
+ * (C) 2001 by Argonne National Laboratory.
+ * See COPYRIGHT in top-level directory.
+ */
+
+/*
+ Check that MPI_File_c2f, applied to the same object several times,
+ yields the same handle. We do this because when MPI handles in
+ C are a different length than those in Fortran, care needs to
+ be exercised to ensure that the mapping from one to another is unique.
+ (Test added to test a potential problem in ROMIO for handling MPI_File
+ on 64-bit systems)
+*/
+#include "mpi.h"
+#include <stdio.h>
+
+int main( int argc, char *argv[] )
+{
+ MPI_Fint handleA, handleB;
+ int rc;
+ int errs = 0;
+ int rank;
+ MPI_File cFile;
+
+ MPI_Init( &argc, &argv );
+ MPI_Comm_rank( MPI_COMM_WORLD, &rank );
+
+ /* File */
+ rc = MPI_File_open( MPI_COMM_WORLD, (char*)"temp",
+ MPI_MODE_RDWR | MPI_MODE_DELETE_ON_CLOSE | MPI_MODE_CREATE,
+ MPI_INFO_NULL, &cFile );
+ if (rc) {
+ errs++;
+ printf( "Unable to open file \"temp\"\n" );
+ }
+ else {
+ handleA = MPI_File_c2f( cFile );
+ handleB = MPI_File_c2f( cFile );
+ if (handleA != handleB) {
+ errs++;
+ printf( "MPI_File_c2f does not give the same handle twice on the same MPI_File\n" );
+ }
+ }
+ MPI_File_close( &cFile );
+
+ if (rank == 0) {
+ if (errs) {
+ fprintf(stderr, "Found %d errors\n", errs);
+ }
+ else {
+ printf(" No Errors\n");
+ }
+ }
+
+ MPI_Finalize();
+
+ return 0;
+}
diff --git a/test/mpi/f08/io/fileerrf90.f90 b/test/mpi/f08/io/fileerrf90.f90
new file mode 100644
index 0000000..3441a1e
--- /dev/null
+++ b/test/mpi/f08/io/fileerrf90.f90
@@ -0,0 +1,157 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer errs, ierr, code(2), newerrclass, eclass
+ character*(MPI_MAX_ERROR_STRING) errstring
+ integer rlen
+ type(MPI_Comm) comm
+ integer buf(10)
+ type(MPI_File) file
+ type(MPI_Errhandler) myerrhan, qerr
+ procedure(MPI_File_errhandler_function) myerrhanfunc
+ integer callcount, codesSeen(3)
+ common /myerrhan/ callcount, codesSeen
+
+ errs = 0
+ callcount = 0
+ call mtest_init( ierr )
+!
+! Setup some new codes and classes
+ call mpi_add_error_class( newerrclass, ierr )
+ call mpi_add_error_code( newerrclass, code(1), ierr )
+ call mpi_add_error_code( newerrclass, code(2), ierr )
+ call mpi_add_error_string( newerrclass, "New Class", ierr )
+ call mpi_add_error_string( code(1), "First new code", ierr )
+ call mpi_add_error_string( code(2), "Second new code", ierr )
+!
+ call mpi_file_create_errhandler( myerrhanfunc, myerrhan, ierr )
+!
+! Create a new communicator so that we can leave the default errors-abort
+! on MPI_COMM_WORLD. Use this comm for file_open, just to leave a little
+! more separation from comm_world
+!
+ call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
+ call mpi_file_open( comm, "testfile.txt", MPI_MODE_RDWR + &
+ & MPI_MODE_CREATE, MPI_INFO_NULL, file, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+!
+ call mpi_file_set_errhandler( file, myerrhan, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+
+ call mpi_file_get_errhandler( file, qerr, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+ if (qerr .ne. myerrhan) then
+ errs = errs + 1
+ print *, ' Did not get expected error handler'
+ endif
+ call mpi_errhandler_free( qerr, ierr )
+! We can free our error handler now
+ call mpi_errhandler_free( myerrhan, ierr )
+
+ call mpi_file_call_errhandler( file, newerrclass, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+ call mpi_file_call_errhandler( file, code(1), ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+ call mpi_file_call_errhandler( file, code(2), ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+
+ if (callcount .ne. 3) then
+ errs = errs + 1
+ print *, ' Expected 3 calls to error handler, found ', &
+ & callcount
+ else
+ if (codesSeen(1) .ne. newerrclass) then
+ errs = errs + 1
+ print *, 'Expected class ', newerrclass, ' got ', &
+ & codesSeen(1)
+ endif
+ if (codesSeen(2) .ne. code(1)) then
+ errs = errs + 1
+ print *, 'Expected code ', code(1), ' got ', &
+ & codesSeen(2)
+ endif
+ if (codesSeen(3) .ne. code(2)) then
+ errs = errs + 1
+ print *, 'Expected code ', code(2), ' got ', &
+ & codesSeen(3)
+ endif
+ endif
+
+ call mpi_file_close( file, ierr )
+ call mpi_comm_free( comm, ierr )
+ call mpi_file_delete( "testfile.txt", MPI_INFO_NULL, ierr )
+!
+! Check error strings while here here...
+ call mpi_error_string( newerrclass, errstring, rlen, ierr )
+ if (errstring(1:rlen) .ne. "New Class") then
+ errs = errs + 1
+ print *, ' Wrong string for error class: ', errstring(1:rlen)
+ endif
+ call mpi_error_class( code(1), eclass, ierr )
+ if (eclass .ne. newerrclass) then
+ errs = errs + 1
+ print *, ' Class for new code is not correct'
+ endif
+ call mpi_error_string( code(1), errstring, rlen, ierr )
+ if (errstring(1:rlen) .ne. "First new code") then
+ errs = errs + 1
+ print *, ' Wrong string for error code: ', errstring(1:rlen)
+ endif
+ call mpi_error_class( code(2), eclass, ierr )
+ if (eclass .ne. newerrclass) then
+ errs = errs + 1
+ print *, ' Class for new code is not correct'
+ endif
+ call mpi_error_string( code(2), errstring, rlen, ierr )
+ if (errstring(1:rlen) .ne. "Second new code") then
+ errs = errs + 1
+ print *, ' Wrong string for error code: ', errstring(1:rlen)
+ endif
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
+!
+ subroutine myerrhanfunc( file, errcode )
+ use mpi_f08
+ type(MPI_File) file
+ integer errcode
+ integer rlen, ierr
+ integer callcount, codesSeen(3)
+ character*(MPI_MAX_ERROR_STRING) errstring
+ common /myerrhan/ callcount, codesSeen
+
+ callcount = callcount + 1
+! Remember the code we've seen
+ if (callcount .le. 3) then
+ codesSeen(callcount) = errcode
+ endif
+ call mpi_error_string( errcode, errstring, rlen, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ print *, ' Panic! could not get error string'
+ call mpi_abort( MPI_COMM_WORLD, 1, ierr )
+ endif
+ end
diff --git a/test/mpi/f08/io/fileinfof90.f90 b/test/mpi/f08/io/fileinfof90.f90
new file mode 100644
index 0000000..bbb93a4
--- /dev/null
+++ b/test/mpi/f08/io/fileinfof90.f90
@@ -0,0 +1,74 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer ierr, errs
+ type(MPI_File) fh
+ type(MPI_Info) info1, info2
+ integer rank
+ logical flag
+ character*(50) filename
+ character*(MPI_MAX_INFO_KEY) mykey
+ character*(MPI_MAX_INFO_VAL) myvalue
+
+ errs = 0
+ call mtest_init( ierr )
+
+ call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+!
+! Open a simple file
+ ierr = -1
+ filename = "iotest.txt"
+ call mpi_file_open( MPI_COMM_WORLD, filename, MPI_MODE_RDWR + &
+ & MPI_MODE_CREATE, MPI_INFO_NULL, fh, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+!
+! Try to set one of the available info hints
+ call mpi_info_create( info1, ierr )
+ call mpi_info_set( info1, "access_style", &
+ & "read_once,write_once", ierr )
+ ierr = -1
+ call mpi_file_set_info( fh, info1, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+ call mpi_info_free( info1, ierr )
+
+ ierr = -1
+ call mpi_file_get_info( fh, info2, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintError( ierr )
+ endif
+ call mpi_info_get( info2, "filename", MPI_MAX_INFO_VAL, &
+ & myvalue, flag, ierr )
+!
+! An implementation isn't required to provide the filename (though
+! a high-quality implementation should)
+ if (flag) then
+! If we find it, we must have the correct name
+ if (myvalue(1:10) .ne. filename(1:10) .or. &
+ & myvalue(11:11) .ne. ' ') then
+ errs = errs + 1
+ print *, ' Returned wrong value for the filename'
+ endif
+ endif
+ call mpi_info_free( info2, ierr )
+!
+ call mpi_file_close( fh, ierr )
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ if (rank .eq. 0) then
+ call mpi_file_delete( filename, MPI_INFO_NULL, ierr )
+ endif
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
diff --git a/test/mpi/f08/io/ioharness.defn b/test/mpi/f08/io/ioharness.defn
new file mode 100644
index 0000000..ca261e5
--- /dev/null
+++ b/test/mpi/f08/io/ioharness.defn
@@ -0,0 +1,593 @@
+#
+# (C) 2004 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+# Definitions for various MPI I/O Read/write tests
+
+# If we want a separate step to check the file as written different
+# from the read step, insert it here.
+<checkfile>
+</checkfile>
+#
+# If the open fails, jump to 111
+<openfile>
+call mpi_file_open( comm, filename, MPI_MODE_RDWR + MPI_MODE_CREATE, MPI_INFO_NULL, fh, ierr )
+<checkErr/>
+if (ierr .ne. MPI_SUCCESS) then
+ goto 111
+endif
+</openfile>
+<closefile>
+call mpi_file_close( fh, ierr )
+<checkErr/>
+</closefile>
+<deletefile>
+call mpi_barrier( comm, ierr )
+call mpi_comm_rank( comm, r, ierr )
+if (r .eq. 0) then
+ call mpi_file_delete( filename, MPI_INFO_NULL, ierr )
+ <checkErr/>
+endif
+call mpi_barrier( comm, ierr )
+</deletefile>
+
+# Common code to initialize the buffer for contiguous writes
+<setContigBuffer>
+do i=1, n
+ buf(i) = r*n + (k-1)*n*s + i-1
+enddo
+</setContigBuffer>
+# This is for double buffered tests
+<setContigBuffer2>
+do i=1, n
+ buf2(i) = r*n + (k)*n*s + i-1
+enddo
+</setContigBuffer2>
+
+<checkContigBuffer>
+do i=1, n
+ ans = r*n + (k-1)*n*s + i-1
+ if (buf(i) .ne. ans) then
+ errs = errs + 1
+ if (errs .le. 10) then
+ print *, r, k, ' buf(',i,') = ', buf(i), ' expected ', ans
+ endif
+ endif
+enddo
+</checkContigBuffer>
+<clearContigBuffer>
+do i=1, n
+ buf(i) = - (r*n + (k-1)*n*s + i)
+enddo
+</clearContigBuffer>
+<checkContigBuffer2>
+do i=1, n
+ if (buf2(i) .ne. r*n + (k)*n*s + i-1) then
+ errs = errs + 1
+ if (errs .le. 10) then
+ print *, r,k,' buf2(',i,') = ', buf2(i)
+ endif
+ endif
+enddo
+</checkContigBuffer2>
+<clearContigBuffer2>
+do i=1, n
+ buf2(i) = - (r*n + (k)*n*s + i)
+enddo
+</clearContigBuffer2>
+
+# Common error check
+<checkErr>
+if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ if (errs .le. 10) then
+ call MTestPrintError( ierr )
+ endif
+endif
+</checkErr>
+
+# Common error check when MPI_ERR_IN_STATUS is a possibility
+# (status array is then statuses, of length nreq (one status per request)
+<checkErrInStatus>
+if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ if (errs .le. 10) then
+ call MTestPrintError( ierr )
+ if (ierr .eq. MPI_ERR_IN_STATUS) then
+ do i=1, nreq
+ if (statuses(i)%MPI_ERROR .ne. MPI_SUCCESS) then
+ print *, 'For statuses[', i, '], error is:'
+ call MTestPrintError(statuses(i)%MPI_ERROR)
+ endif
+ enddo
+ endif
+ endif
+endif
+</checkErrInStatus>
+
+# Common offset computation, based on the block, rank, size
+<findOffset>
+offset = (r * n + (k - 1) * n * s) * intsize
+</findOffset>
+
+# Set the view of the file for this process; suitable for
+# collective I/O and independent file I/O without seek
+<setcontigview>
+call mpi_type_vector( b, n, n*s, MPI_INTEGER, filetype, ierr )
+call mpi_type_commit( filetype, ierr )
+offset = r * n * intsize
+call mpi_file_set_view( fh, offset, MPI_INTEGER, filetype, "native", MPI_INFO_NULL, ierr )
+<checkErr/>
+call mpi_type_free( filetype, ierr )
+</setcontigview>
+
+# Some tests require that the individual processes proceed in order.
+# The following definitions initialize the src and dest, and arrange
+# to pass a token using MPI_Ssend
+# Prereqs: r and s contain rank and size, and src,dest are declared.
+# The ring is executed b times, with index variable k
+<initRing>
+src = mod( r + s - 1, s )
+dest = mod( r + 1, s )
+if (s .eq. 1) then
+ src = MPI_PROC_NULL
+ dest = MPI_PROC_NULL
+endif
+if (r .eq. s-1) then
+ call mpi_ssend( MPI_BOTTOM, 0, MPI_INTEGER, dest, 1, comm, ierr )
+endif
+</initRing>
+<waitRing>
+call mpi_recv( MPI_BOTTOM, 0, MPI_INTEGER, src, k, comm, MPI_STATUS_IGNORE, ierr )
+</waitRing>
+<nextRing>
+if (r .eq. s-1) then
+ call mpi_ssend( MPI_BOTTOM, 0, MPI_INTEGER, dest, k+1, comm, ierr )
+else
+ call mpi_ssend( MPI_BOTTOM, 0, MPI_INTEGER, dest, k, comm, ierr )
+endif
+</nextRing>
+<endRing>
+if (r .eq. 0) then
+ call mpi_recv( MPI_BOTTOM, 0, MPI_INTEGER, src, b+1, comm, MPI_STATUS_IGNORE, ierr )
+endif
+</endRing>
+#
+# ----------------------------------------------------------------------------
+# This test uses the individual file pointers.
+# To reach the correct locations, we seek to the position
+<TESTDEFN filename="writef90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b
+ <setContigBuffer/>
+ <findOffset/>
+ call mpi_file_seek( fh, offset, MPI_SEEK_SET, ierr )
+ <checkErr/>
+ call mpi_file_write( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b
+ <clearContigBuffer/>
+ <findOffset/>
+ call mpi_file_seek( fh, offset, MPI_SEEK_SET, ierr )
+ <checkErr/>
+ call mpi_file_read( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses independent I/O with thread-safe, individual file pointers
+<TESTDEFN filename="writeatf90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b
+ <setContigBuffer/>
+ <findOffset/>
+ call mpi_file_write_at( fh, offset, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b
+ <clearContigBuffer/>
+ <findOffset/>
+ call mpi_file_read_at( fh, offset, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses collective I/O with thread-safe, individual file pointers
+<TESTDEFN filename="writeatallf90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b
+ <setContigBuffer/>
+ <findOffset/>
+ call mpi_file_write_at_all( fh, offset, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b
+ <clearContigBuffer/>
+ <findOffset/>
+ call mpi_file_read_at_all( fh, offset, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses collective I/O with thread-safe, individual file pointers
+<TESTDEFN filename="writeatallbef90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b
+ <setContigBuffer/>
+ <findOffset/>
+ call mpi_file_write_at_all_begin( fh, offset, buf, n, MPI_INTEGER, ierr )
+ <checkErr/>
+ call mpi_file_write_at_all_end( fh, buf, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b
+ <clearContigBuffer/>
+ <findOffset/>
+ call mpi_file_read_at_all_begin( fh, offset, buf, n, MPI_INTEGER, ierr )
+ <checkErr/>
+ call mpi_file_read_at_all_end( fh, buf, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses nonblocking I/O with independent file pointers
+<TESTDEFN filename="iwriteatf90.f90">
+<writefiledecl>
+type(MPI_Status) statuses(2)
+integer buf(MAX_BUFFER), buf2(MAX_BUFFER), ans
+type(MPI_Request) req(2)
+integer nreq
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b ,2
+ <setContigBuffer/>
+ <findOffset/>
+ nreq = 1
+ call mpi_file_iwrite_at( fh, offset, buf, n, MPI_INTEGER, req(1), ierr )
+ <checkErr/>
+ if (k+1 .le. b) then
+ offset = offset + (s * n) * intsize
+ <setContigBuffer2/>
+ nreq = nreq + 1
+ call mpi_file_iwrite_at( fh, offset, buf2, n, MPI_INTEGER, req(2), ierr )
+ <checkErr/>
+ endif
+ call mpi_waitall( nreq, req, statuses, ierr )
+ <checkErrInStatus/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b ,2
+ <clearContigBuffer/>
+ <findOffset/>
+ nreq = 1
+ call mpi_file_iread_at( fh, offset, buf, n, MPI_INTEGER, req(1), ierr )
+ <checkErr/>
+ if (k+1 .le. b) then
+ offset = offset + (s * n) * intsize
+ <clearContigBuffer2/>
+ nreq = nreq + 1
+ call mpi_file_iread_at( fh, offset, buf2, n, MPI_INTEGER, req(2), ierr )
+ <checkErr/>
+ endif
+ call mpi_waitall( nreq, req, statuses, ierr )
+ <checkErrInStatus/>
+ <checkContigBuffer/>
+ if (nreq .eq. 2) then
+ <checkContigBuffer2/>
+ endif
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses nonblocking I/O with independent file pointers and explicit
+# seeks
+<TESTDEFN filename="iwritef90.f90">
+<writefiledecl>
+type(MPI_Status) statuses(2)
+integer buf(MAX_BUFFER), buf2(MAX_BUFFER), ans
+type(MPI_Request) req(2)
+integer nreq
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b ,2
+ <setContigBuffer/>
+ <findOffset/>
+ nreq = 1
+ call mpi_file_seek( fh, offset, MPI_SEEK_SET, ierr )
+ <checkErr/>
+ call mpi_file_iwrite( fh, buf, n, MPI_INTEGER, req(1), ierr )
+ <checkErr/>
+ if (k+1 .le. b) then
+ offset = offset + (s * n) * intsize
+ call mpi_file_seek( fh, offset, MPI_SEEK_SET, ierr )
+ <checkErr/>
+ <setContigBuffer2/>
+ nreq = nreq + 1
+ call mpi_file_iwrite( fh, buf2, n, MPI_INTEGER, req(2), ierr )
+ <checkErr/>
+ endif
+ call mpi_waitall( nreq, req, statuses, ierr )
+ <checkErrInStatus/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b ,2
+ <clearContigBuffer/>
+ <findOffset/>
+ nreq = 1
+ call mpi_file_seek( fh, offset, MPI_SEEK_SET, ierr )
+ <checkErr/>
+ call mpi_file_iread( fh, buf, n, MPI_INTEGER, req(1), ierr )
+ <checkErr/>
+ if (k+1 .le. b) then
+ offset = offset + (s * n) * intsize
+ call mpi_file_seek( fh, offset, MPI_SEEK_SET, ierr )
+ <clearContigBuffer2/>
+ nreq = nreq + 1
+ call mpi_file_iread( fh, buf2, n, MPI_INTEGER, req(2), ierr )
+ <checkErr/>
+ endif
+ call mpi_waitall( nreq, req, statuses, ierr )
+ <checkErrInStatus/>
+ <checkContigBuffer/>
+ if (nreq .eq. 2) then
+ <checkContigBuffer2/>
+ endif
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses nonblocking I/O with shared file pointers
+<TESTDEFN filename="iwriteshf90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer src, dest
+type(MPI_Request) req
+</writefiledecl>
+<writefile>
+<initRing/>
+do k=1, b
+ <waitRing/>
+ <setContigBuffer/>
+ call mpi_file_iwrite_shared( fh, buf, n, MPI_INTEGER, req, ierr )
+ <checkErr/>
+ call mpi_wait( req, status, ierr )
+ <nextRing/>
+enddo
+<endRing/>
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+<initRing/>
+do k=1, b
+ <waitRing/>
+ <clearContigBuffer/>
+ call mpi_file_iread_shared( fh, buf, n, MPI_INTEGER, req, ierr )
+ <checkErr/>
+ call mpi_wait( req, status, ierr )
+ <checkContigBuffer/>
+ <nextRing/>
+enddo
+<endRing/>
+</readfile>
+</TESTDEFN>
+
+
+# This test uses collective I/O
+<TESTDEFN filename="writeallf90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+type(MPI_Datatype) filetype
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+<setcontigview/>
+do k=1, b
+ <setContigBuffer/>
+ call mpi_file_write_all( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+<setcontigview/>
+do k=1, b
+ <clearContigBuffer/>
+ call mpi_file_read_all( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses split collective I/O
+<TESTDEFN filename="writeallbef90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+type(MPI_Datatype) filetype
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+<setcontigview/>
+do k=1, b
+ <setContigBuffer/>
+ call mpi_file_write_all_begin( fh, buf, n, MPI_INTEGER, ierr )
+ <checkErr/>
+ call mpi_file_write_all_end( fh, buf, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+<setcontigview/>
+do k=1, b
+ <clearContigBuffer/>
+ call mpi_file_read_all_begin( fh, buf, n, MPI_INTEGER, ierr )
+ <checkErr/>
+ call mpi_file_read_all_end( fh, buf, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses the shared file pointers collectively.
+<TESTDEFN filename="writeordf90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b
+ <setContigBuffer/>
+ call mpi_file_write_ordered( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b
+ <clearContigBuffer/>
+ call mpi_file_read_ordered( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses the shared file pointers with split collectives.
+<TESTDEFN filename="writeordbef90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer (kind=MPI_OFFSET_KIND)offset
+</writefiledecl>
+<writefile>
+do k=1, b
+ <setContigBuffer/>
+ call mpi_file_write_ordered_begin( fh, buf, n, MPI_INTEGER, ierr )
+ <checkErr/>
+ call mpi_file_write_ordered_end( fh, buf, status, ierr )
+ <checkErr/>
+enddo
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+do k=1, b
+ <clearContigBuffer/>
+ call mpi_file_read_ordered_begin( fh, buf, n, MPI_INTEGER, ierr )
+ <checkErr/>
+ call mpi_file_read_ordered_end( fh, buf, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+enddo
+</readfile>
+</TESTDEFN>
+
+# This test uses the shared file pointers independently.
+# We pass a token to control the oredering
+<TESTDEFN filename="writeshf90.f90">
+<writefiledecl>
+type(MPI_Status) status
+integer buf(MAX_BUFFER), ans
+integer src, dest
+</writefiledecl>
+<writefile>
+<initRing/>
+do k=1, b
+ <waitRing/>
+ <setContigBuffer/>
+ call mpi_file_write_shared( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+ <nextRing/>
+enddo
+<endRing/>
+</writefile>
+# No extra declarations are needed for the read step
+<readfiledecl>
+</readfiledecl>
+<readfile>
+<initRing/>
+do k=1, b
+ <waitRing/>
+ <clearContigBuffer/>
+ call mpi_file_read_shared( fh, buf, n, MPI_INTEGER, status, ierr )
+ <checkErr/>
+ <checkContigBuffer/>
+ <nextRing/>
+enddo
+<endRing/>
+</readfile>
+</TESTDEFN>
diff --git a/test/mpi/f08/io/ioharness.tlt b/test/mpi/f08/io/ioharness.tlt
new file mode 100644
index 0000000..1dff2d0
--- /dev/null
+++ b/test/mpi/f08/io/ioharness.tlt
@@ -0,0 +1,73 @@
+<f90header/>
+ program main
+ use mpi_f08
+ integer maxfparm
+ parameter (maxfparm=5)
+ integer max_buffer
+ parameter (max_buffer=65536)
+ integer maxftype
+ parameter (maxftype=3)
+!
+ type(MPI_Comm) comm
+ type(MPI_File) fh
+ integer ftype, itmp, fparm, n, b, i, k, r, s
+ integer intsize
+ integer errs, toterrs, err, ierr
+ integer wrank, wsize
+ integer fparms(2,maxfparm)
+ character *(100) filename
+ <writefiledecl/>
+ <readfiledecl/>
+ data fparms/1,4000, 4000,8, 4096,8, 64000,8, 65536,8 /
+
+ errs = 0
+
+ call MTest_Init( ierr )
+ call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
+ call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
+
+ call mpi_type_size( MPI_INTEGER, intsize, ierr )
+ do ftype = 1, maxftype
+ filename = "iotest.txt"
+ if (ftype .eq. 1) then
+ comm = MPI_COMM_WORLD
+ elseif (ftype .eq. 2) then
+ call mpi_comm_split( MPI_COMM_WORLD, 0, wsize - wrank, comm, ierr )
+ <checkErr/>
+ else
+ itmp = 1
+ if (wrank .eq. 0) itmp = 0
+ call mpi_comm_split( MPI_COMM_WORLD, itmp, wrank, comm, ierr )
+ <checkErr/>
+ if (wrank .eq. 0) then
+ goto 10
+ endif
+ endif
+ call mpi_comm_size( comm, s, ierr )
+ call mpi_comm_rank( comm, r, ierr )
+ do fparm=1, maxfparm
+ n = fparms(1,fparm)
+ b = fparms(2,fparm)
+! Try writing the file, then check it
+ <openfile/>
+ <writefile/>
+ <closefile/>
+ <checkfile/>
+! Now, open the same file for reading
+ <openfile/>
+ <readfile/>
+ <closefile/>
+ <deletefile/>
+ enddo
+10 continue
+!
+! Jump to 111 on a failure to open
+111 continue
+ if (comm .ne. MPI_COMM_WORLD) then
+ call mpi_comm_free( comm, ierr )
+ endif
+ enddo
+
+ call MTest_Finalize( errs )
+ call mpi_finalize( ierr )
+ end
diff --git a/test/mpi/f08/io/miscfilef90.f90 b/test/mpi/f08/io/miscfilef90.f90
new file mode 100644
index 0000000..1857ccc
--- /dev/null
+++ b/test/mpi/f08/io/miscfilef90.f90
@@ -0,0 +1,214 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+! iooffset.h provides a variable "offset" that is of type MPI_Offset
+! (in Fortran 90, kind=MPI_OFFSET_KIND)
+ integer (kind=MPI_OFFSET_KIND) offset
+
+! iodisp.h declares disp as an MPI_Offset integer
+ integer (kind=MPI_OFFSET_KIND) disp
+
+ integer rank, size
+ type(MPI_File) fh
+ type(MPI_Group) group, worldgroup
+ integer i, result
+
+ integer ierr, errs
+ integer BUFSIZE
+ parameter (BUFSIZE=1024)
+ integer buf(BUFSIZE)
+ character*(50) filename
+ character*(MPI_MAX_DATAREP_STRING) datarep
+ integer amode
+ logical atomicity
+ type(MPI_Datatype) newtype, etype, filetype
+ integer integer_size, type_size
+!
+ errs = 0
+ call mtest_init( ierr )
+ call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+ call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
+!
+! Create a file that we'll then query properties
+ filename = "testfile.txt"
+ call mpi_file_open( MPI_COMM_WORLD, filename, MPI_MODE_CREATE + &
+ & MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ print *, "Unable to create file ", filename
+ call mpi_abort( MPI_COMM_WORLD, 1, ierr )
+ endif
+!
+! Fill in some data
+ do i=1, BUFSIZE
+ buf(i) = i
+ enddo
+ call mpi_file_write( fh, buf, BUFSIZE, MPI_INTEGER, &
+ & MPI_STATUS_IGNORE, ierr )
+ call MPI_File_sync( fh, ierr )
+!
+! Now, query properties of the file and the file handle
+ call MPI_File_get_amode(fh, amode, ierr )
+ if (amode .ne. MPI_MODE_CREATE + MPI_MODE_RDWR) then
+ errs = errs + 1
+ print *, " Amode was different than expected"
+ endif
+!
+ call MPI_File_get_atomicity( fh, atomicity, ierr )
+ if (atomicity) then
+ errs = errs + 1
+ print *, " Atomicity was true but should be false"
+ endif
+!
+ call MPI_File_set_atomicity( fh, .true., ierr )
+ call MPI_File_get_atomicity( fh, atomicity, ierr )
+ if (.not. atomicity) then
+ errs = errs + 1
+ print *, " Atomicity was set to true but ", &
+ & "get_atomicity returned false"
+ endif
+ call MPI_File_set_atomicity( fh, .false., ierr )
+!
+! FIXME: original code use 10,10,20, and the following code
+! assumed the original
+!
+! Create a vector type of 10 elements, each of 20 elements, with a stride of
+! 30 elements
+ call mpi_type_vector( 10, 20, 30, MPI_INTEGER, newtype, ierr )
+ call mpi_type_commit( newtype, ierr )
+!
+! All processes are getting the same view, with a 1000 byte offset
+ offset = 1000
+ call mpi_file_set_view( fh, offset, MPI_INTEGER, newtype, "native" &
+ & , MPI_INFO_NULL, ierr )
+
+ call mpi_file_get_view( fh, offset, etype, filetype, datarep, ierr &
+ & )
+ if (offset .ne. 1000) then
+ print *, " displacement was ", offset, ", expected 1000"
+ errs = errs + 1
+ endif
+ if (datarep .ne. "native") then
+ print *, " data representation form was ", datarep, &
+ & ", expected native"
+ errs = errs + 1
+ endif
+
+! Find the byte offset, given an offset of 20 etypes relative to the
+! current view (the same as the blockcount of the filetype, which
+! places it at the beginning of the next block, hence a stride
+! distance away).
+ offset = 20
+ call mpi_file_get_byte_offset( fh, offset, disp, ierr )
+ call mpi_type_size( MPI_INTEGER, integer_size, ierr )
+ if (disp .ne. 1000 + 30 * integer_size) then
+ errs = errs + 1
+ print *, " (offset20)Byte offset = ", disp, ", should be ", &
+ & 1000+20*integer_size
+ endif
+!
+! We should also compare file and etypes. We just look at the
+! sizes and extents for now
+
+ call mpi_type_size( etype, type_size, ierr )
+ if (type_size .ne. integer_size) then
+ print *, " Etype has size ", type_size, ", but should be ", &
+ & integer_size
+ errs = errs + 1
+ endif
+ call mpi_type_size( filetype, type_size, ierr )
+ if (type_size .ne. 10*20*integer_size) then
+ print *, " filetype has size ", type_size, ", but should be ", &
+ & 10*20*integer_size
+ errs = errs + 1
+ endif
+!
+! Only free derived type
+ call mpi_type_free( filetype, ierr )
+
+ call mpi_file_get_group( fh, group, ierr )
+ call mpi_comm_group( MPI_COMM_WORLD, worldgroup, ierr )
+ call mpi_group_compare( group, worldgroup, result, ierr )
+
+ if (result .ne. MPI_IDENT) then
+ print *, " Group of file does not match group of comm_world"
+ errs = errs + 1
+ endif
+ call mpi_group_free( group, ierr )
+ call mpi_group_free( worldgroup, ierr )
+
+ offset = 1000+25*integer_size
+ call mpi_file_set_size(fh, offset, ierr )
+ call mpi_barrier(MPI_COMM_WORLD, ierr )
+ call mpi_file_sync(fh, ierr )
+ call mpi_file_get_size( fh, offset, ierr )
+
+ if (offset .ne. 1000+25*integer_size) then
+ errs = errs + 1
+ print *, " File size is ", offset, ", should be ", 1000 + 25 &
+ & * integer_size
+ endif
+!
+! File size is 1000+25ints. Seek to end. Note that the file size
+! places the end of the file into the gap in the view, so seeking
+! to the end, which is relative to the view, needs to give the end
+! of the first block of 20 ints)
+ offset = 0
+ call mpi_file_seek( fh, offset, MPI_SEEK_END, ierr )
+ call mpi_file_get_position( fh, disp, ierr )
+ if (disp .ne. 20) then
+ errs = errs + 1
+ print *, "File pointer position = ", disp, ", should be 20"
+ if (disp .eq. 25) then
+! See MPI 2.1, section 13.4, page 399, lines 7-8. The disp must be
+! relative to the current view, in the etype units of the current view
+ print *, " MPI implementation failed to position the "// &
+ & "displacement within the current file view"
+ endif
+! Make sure we use the expected position in the next step.
+ disp = 20
+ endif
+ call mpi_file_get_byte_offset(fh, disp, offset, ierr )
+ if (offset .ne. 1000+30*integer_size) then
+ errs = errs + 1
+ print *, " (seek)Byte offset = ", offset, ", should be ", 1000 &
+ & +30*integer_size
+ endif
+
+ call mpi_barrier(MPI_COMM_WORLD, ierr )
+
+ offset = -20
+ call mpi_file_seek(fh, offset, MPI_SEEK_CUR, ierr )
+ call mpi_file_get_position(fh, disp, ierr )
+ call mpi_file_get_byte_offset(fh, disp, offset, ierr )
+ if (offset .ne. 1000) then
+ errs = errs + 1
+ print *, " File pointer position in bytes = ", offset, &
+ & ", should be 1000"
+ endif
+
+ offset = 8192
+ call mpi_file_preallocate(fh, offset, ierr )
+ offset = 0
+ call mpi_file_get_size( fh, offset, ierr )
+ if (offset .lt. 8192) then
+ errs = errs + 1
+ print *, " Size after preallocate is ", offset, &
+ & ", should be at least 8192"
+ endif
+ call mpi_file_close( fh, ierr )
+
+ call mpi_barrier(MPI_COMM_WORLD, ierr )
+
+ if (rank .eq. 0) then
+ call MPI_File_delete(filename, MPI_INFO_NULL, ierr )
+ endif
+
+ call mpi_type_free( newtype, ierr )
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+ end
diff --git a/test/mpi/f08/io/setviewcurf90.f90 b/test/mpi/f08/io/setviewcurf90.f90
new file mode 100644
index 0000000..43cede6
--- /dev/null
+++ b/test/mpi/f08/io/setviewcurf90.f90
@@ -0,0 +1,121 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer (kind=MPI_OFFSET_KIND) offset
+
+ integer errs, ierr, size, rank
+ type(MPI_File) fh
+ type(MPI_Comm) comm
+ type(MPI_Status) status
+
+ integer buf(1024)
+
+ errs = 0
+ call MTest_Init( ierr )
+
+! This test reads a header then sets the view to every "size" int,
+! using set view and current displacement. The file is first written
+! using a combination of collective and ordered writes
+
+ comm = MPI_COMM_WORLD
+ call MPI_File_open( comm, "test.ord", MPI_MODE_WRONLY + &
+ & MPI_MODE_CREATE, MPI_INFO_NULL, fh, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Open(1)", ierr )
+ endif
+ call MPI_Comm_size( comm, size, ierr )
+ call MPI_Comm_rank( comm, rank, ierr )
+ if (size .gt. 1024) then
+ if (rank .eq. 0) then
+ print *, &
+ &"This program must be run with no more than 1024 processes"
+ call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
+ endif
+ endif
+
+ buf(1) = size
+ call MPI_File_write_all( fh, buf, 1, MPI_INTEGER, status, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Write_all", ierr )
+ endif
+ call MPI_File_get_position( fh, offset, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Get_position", ierr )
+ endif
+ call MPI_File_seek_shared( fh, offset, MPI_SEEK_SET, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Seek_shared", ierr )
+ endif
+ buf(1) = rank
+ call MPI_File_write_ordered( fh, buf, 1, MPI_INTEGER, status,ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Write_ordered", ierr )
+ endif
+ call MPI_File_close( fh, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Close(1)", ierr )
+ endif
+
+! Reopen the file as sequential
+ call MPI_File_open( comm, "test.ord", MPI_MODE_RDONLY + &
+ & MPI_MODE_SEQUENTIAL + MPI_MODE_DELETE_ON_CLOSE, &
+ & MPI_INFO_NULL, fh, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Open(Read)", ierr )
+ endif
+
+ if (rank .eq. 0) then
+ call MPI_File_read_shared( fh, buf, 1, MPI_INTEGER, status, &
+ & ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Read_all", ierr )
+ endif
+ if (buf(1) .ne. size) then
+ errs = errs + 1
+ print *, "Unexpected value for the header = ", buf(1), &
+ & ", should be ", size
+ endif
+ endif
+ call MPI_Barrier( comm, ierr )
+! All processes must provide the same file view for MODE_SEQUENTIAL
+ call MPI_File_set_view( fh, MPI_DISPLACEMENT_CURRENT, MPI_INTEGER &
+ & ,MPI_INTEGER, "native", MPI_INFO_NULL, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Set_view", ierr )
+ endif
+ buf(1) = -1
+ call MPI_File_read_ordered( fh, buf, 1, MPI_INTEGER, status, ierr &
+ & )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Read_all", ierr )
+ endif
+ if (buf(1) .ne. rank) then
+ errs = errs + 1
+ print *, rank, ": buf(1) = ", buf(1)
+ endif
+
+ call MPI_File_close( fh, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MTestPrintErrorMsg( "Close(2)", ierr )
+ endif
+
+ call MTest_Finalize( errs )
+
+ call MPI_Finalize( ierr )
+ end
+
diff --git a/test/mpi/f08/io/shpositionf90.f90 b/test/mpi/f08/io/shpositionf90.f90
new file mode 100644
index 0000000..a2955b6
--- /dev/null
+++ b/test/mpi/f08/io/shpositionf90.f90
@@ -0,0 +1,75 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ type(MPI_Comm) comm
+ type(MPI_File) fh
+ integer r, s, i
+ integer fileintsize
+ integer errs, err, ierr
+ character *(100) filename
+ integer (kind=MPI_OFFSET_KIND) offset
+
+ integer (kind=MPI_ADDRESS_KIND) aint
+
+
+ errs = 0
+ call MTest_Init( ierr )
+
+ filename = "iotest.txt"
+ comm = MPI_COMM_WORLD
+ call mpi_comm_size( comm, s, ierr )
+ call mpi_comm_rank( comm, r, ierr )
+! Try writing the file, then check it
+ call mpi_file_open( comm, filename, MPI_MODE_RDWR + &
+ & MPI_MODE_CREATE, MPI_INFO_NULL, fh, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ if (errs .le. 10) then
+ call MTestPrintError( ierr )
+ endif
+ endif
+!
+! Get the size of an INTEGER in the file
+ call mpi_file_get_type_extent( fh, MPI_INTEGER, aint, ierr )
+ fileintsize = aint
+!
+! We let each process write in turn, getting the position after each
+! write
+ do i=1, s
+ if (i .eq. r + 1) then
+ call mpi_file_write_shared( fh, i, 1, MPI_INTEGER, &
+ & MPI_STATUS_IGNORE, ierr )
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ if (errs .le. 10) then
+ call MTestPrintError( ierr )
+ endif
+ endif
+ endif
+ call mpi_barrier( comm, ierr )
+ call mpi_file_get_position_shared( fh, offset, ierr )
+ if (offset .ne. fileintsize * i) then
+ errs = errs + 1
+ print *, r, ' Shared position is ', offset,' should be ', &
+ & fileintsize * i
+ endif
+ call mpi_barrier( comm, ierr )
+ enddo
+ call mpi_file_close( fh, ierr )
+ if (r .eq. 0) then
+ call mpi_file_delete( filename, MPI_INFO_NULL, ierr )
+ endif
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ if (errs .le. 10) then
+ call MTestPrintError( ierr )
+ endif
+ endif
+!
+ call MTest_Finalize( errs )
+ call mpi_finalize( ierr )
+ end
diff --git a/test/mpi/f08/io/testlist b/test/mpi/f08/io/testlist
new file mode 100644
index 0000000..46c2ef8
--- /dev/null
+++ b/test/mpi/f08/io/testlist
@@ -0,0 +1,20 @@
+iwriteatf90 4
+iwritef90 4
+iwriteshf90 4
+writef90 4
+writeatf90 4
+writeallf90 4
+writeshf90 4
+writeordf90 4
+writeatallf90 4
+writeatallbef90 4
+writeallbef90 4
+writeordbef90 4
+fileerrf90 1
+fileinfof90 3
+shpositionf90 4
+atomicityf90 8
+miscfilef90 4
+setviewcurf90 4
+c2f2ciof90 1
+c2f90multio 1
diff --git a/test/mpi/f08/misc/Makefile.am b/test/mpi/f08/misc/Makefile.am
new file mode 100644
index 0000000..053dc97
--- /dev/null
+++ b/test/mpi/f08/misc/Makefile.am
@@ -0,0 +1,14 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+noinst_PROGRAMS = sizeof2
+sizeof2_SOURCES = sizeof2.f90
+
diff --git a/test/mpi/f08/misc/sizeof2.f90 b/test/mpi/f08/misc/sizeof2.f90
new file mode 100644
index 0000000..7a1a938
--- /dev/null
+++ b/test/mpi/f08/misc/sizeof2.f90
@@ -0,0 +1,62 @@
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer ierr, errs
+ integer size1, size2
+ real a
+ real d(20)
+ double precision b
+ complex c
+
+ errs = 0
+ call mpi_init(ierr)
+ call mpi_sizeof( errs, size1, ierr )
+ call mpi_type_size( MPI_INTEGER, size2, ierr )
+ if (size1 .ne. size2) then
+ errs = errs + 1
+ print *, "integer size is ", size2, " sizeof claims ", size1
+ endif
+
+ call mpi_sizeof( a, size1, ierr )
+ call mpi_type_size( MPI_REAL, size2, ierr )
+ if (size1 .ne. size2) then
+ errs = errs + 1
+ print *, "real size is ", size2, " sizeof claims ", size1
+ endif
+
+ call mpi_sizeof( b, size1, ierr )
+ call mpi_type_size( MPI_DOUBLE_PRECISION, size2, ierr )
+ if (size1 .ne. size2) then
+ errs = errs + 1
+ print *, "double precision size is ", size2, " sizeof claims ", size1
+ endif
+
+ call mpi_sizeof( c, size1, ierr )
+ call mpi_type_size( MPI_COMPLEX, size2, ierr )
+ if (size1 .ne. size2) then
+ errs = errs + 1
+ print *, "complex size is ", size2, " sizeof claims ", size1
+ endif
+!
+! A previous version of this test called mpi_sizeof with a character variable.
+! However, the MPI 2.2 standard, p 494, line 41, defines MPI_SIZEOF only
+! for "numeric intrinsic type", so that test was removed.
+!
+ call mpi_sizeof( d, size1, ierr )
+ call mpi_type_size( MPI_REAL, size2, ierr )
+ if (size1 .ne. size2) then
+ errs = errs + 1
+ print *, "real array size is ", size2, " sizeof claims ", size1
+ endif
+
+ if (errs .gt. 0) then
+ print *, ' Found ', errs, ' errors'
+ else
+ print *, ' No Errors'
+ endif
+ call mpi_finalize(ierr)
+
+ end program main
diff --git a/test/mpi/f08/misc/testlist b/test/mpi/f08/misc/testlist
new file mode 100644
index 0000000..37ae4d2
--- /dev/null
+++ b/test/mpi/f08/misc/testlist
@@ -0,0 +1 @@
+sizeof2 1
diff --git a/test/mpi/f08/profile/Makefile.am b/test/mpi/f08/profile/Makefile.am
new file mode 100644
index 0000000..e66ceed
--- /dev/null
+++ b/test/mpi/f08/profile/Makefile.am
@@ -0,0 +1,15 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+# avoid having to write many "foo_SOURCES = foo.f90" lines
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = profile1f90
diff --git a/test/mpi/f08/profile/profile1f90.f90 b/test/mpi/f08/profile/profile1f90.f90
new file mode 100644
index 0000000..175a100
--- /dev/null
+++ b/test/mpi/f08/profile/profile1f90.f90
@@ -0,0 +1,118 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer ierr
+ integer smsg(3), rmsg(3), toterrs, wsize, wrank
+ common /myinfo/ calls, amount, rcalls, ramount
+ integer calls, amount, rcalls, ramount
+
+ toterrs = 0
+ call mpi_init( ierr )
+ call init_counts()
+ call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
+ call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
+
+ if (wrank .eq. 0) then
+ smsg(1) = 3
+ call mpi_send( smsg, 1, MPI_INT, 1, 0, MPI_COMM_WORLD, ierr )
+ else if (wrank .eq. 1) then
+ call mpi_recv( rmsg, 1, MPI_INT, 0, 0, MPI_COMM_WORLD, &
+ & MPI_STATUS_IGNORE, ierr )
+ if (rmsg(1) .ne. 3) then
+ toterrs = toterrs + 1
+ print *, "Unexpected received value ", rmsg(1)
+ endif
+ endif
+!
+! check that we used the profiling versions of the routines
+ toterrs = 0
+ if (wrank .eq. 0) then
+ if (calls.ne.1) then
+ toterrs = toterrs + 1
+ print *, "Sender calls is ", calls
+ endif
+ if (amount.ne.1) then
+ toterrs = toterrs + 1
+ print *, "Sender amount is ", amount
+ endif
+ else if (wrank .eq. 1) then
+ if (rcalls.ne.1) then
+ toterrs = toterrs + 1
+ print *, "Receiver calls is ", rcalls
+ endif
+ if (ramount.ne.1) then
+ toterrs = toterrs + 1
+ print *, "Receiver amount is ", ramount
+ endif
+ endif
+
+ call mpi_allreduce( MPI_IN_PLACE, toterrs, 1, MPI_INT, MPI_SUM, &
+ & MPI_COMM_WORLD, ierr )
+ if (wrank .eq. 0) then
+ if (toterrs .eq. 0) then
+ print *, " No Errors"
+ else
+ print *, " Found ", toterrs, " errors"
+ endif
+ endif
+!
+ call mpi_finalize( ierr )
+ end
+!
+ subroutine mpi_send_f08ts( smsg, count, dtype, dest, tag, comm, ierr )
+ use :: mpi_f08, my_noname => mpi_send_f08ts
+ type(*), dimension(..), intent(in) :: smsg
+ integer, intent(in) :: count, dest, tag
+ type(MPI_Datatype), intent(in) :: dtype
+ type(MPI_Comm), intent(in) :: comm
+ integer, optional, intent(out) :: ierr
+
+ common /myinfo/ calls, amount, rcalls, ramount
+ integer calls, amount, rcalls, ramount
+!
+ calls = calls + 1
+ amount = amount + count
+ if (present(ierr)) then
+ call pmpi_send(smsg, count, dtype, dest, tag, comm, ierr)
+ else
+ call pmpi_send(smsg, count, dtype, dest, tag, comm)
+ end if
+ end
+!
+ subroutine mpi_recv_f08ts( rmsg, count, dtype, src, tag, comm, status, ierr )
+ use :: mpi_f08, my_noname => mpi_recv_f08ts
+ type(*), dimension(..), intent(in) :: rmsg
+ integer, intent(in) :: count, src, tag
+ type(MPI_Datatype), intent(in) :: dtype
+ type(MPI_Comm), intent(in) :: comm
+ type(MPI_Status) :: status
+ integer, optional, intent(out) :: ierr
+
+ common /myinfo/ calls, amount, rcalls, ramount
+ integer calls, amount, rcalls, ramount
+ rcalls = rcalls + 1
+ ramount = ramount + 1
+ if (present(ierr)) then
+ call pmpi_recv(rmsg, count, dtype, src, tag, comm, status, ierr)
+ else
+ call pmpi_recv(rmsg, count, dtype, src, tag, comm, status)
+ end if
+ end
+!
+ subroutine init_counts()
+ common /myinfo/ calls, amount, rcalls, ramount
+ integer calls, amount, rcalls, ramount
+ calls = 0
+ amount = 0
+ rcalls = 0
+ ramount = 0
+ end
+!
+ subroutine mpi_pcontrol( ierr )
+ integer ierr
+ return
+ end
diff --git a/test/mpi/f08/profile/testlist b/test/mpi/f08/profile/testlist
new file mode 100644
index 0000000..8b2ba1e
--- /dev/null
+++ b/test/mpi/f08/profile/testlist
@@ -0,0 +1 @@
+profile1f90 2
diff --git a/test/mpi/f08/spawn/Makefile.am b/test/mpi/f08/spawn/Makefile.am
new file mode 100644
index 0000000..df0a766
--- /dev/null
+++ b/test/mpi/f08/spawn/Makefile.am
@@ -0,0 +1,23 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+# avoid having to write many "foo_SOURCES = foo.f90" lines
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = namepubf90 spawnf90 spawnargvf90 spawnmultf90 spawnmult2f90 connaccf90
+
+# add "-lU77" (or equivalent) to the link line for these tests that use getarg
+spawnargvf90_LDADD = $(LDADD) $(FC_GETARG_LIBS)
+spawnmultf90_LDADD = $(LDADD) $(FC_GETARG_LIBS)
+
+noinst_PROGRAMS += spawnargvf03 spawnmultf03
+spawnargvf03_SOURCES = spawnargvf03.f90
+spawnmultf03_SOURCES = spawnmultf03.f90
diff --git a/test/mpi/f08/spawn/connaccf90.f90 b/test/mpi/f08/spawn/connaccf90.f90
new file mode 100644
index 0000000..e858973
--- /dev/null
+++ b/test/mpi/f08/spawn/connaccf90.f90
@@ -0,0 +1,127 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer size, rank, ierr, errs, eclass
+ integer color
+ type(MPI_Comm) comm, intercomm
+ integer s1, s2
+ character*(MPI_MAX_PORT_NAME) portname
+
+ errs = 0
+ call mtest_init( ierr )
+
+ call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
+ call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+ if (size .lt. 2) then
+ print *, 'This example must have at least 2 processes'
+ call mpi_abort( MPI_COMM_WORLD, 1, ierr )
+ endif
+!
+! Part of this test is to ensure that lookups cleanly fail when
+! a name is not present. This code is used to ensure that the
+! name is not in use before the test.
+! The MPI Standard (10.4.4 Name Publishing) requires that a process that
+! has published a name unpublish it before it exits.
+! This code attempts to lookup the name that we want to use as the
+! service name for this example. If it is found (it should not be, but
+! might if an MPI program with this service name exits without unpublishing
+! the servicename, and the runtime that provides the name publishing
+! leaves the servicename in use. This block of code should not be necessary
+! in a robust MPI implementation, but should not cause problems for a correct.
+!
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ call mpi_comm_set_errhandler( MPI_COMM_WORLD, MPI_ERRORS_RETURN, &
+ & ierr )
+ call mpi_lookup_name( "fservtest", MPI_INFO_NULL, portname, ierr )
+ if (ierr .eq. MPI_SUCCESS) then
+ call mpi_unpublish_name( "fservtest", MPI_INFO_NULL, portname, &
+ & ierr )
+ endif
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+! Ignore errors from unpublish_name (such as name-not-found)
+ call mpi_comm_set_errhandler( MPI_COMM_WORLD, &
+ & MPI_ERRORS_ARE_FATAL, ierr )
+!
+! The server (accept) side is rank < size/2 and the client (connect)
+! side is rank >= size/2
+ color = 0
+ if (rank .ge. size/2) color = 1
+ call mpi_comm_split( MPI_COMM_WORLD, color, rank, comm, ierr )
+!
+ if (rank .lt. size/2) then
+! Server
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ if (rank .eq. 0) then
+ call mpi_open_port( MPI_INFO_NULL, portname, ierr )
+ call mpi_publish_name( "fservtest", MPI_INFO_NULL, &
+ & portname, ierr )
+ endif
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ call mpi_comm_accept( portname, MPI_INFO_NULL, 0, comm, &
+ & intercomm, ierr )
+
+ if (rank .eq. 0) then
+ call mpi_close_port( portname, ierr )
+ call mpi_unpublish_name( "fservtest", MPI_INFO_NULL, &
+ & portname, ierr )
+ endif
+
+ else
+! Client
+ call mpi_comm_set_errhandler( MPI_COMM_WORLD,MPI_ERRORS_RETURN, &
+ & ierr )
+ ierr = MPI_SUCCESS
+ call mpi_lookup_name( "fservtest", MPI_INFO_NULL, &
+ & portname, ierr )
+ if (ierr .eq. MPI_SUCCESS) then
+ errs = errs + 1
+ print *, 'lookup name returned a value before published'
+ else
+ call mpi_error_class( ierr, eclass, ierr )
+ if (eclass .ne. MPI_ERR_NAME) then
+ errs = errs + 1
+ print *, ' Wrong error class, is ', eclass, ' must be ', &
+ & MPI_ERR_NAME
+! See the MPI-2 Standard, 5.4.4
+ endif
+ endif
+ call mpi_comm_set_errhandler( MPI_COMM_WORLD, &
+ & MPI_ERRORS_ARE_FATAL, ierr )
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ call mpi_barrier( MPI_COMM_WORLD, ierr )
+ call mpi_lookup_name( "fservtest", MPI_INFO_NULL, &
+ & portname, ierr )
+! This should not happen (ERRORS_ARE_FATAL), but just in case...
+ if (ierr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ print *, ' Major error: errors_are_fatal set but returned'
+ print *, ' non MPI_SUCCESS value. Details:'
+ call MTestPrintErrorMsg( ' Unable to lookup fservtest port', &
+ & ierr )
+! Unable to continue without a valid port
+ call mpi_abort( MPI_COMM_WORLD, 1, ierr )
+ endif
+ call mpi_comm_connect( portname, MPI_INFO_NULL, 0, comm, &
+ & intercomm, ierr )
+ endif
+!
+! Check that this is an acceptable intercomm
+ call mpi_comm_size( intercomm, s1, ierr )
+ call mpi_comm_remote_size( intercomm, s2, ierr )
+ if (s1 + s2 .ne. size) then
+ errs = errs + 1
+ print *, ' Wrong size for intercomm = ', s1+s2
+ endif
+
+ call mpi_comm_free(comm, ierr)
+! Everyone can now abandon the new intercomm
+ call mpi_comm_disconnect( intercomm, ierr )
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+
+ end
diff --git a/test/mpi/f08/spawn/namepubf90.f90 b/test/mpi/f08/spawn/namepubf90.f90
new file mode 100644
index 0000000..83cc0cb
--- /dev/null
+++ b/test/mpi/f08/spawn/namepubf90.f90
@@ -0,0 +1,95 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer errs
+ character*(MPI_MAX_PORT_NAME) port_name
+ character*(MPI_MAX_PORT_NAME) port_name_out
+ character*(256) serv_name
+ integer merr, mclass
+ character*(MPI_MAX_ERROR_STRING) errmsg
+ integer msglen, rank
+ integer ierr
+
+ errs = 0
+ call MTest_Init( ierr )
+ call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr )
+
+! Note that according to the MPI standard, port_name must
+! have been created by MPI_Open_port. For current testing
+! purposes, we'll use a fake name. This test should eventually use
+! a valid name from Open_port
+
+ port_name = 'otherhost:122'
+ serv_name = 'MyTest'
+
+ call MPI_Comm_set_errhandler( MPI_COMM_WORLD, MPI_ERRORS_RETURN, &
+ & ierr )
+
+ if (rank .eq. 0) then
+ merr = -1
+ call MPI_Publish_name( serv_name, MPI_INFO_NULL, port_name, &
+ & merr )
+ if (merr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MPI_Error_string( merr, errmsg, msglen, ierr )
+ print *, "Error in Publish_name ", errmsg(1:msglen)
+ endif
+
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+
+ merr = -1
+ call MPI_Unpublish_name( serv_name, MPI_INFO_NULL, port_name, &
+ & merr)
+ if (merr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MPI_Error_string( merr, errmsg, msglen, ierr )
+ print *, "Error in Unpublish name ", errmsg(1:msglen)
+ endif
+ else
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+ merr = -1
+ call MPI_Lookup_name( serv_name, MPI_INFO_NULL, port_name_out, &
+ & merr)
+ if (merr .ne. MPI_SUCCESS) then
+ errs = errs + 1
+ call MPI_Error_string( merr, errmsg, msglen, ierr )
+ print *, "Error in Lookup name", errmsg(1:msglen)
+ else
+ if (port_name .ne. port_name_out) then
+ errs = errs + 1
+ print *, "Lookup name returned the wrong value (", &
+ & port_name_out, "), expected (", port_name, ")"
+ endif
+ endif
+
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+ endif
+
+ call MPI_Barrier(MPI_COMM_WORLD, ierr )
+
+ merr = -1
+ call MPI_Lookup_name( serv_name, MPI_INFO_NULL, port_name_out, &
+ & merr )
+ if (merr .eq. MPI_SUCCESS) then
+ errs = errs + 1
+ print *, "Lookup name returned name after it was unpublished"
+ else
+! Must be class MPI_ERR_NAME
+ call MPI_Error_class( merr, mclass, ierr )
+ if (mclass .ne. MPI_ERR_NAME) then
+ errs = errs + 1
+ call MPI_Error_string( merr, errmsg, msglen, ierr )
+ print *, "Lookup name returned the wrong error class &
+ & (",mclass,"), msg ", errmsg
+
+ endif
+ endif
+
+ call MTest_Finalize( errs )
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/spawn/spawnargvf03.f90 b/test/mpi/f08/spawn/spawnargvf03.f90
new file mode 100644
index 0000000..91693f4
--- /dev/null
+++ b/test/mpi/f08/spawn/spawnargvf03.f90
@@ -0,0 +1,127 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This test makes use of routines to access the command line added in
+! Fortran 2003
+!
+ program main
+! declared on the old sparc compilers
+ use mpi_f08
+ integer errs, err
+ integer rank, size, rsize, i
+ integer np
+ integer errcodes(2)
+ type(MPI_Comm) parentcomm, intercomm
+ type(MPI_Status) status
+ character*(10) inargv(6), outargv(6)
+ character*(80) argv(64)
+ integer argc
+ data inargv /"a", "b=c", "d e", "-pf", " Ss", " " /
+ data outargv /"a", "b=c", "d e", "-pf", " Ss", " " /
+ integer ierr
+ integer comm_size
+ integer can_spawn
+
+ errs = 0
+ np = 2
+
+
+ call MTest_Init( ierr )
+
+ call MTestSpawnPossible( can_spawn, errs )
+ if ( can_spawn .eq. 0 ) then
+ call MTest_Finalize( errs )
+ goto 300
+ endif
+
+ call MPI_Comm_get_parent( parentcomm, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Create 2 more processes
+ call MPI_Comm_spawn( "./spawnargvf03", inargv, np, &
+ & MPI_INFO_NULL, 0, MPI_COMM_WORLD, intercomm, errcodes, &
+ & ierr )
+ else
+ intercomm = parentcomm
+ endif
+
+! We now have a valid intercomm
+
+ call MPI_Comm_remote_size( intercomm, rsize, ierr )
+ call MPI_Comm_size( intercomm, size, ierr )
+ call MPI_Comm_rank( intercomm, rank, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Master
+ if (rsize .ne. np) then
+ errs = errs + 1
+ print *, "Did not create ", np, " processes (got &
+ & ", rsize, ")"
+ endif
+ do i=0, rsize-1
+ call MPI_Send( i, 1, MPI_INTEGER, i, 0, intercomm, ierr )
+ enddo
+! We could use intercomm reduce to get the errors from the
+! children, but we'll use a simpler loop to make sure that
+! we get valid data
+ do i=0, rsize-1
+ call MPI_Recv( err, 1, MPI_INTEGER, i, 1, intercomm, &
+ & MPI_STATUS_IGNORE, ierr )
+ errs = errs + err
+ enddo
+ else
+! Child
+! FIXME: This assumes that stdout is handled for the children
+! (the error count will still be reported to the parent)
+ argc = command_argument_count()
+ do i=1, argc
+ call get_command_argument( i, argv(i) )
+ enddo
+ if (size .ne. np) then
+ errs = errs + 1
+ print *, "(Child) Did not create ", np, " processes (got ", &
+ & size, ")"
+ endif
+
+ call MPI_Recv( i, 1, MPI_INTEGER, 0, 0, intercomm, status, ierr &
+ & )
+ if (i .ne. rank) then
+ errs = errs + 1
+ print *, "Unexpected rank on child ", rank, "(",i,")"
+ endif
+! Check the command line
+ do i=1, argc
+ if (outargv(i) .eq. " ") then
+ errs = errs + 1
+ print *, "Wrong number of arguments (", argc, ")"
+ goto 200
+ endif
+ if (argv(i) .ne. outargv(i)) then
+ errs = errs + 1
+ print *, "Found arg ", argv(i), " but expected ", &
+ & outargv(i)
+ endif
+ enddo
+ 200 continue
+ if (outargv(i) .ne. " ") then
+! We had too few args in the spawned command
+ errs = errs + 1
+ print *, "Too few arguments to spawned command"
+ endif
+! Send the errs back to the master process
+ call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
+ endif
+
+! It isn't necessary to free the intercomm, but it should not hurt
+ call MPI_Comm_free( intercomm, ierr )
+
+! Note that the MTest_Finalize get errs only over COMM_WORLD
+ if (parentcomm .eq. MPI_COMM_NULL) then
+ call MTest_Finalize( errs )
+ endif
+
+ 300 continue
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/spawn/spawnargvf90.f90 b/test/mpi/f08/spawn/spawnargvf90.f90
new file mode 100644
index 0000000..c673d48
--- /dev/null
+++ b/test/mpi/f08/spawn/spawnargvf90.f90
@@ -0,0 +1,125 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This is a special test that requires an getarg/iargc routine
+!
+ program main
+! declared on the old sparc compilers
+ use mpi_f08
+ integer errs, err
+ integer rank, size, rsize, i
+ integer np
+ integer errcodes(2)
+ type(MPI_Comm) parentcomm, intercomm
+ type(MPI_Status) status
+ character*(10) inargv(6), outargv(6)
+ character*(80) argv(64)
+ integer argc
+ data inargv /"a", "b=c", "d e", "-pf", " Ss", " " /
+ data outargv /"a", "b=c", "d e", "-pf", " Ss", " " /
+ integer ierr
+ integer can_spawn
+
+ errs = 0
+ np = 2
+
+
+ call MTest_Init( ierr )
+
+ call MTestSpawnPossible( can_spawn, errs )
+ if ( can_spawn .eq. 0 ) then
+ call MTest_Finalize( errs )
+ goto 300
+ endif
+
+ call MPI_Comm_get_parent( parentcomm, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Create 2 more processes
+ call MPI_Comm_spawn( "./spawnargvf90", inargv, np, &
+ & MPI_INFO_NULL, 0, MPI_COMM_WORLD, intercomm, errcodes, &
+ & ierr )
+ else
+ intercomm = parentcomm
+ endif
+
+! We now have a valid intercomm
+
+ call MPI_Comm_remote_size( intercomm, rsize, ierr )
+ call MPI_Comm_size( intercomm, size, ierr )
+ call MPI_Comm_rank( intercomm, rank, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Master
+ if (rsize .ne. np) then
+ errs = errs + 1
+ print *, "Did not create ", np, " processes (got &
+ & ", rsize, ")"
+ endif
+ do i=0, rsize-1
+ call MPI_Send( i, 1, MPI_INTEGER, i, 0, intercomm, ierr )
+ enddo
+! We could use intercomm reduce to get the errors from the
+! children, but we'll use a simpler loop to make sure that
+! we get valid data
+ do i=0, rsize-1
+ call MPI_Recv( err, 1, MPI_INTEGER, i, 1, intercomm, &
+ & MPI_STATUS_IGNORE, ierr )
+ errs = errs + err
+ enddo
+ else
+! Child
+! FIXME: This assumes that stdout is handled for the children
+! (the error count will still be reported to the parent)
+ argc = iargc()
+ do i=1, argc
+ call getarg( i, argv(i) )
+ enddo
+ if (size .ne. np) then
+ errs = errs + 1
+ print *, "(Child) Did not create ", np, " processes (got ", &
+ & size, ")"
+ endif
+
+ call MPI_Recv( i, 1, MPI_INTEGER, 0, 0, intercomm, status, ierr &
+ & )
+ if (i .ne. rank) then
+ errs = errs + 1
+ print *, "Unexpected rank on child ", rank, "(",i,")"
+ endif
+! Check the command line
+ do i=1, argc
+ if (outargv(i) .eq. " ") then
+ errs = errs + 1
+ print *, "Wrong number of arguments (", argc, ")"
+ goto 200
+ endif
+ if (argv(i) .ne. outargv(i)) then
+ errs = errs + 1
+ print *, "Found arg ", argv(i), " but expected ", &
+ & outargv(i)
+ endif
+ enddo
+ 200 continue
+ if (outargv(i) .ne. " ") then
+! We had too few args in the spawned command
+ errs = errs + 1
+ print *, "Too few arguments to spawned command"
+ endif
+! Send the errs back to the master process
+ call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
+ endif
+
+! It isn't necessary to free the intercomm, but it should not hurt
+ call MPI_Comm_free( intercomm, ierr )
+
+! Note that the MTest_Finalize get errs only over COMM_WORLD
+ if (parentcomm .eq. MPI_COMM_NULL) then
+ call MTest_Finalize( errs )
+ endif
+
+ 300 continue
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/spawn/spawnf90.f90 b/test/mpi/f08/spawn/spawnf90.f90
new file mode 100644
index 0000000..8897567
--- /dev/null
+++ b/test/mpi/f08/spawn/spawnf90.f90
@@ -0,0 +1,98 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+ use mpi_f08
+ integer errs, err
+ integer rank, size, rsize, i
+ integer np
+ integer errcodes(2)
+ type(MPI_Comm) parentcomm, intercomm
+ type(MPI_Status) status
+ integer ierr
+ integer can_spawn
+
+ errs = 0
+ np = 2
+
+ call MTest_Init( ierr )
+
+ call MTestSpawnPossible( can_spawn, errs )
+ if ( can_spawn .eq. 0 ) then
+ call MTest_Finalize( errs )
+ goto 300
+ endif
+
+ call MPI_Comm_get_parent( parentcomm, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Create 2 more processes
+ call MPI_Comm_spawn( "./spawnf90", MPI_ARGV_NULL, np, &
+ & MPI_INFO_NULL, 0, MPI_COMM_WORLD, intercomm, errcodes &
+ & ,ierr )
+ else
+ intercomm = parentcomm
+ endif
+
+! We now have a valid intercomm
+
+ call MPI_Comm_remote_size( intercomm, rsize, ierr )
+ call MPI_Comm_size( intercomm, size, ierr )
+ call MPI_Comm_rank( intercomm, rank, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Master
+ if (rsize .ne. np) then
+ errs = errs + 1
+ print *, "Did not create ", np, " processes (got ", rsize, &
+ & ")"
+ endif
+ if (rank .eq. 0) then
+ do i=0,rsize-1
+ call MPI_Send( i, 1, MPI_INTEGER, i, 0, intercomm, ierr &
+ & )
+ enddo
+! We could use intercomm reduce to get the errors from the
+! children, but we'll use a simpler loop to make sure that
+! we get valid data
+ do i=0, rsize-1
+ call MPI_Recv( err, 1, MPI_INTEGER, i, 1, intercomm, &
+ & MPI_STATUS_IGNORE, ierr )
+ errs = errs + err
+ enddo
+ endif
+ else
+! Child
+ if (size .ne. np) then
+ errs = errs + 1
+ print *, "(Child) Did not create ", np, " processes (got " &
+ & ,size, ")"
+ endif
+
+ call MPI_Recv( i, 1, MPI_INTEGER, 0, 0, intercomm, status, &
+ & ierr )
+
+ if (i .ne. rank) then
+ errs = errs + 1
+ print *, "Unexpected rank on child ", rank, "(",i,")"
+ endif
+
+! Send the errs back to the master process
+ call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
+ endif
+
+! It isn't necessary to free the intercomm, but it should not hurt
+ call MPI_Comm_free( intercomm, ierr )
+
+! Note that the MTest_Finalize get errs only over COMM_WORLD
+! Note also that both the parent and child will generate "No
+! Errors" if both call MTest_Finalize
+ if (parentcomm .eq. MPI_COMM_NULL) then
+ call MTest_Finalize( errs )
+ endif
+
+ 300 continue
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/spawn/spawnmult2f90.f90 b/test/mpi/f08/spawn/spawnmult2f90.f90
new file mode 100644
index 0000000..ed6982a
--- /dev/null
+++ b/test/mpi/f08/spawn/spawnmult2f90.f90
@@ -0,0 +1,134 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This tests spawn_mult by using the same executable and no command-line
+! options. The attribute MPI_APPNUM is used to determine which
+! executable is running.
+!
+ program main
+ use mpi_f08
+ integer (kind=MPI_ADDRESS_KIND) aint
+
+ integer errs, err
+ integer rank, size, rsize, wsize, i
+ integer np(2)
+ type(MPI_Info) infos(2)
+ integer errcodes(2)
+ type(MPI_Comm) parentcomm, intercomm
+ type(MPI_Status) status
+ character*(30) cmds(2)
+ integer appnum
+ logical flag
+ integer ierr
+ integer can_spawn
+
+ errs = 0
+
+ call MTest_Init( ierr )
+
+ call MTestSpawnPossible( can_spawn, errs )
+ if ( can_spawn .eq. 0 ) then
+ call MTest_Finalize( errs )
+ goto 300
+ endif
+
+ call MPI_Comm_get_parent( parentcomm, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Create 2 more processes
+ cmds(1) = "./spawnmult2f90"
+ cmds(2) = "./spawnmult2f90"
+ np(1) = 1
+ np(2) = 1
+ infos(1)= MPI_INFO_NULL
+ infos(2)= MPI_INFO_NULL
+ call MPI_Comm_spawn_multiple( 2, cmds, MPI_ARGVS_NULL, &
+ & np, infos, 0, &
+ & MPI_COMM_WORLD, intercomm, errcodes, ierr )
+ else
+ intercomm = parentcomm
+ endif
+
+! We now have a valid intercomm
+
+ call MPI_Comm_remote_size( intercomm, rsize, ierr )
+ call MPI_Comm_size( intercomm, size, ierr )
+ call MPI_Comm_rank( intercomm, rank, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Master
+ if (rsize .ne. np(1) + np(2)) then
+ errs = errs + 1
+ print *, "Did not create ", np(1)+np(2), &
+ & " processes (got ", rsize, ")"
+ endif
+! Allow a multi-process parent
+ if (rank .eq. 0) then
+ do i=0, rsize-1
+ call MPI_Send( i, 1, MPI_INTEGER, i, 0, intercomm, &
+ & ierr )
+ enddo
+! We could use intercomm reduce to get the errors from the
+! children, but we'll use a simpler loop to make sure that
+! we get valid data
+ do i=0, rsize-1
+ call MPI_Recv( err, 1, MPI_INTEGER, i, 1, intercomm, &
+ & MPI_STATUS_IGNORE, ierr )
+ errs = errs + err
+ enddo
+ endif
+ else
+! Child
+! FIXME: This assumes that stdout is handled for the children
+! (the error count will still be reported to the parent)
+ if (size .ne. 2) then
+ errs = errs + 1
+ print *, "(Child) Did not create ", 2, &
+ & " processes (got ",size, ")"
+ call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
+ if (wsize .eq. 2) then
+ errs = errs + 1
+ print *, "(Child) world size is 2 but ", &
+ & " local intercomm size is not 2"
+ endif
+ endif
+
+ call MPI_Recv( i, 1, MPI_INTEGER, 0, 0, intercomm, status, ierr &
+ & )
+ if (i .ne. rank) then
+ errs = errs + 1
+ print *, "Unexpected rank on child ", rank, "(",i,")"
+ endif
+!
+! Check for correct APPNUM
+ call mpi_comm_get_attr( MPI_COMM_WORLD, MPI_APPNUM, aint, &
+ & flag, ierr )
+! My appnum should be my rank in comm world
+ if (flag) then
+ appnum = aint
+ if (appnum .ne. rank) then
+ errs = errs + 1
+ print *, "appnum is ", appnum, " but should be ", rank
+ endif
+ else
+ errs = errs + 1
+ print *, "appnum was not set"
+ endif
+
+! Send the errs back to the master process
+ call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
+ endif
+
+! It isn't necessary to free the intercomm, but it should not hurt
+ call MPI_Comm_free( intercomm, ierr )
+
+! Note that the MTest_Finalize get errs only over COMM_WORLD
+ if (parentcomm .eq. MPI_COMM_NULL) then
+ call MTest_Finalize( errs )
+ endif
+
+ 300 continue
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/spawn/spawnmultf03.f90 b/test/mpi/f08/spawn/spawnmultf03.f90
new file mode 100644
index 0000000..98ab7be
--- /dev/null
+++ b/test/mpi/f08/spawn/spawnmultf03.f90
@@ -0,0 +1,152 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This tests spawn_mult by using the same executable but different
+! command-line options.
+!
+ program main
+! declared on the old sparc compilers
+ use mpi_f08
+ integer errs, err
+ integer rank, size, rsize, wsize, i
+ integer np(2)
+ type(MPI_Info) infos(2)
+ integer errcodes(2)
+ type(MPI_Comm) parentcomm, intercomm
+ type(MPI_Status) status
+ character*(10) inargv(2,6), outargv(2,6)
+ character*(30) cmds(2)
+ character*(80) argv(64)
+ integer argc
+ integer ierr
+ integer can_spawn
+!
+! Arguments are stored by rows, not columns in the vector.
+! We write the data in a way that looks like the transpose,
+! since Fortran stores by column
+ data inargv /"a", "-p", &
+ & "b=c", "27", &
+ & "d e", "-echo", &
+ & "-pf", " ", &
+ & "Ss", " ", &
+ & " ", " "/
+ data outargv /"a", "-p", &
+ & "b=c", "27", &
+ & "d e", "-echo", &
+ & "-pf", " ", &
+ & "Ss", " ", &
+ & " ", " "/
+
+ errs = 0
+
+ call MTest_Init( ierr )
+
+ call MTestSpawnPossible( can_spawn, errs )
+ if ( can_spawn .eq. 0 ) then
+ call MTest_Finalize( errs )
+ goto 300
+ endif
+
+ call MPI_Comm_get_parent( parentcomm, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Create 2 more processes
+ cmds(1) = "./spawnmultf03"
+ cmds(2) = "./spawnmultf03"
+ np(1) = 1
+ np(2) = 1
+ infos(1)= MPI_INFO_NULL
+ infos(2)= MPI_INFO_NULL
+ call MPI_Comm_spawn_multiple( 2, cmds, inargv, &
+ & np, infos, 0, &
+ & MPI_COMM_WORLD, intercomm, errcodes, ierr )
+ else
+ intercomm = parentcomm
+ endif
+
+! We now have a valid intercomm
+
+ call MPI_Comm_remote_size( intercomm, rsize, ierr )
+ call MPI_Comm_size( intercomm, size, ierr )
+ call MPI_Comm_rank( intercomm, rank, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Master
+ if (rsize .ne. np(1) + np(2)) then
+ errs = errs + 1
+ print *, "Did not create ", np(1)+np(2), &
+ & " processes (got ", rsize, ")"
+ endif
+ do i=0, rsize-1
+ call MPI_Send( i, 1, MPI_INTEGER, i, 0, intercomm, ierr )
+ enddo
+! We could use intercomm reduce to get the errors from the
+! children, but we'll use a simpler loop to make sure that
+! we get valid data
+ do i=0, rsize-1
+ call MPI_Recv( err, 1, MPI_INTEGER, i, 1, intercomm, &
+ & MPI_STATUS_IGNORE, ierr )
+ errs = errs + err
+ enddo
+ else
+! Child
+! FIXME: This assumes that stdout is handled for the children
+! (the error count will still be reported to the parent)
+ argc = command_argument_count()
+ do i=1, argc
+ call get_command_argument( i, argv(i) )
+ enddo
+ if (size .ne. 2) then
+ errs = errs + 1
+ print *, "(Child) Did not create ", 2, &
+ & " processes (got ",size, ")"
+ call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
+ if (wsize .eq. 2) then
+ errs = errs + 1
+ print *, "(Child) world size is 2 but ", &
+ & " local intercomm size is not 2"
+ endif
+ endif
+
+ call MPI_Recv( i, 1, MPI_INTEGER, 0, 0, intercomm, status, ierr &
+ & )
+ if (i .ne. rank) then
+ errs = errs + 1
+ print *, "Unexpected rank on child ", rank, "(",i,")"
+ endif
+! Check the command line
+ do i=1, argc
+ if (outargv(rank+1,i) .eq. " ") then
+ errs = errs + 1
+ print *, "Wrong number of arguments (", argc, ")"
+ goto 200
+ endif
+ if (argv(i) .ne. outargv(rank+1,i)) then
+ errs = errs + 1
+ print *, "Found arg ", argv(i), " but expected ", &
+ & outargv(rank+1,i)
+ endif
+ enddo
+ 200 continue
+ if (outargv(rank+1,i) .ne. " ") then
+! We had too few args in the spawned command
+ errs = errs + 1
+ print *, "Too few arguments to spawned command"
+ endif
+! Send the errs back to the master process
+ call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
+ endif
+
+! It isn't necessary to free the intercomm, but it should not hurt
+ call MPI_Comm_free( intercomm, ierr )
+
+! Note that the MTest_Finalize get errs only over COMM_WORLD
+ if (parentcomm .eq. MPI_COMM_NULL) then
+ call MTest_Finalize( errs )
+ endif
+
+ 300 continue
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/spawn/spawnmultf90.f90 b/test/mpi/f08/spawn/spawnmultf90.f90
new file mode 100644
index 0000000..e6c8b25
--- /dev/null
+++ b/test/mpi/f08/spawn/spawnmultf90.f90
@@ -0,0 +1,153 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2003 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This is a special test that requires an getarg/iargc routine
+! This tests spawn_mult by using the same executable but different
+! command-line options.
+!
+ program main
+! declared on the old sparc compilers
+ use mpi_f08
+ integer errs, err
+ integer rank, size, rsize, wsize, i
+ integer np(2)
+ type(MPI_Info) infos(2)
+ integer errcodes(2)
+ type(MPI_Comm) parentcomm, intercomm
+ type(MPI_Status) status
+ character*(10) inargv(2,6), outargv(2,6)
+ character*(30) cmds(2)
+ character*(80) argv(64)
+ integer argc
+ integer ierr
+ integer can_spawn
+!
+! Arguments are stored by rows, not columns in the vector.
+! We write the data in a way that looks like the transpose,
+! since Fortran stores by column
+ data inargv /"a", "-p", &
+ & "b=c", "27", &
+ & "d e", "-echo", &
+ & "-pf", " ", &
+ & "Ss", " ", &
+ & " ", " "/
+ data outargv /"a", "-p", &
+ & "b=c", "27", &
+ & "d e", "-echo", &
+ & "-pf", " ", &
+ & "Ss", " ", &
+ & " ", " "/
+
+ errs = 0
+
+ call MTest_Init( ierr )
+
+ call MTestSpawnPossible( can_spawn, errs )
+ if ( can_spawn .eq. 0 ) then
+ call MTest_Finalize( errs )
+ goto 300
+ endif
+
+ call MPI_Comm_get_parent( parentcomm, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Create 2 more processes
+ cmds(1) = "./spawnmultf90"
+ cmds(2) = "./spawnmultf90"
+ np(1) = 1
+ np(2) = 1
+ infos(1)= MPI_INFO_NULL
+ infos(2)= MPI_INFO_NULL
+ call MPI_Comm_spawn_multiple( 2, cmds, inargv, &
+ & np, infos, 0, &
+ & MPI_COMM_WORLD, intercomm, errcodes, ierr )
+ else
+ intercomm = parentcomm
+ endif
+
+! We now have a valid intercomm
+
+ call MPI_Comm_remote_size( intercomm, rsize, ierr )
+ call MPI_Comm_size( intercomm, size, ierr )
+ call MPI_Comm_rank( intercomm, rank, ierr )
+
+ if (parentcomm .eq. MPI_COMM_NULL) then
+! Master
+ if (rsize .ne. np(1) + np(2)) then
+ errs = errs + 1
+ print *, "Did not create ", np(1)+np(2), &
+ & " processes (got ", rsize, ")"
+ endif
+ do i=0, rsize-1
+ call MPI_Send( i, 1, MPI_INTEGER, i, 0, intercomm, ierr )
+ enddo
+! We could use intercomm reduce to get the errors from the
+! children, but we'll use a simpler loop to make sure that
+! we get valid data
+ do i=0, rsize-1
+ call MPI_Recv( err, 1, MPI_INTEGER, i, 1, intercomm, &
+ & MPI_STATUS_IGNORE, ierr )
+ errs = errs + err
+ enddo
+ else
+! Child
+! FIXME: This assumes that stdout is handled for the children
+! (the error count will still be reported to the parent)
+ argc = iargc()
+ do i=1, argc
+ call getarg( i, argv(i) )
+ enddo
+ if (size .ne. 2) then
+ errs = errs + 1
+ print *, "(Child) Did not create ", 2, &
+ & " processes (got ",size, ")"
+ call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
+ if (wsize .eq. 2) then
+ errs = errs + 1
+ print *, "(Child) world size is 2 but ", &
+ & " local intercomm size is not 2"
+ endif
+ endif
+
+ call MPI_Recv( i, 1, MPI_INTEGER, 0, 0, intercomm, status, ierr &
+ & )
+ if (i .ne. rank) then
+ errs = errs + 1
+ print *, "Unexpected rank on child ", rank, "(",i,")"
+ endif
+! Check the command line
+ do i=1, argc
+ if (outargv(rank+1,i) .eq. " ") then
+ errs = errs + 1
+ print *, "Wrong number of arguments (", argc, ")"
+ goto 200
+ endif
+ if (argv(i) .ne. outargv(rank+1,i)) then
+ errs = errs + 1
+ print *, "Found arg ", argv(i), " but expected ", &
+ & outargv(rank+1,i)
+ endif
+ enddo
+ 200 continue
+ if (outargv(rank+1,i) .ne. " ") then
+! We had too few args in the spawned command
+ errs = errs + 1
+ print *, "Too few arguments to spawned command"
+ endif
+! Send the errs back to the master process
+ call MPI_Ssend( errs, 1, MPI_INTEGER, 0, 1, intercomm, ierr )
+ endif
+
+! It isn't necessary to free the intercomm, but it should not hurt
+ call MPI_Comm_free( intercomm, ierr )
+
+! Note that the MTest_Finalize get errs only over COMM_WORLD
+ if (parentcomm .eq. MPI_COMM_NULL) then
+ call MTest_Finalize( errs )
+ endif
+
+ 300 continue
+ call MPI_Finalize( ierr )
+ end
diff --git a/test/mpi/f08/spawn/testlist b/test/mpi/f08/spawn/testlist
new file mode 100644
index 0000000..6bc64d0
--- /dev/null
+++ b/test/mpi/f08/spawn/testlist
@@ -0,0 +1,8 @@
+namepubf90 2
+spawnf90 1
+spawnargvf90 1
+connaccf90 2
+spawnmultf90 1
+spawnmult2f90 2
+spawnargvf03 1
+spawnmultf03 1
diff --git a/test/mpi/f08/testlist b/test/mpi/f08/testlist
index 60a20c0..0c0f42c 100644
--- a/test/mpi/f08/testlist
+++ b/test/mpi/f08/testlist
@@ -7,3 +7,12 @@ datatype
comm
rma
subarray
+topo
+ext
+info
+init
+io
+misc
+spawn
+timer
+profile
diff --git a/test/mpi/f08/timer/Makefile.am b/test/mpi/f08/timer/Makefile.am
new file mode 100644
index 0000000..9ec61ab
--- /dev/null
+++ b/test/mpi/f08/timer/Makefile.am
@@ -0,0 +1,14 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = wtimef90
diff --git a/test/mpi/f08/timer/testlist b/test/mpi/f08/timer/testlist
new file mode 100644
index 0000000..6c27661
--- /dev/null
+++ b/test/mpi/f08/timer/testlist
@@ -0,0 +1 @@
+wtimef90 1
diff --git a/test/mpi/f08/timer/wtimef90.f90 b/test/mpi/f08/timer/wtimef90.f90
new file mode 100644
index 0000000..a372078
--- /dev/null
+++ b/test/mpi/f08/timer/wtimef90.f90
@@ -0,0 +1,32 @@
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+ program main
+! This is a simple test to check that both the MPI and PMPI versions of the
+! timers are available, and that they return double precision values.
+! If this code links, there are no problems.
+!
+ use mpi_f08
+ implicit none
+ integer err
+ double precision time1
+
+ call mpi_init(err)
+
+ time1 = mpi_wtime()
+ time1 = time1 + mpi_wtick()
+ time1 = time1 + pmpi_wtime()
+ time1 = time1 + pmpi_wtick()
+! Add a test on time1 to ensure that the compiler does not remove the calls
+! (The compiler should call them anyway because they aren't pure, but
+! including these operations ensures that a buggy compiler doesn't
+! pass this test by mistake).
+ if (time1 .lt. 0.0d0) then
+ print *, ' Negative time result'
+ else
+ print *, ' No Errors'
+ endif
+
+ call mpi_finalize(err)
+ end
diff --git a/test/mpi/f08/topo/Makefile.am b/test/mpi/f08/topo/Makefile.am
new file mode 100644
index 0000000..78dce0a
--- /dev/null
+++ b/test/mpi/f08/topo/Makefile.am
@@ -0,0 +1,14 @@
+# -*- Mode: Makefile; -*-
+# vim: set ft=automake :
+#
+# (C) 2014 by Argonne National Laboratory.
+# See COPYRIGHT in top-level directory.
+#
+
+include $(top_srcdir)/Makefile_f08.mtest
+
+EXTRA_DIST = testlist
+
+AM_DEFAULT_SOURCE_EXT = .f90
+
+noinst_PROGRAMS = cartcrf90 dgraph_wgtf90 dgraph_unwgtf90
diff --git a/test/mpi/f08/topo/cartcrf90.f90 b/test/mpi/f08/topo/cartcrf90.f90
new file mode 100644
index 0000000..6ab50a9
--- /dev/null
+++ b/test/mpi/f08/topo/cartcrf90.f90
@@ -0,0 +1,102 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! Test various combinations of periodic and non-periodic Cartesian
+! communicators
+!
+ program main
+ use mpi_f08
+ integer errs, ierr
+ integer ndims, nperiods, i, size
+ integer source, dest
+ type(mpi_comm) comm, newcomm
+ integer maxdims
+ parameter (maxdims=7)
+ logical periods(maxdims), outperiods(maxdims)
+ integer dims(maxdims), outdims(maxdims)
+ integer outcoords(maxdims)
+
+ errs = 0
+ call mtest_init( ierr )
+
+!
+! For upto 6 dimensions, test with periodicity in 0 through all
+! dimensions. The test is computed by both:
+! get info about the created communicator
+! apply cart shift
+! Note that a dimension can have size one, so that these tests
+! can work with small numbers (even 1) of processes
+!
+ comm = MPI_COMM_WORLD
+ call mpi_comm_size( comm, size, ierr )
+ do ndims = 1, 6
+ do nperiods = 0, ndims
+ do i=1,ndims
+ periods(i) = .false.
+ dims(i) = 0
+ enddo
+ do i=1,nperiods
+ periods(i) = .true.
+ enddo
+
+ call mpi_dims_create( size, ndims, dims, ierr )
+ call mpi_cart_create( comm, ndims, dims, periods, .false., &
+ & newcomm, ierr )
+
+ if (newcomm .ne. MPI_COMM_NULL) then
+ call mpi_cart_get( newcomm, maxdims, outdims, outperiods, &
+ & outcoords, ierr )
+! print *, 'Coords = '
+ do i=1, ndims
+! print *, i, '(', outcoords(i), ')'
+ if (periods(i) .neqv. outperiods(i)) then
+ errs = errs + 1
+ print *, ' Wrong value for periods ', i
+ print *, ' ndims = ', ndims
+ endif
+ enddo
+
+ do i=1, ndims
+ call mpi_cart_shift( newcomm, i-1, 1, source, dest, &
+ & ierr )
+ if (outcoords(i) .eq. outdims(i)-1) then
+ if (periods(i)) then
+ if (dest .eq. MPI_PROC_NULL) then
+ errs = errs + 1
+ print *, 'Expected rank, got proc_null'
+ endif
+ else
+ if (dest .ne. MPI_PROC_NULL) then
+ errs = errs + 1
+ print *, 'Expected procnull, got ', dest
+ endif
+ endif
+ endif
+
+ call mpi_cart_shift( newcomm, i-1, -1, source, dest, &
+ & ierr )
+ if (outcoords(i) .eq. 0) then
+ if (periods(i)) then
+ if (dest .eq. MPI_PROC_NULL) then
+ errs = errs + 1
+ print *, 'Expected rank, got proc_null'
+ endif
+ else
+ if (dest .ne. MPI_PROC_NULL) then
+ errs = errs + 1
+ print *, 'Expected procnull, got ', dest
+ endif
+ endif
+ endif
+ enddo
+ call mpi_comm_free( newcomm, ierr )
+ endif
+
+ enddo
+ enddo
+
+ call mtest_finalize( errs )
+ call mpi_finalize( ierr )
+ end
diff --git a/test/mpi/f08/topo/dgraph_unwgtf90.f90 b/test/mpi/f08/topo/dgraph_unwgtf90.f90
new file mode 100644
index 0000000..3298873
--- /dev/null
+++ b/test/mpi/f08/topo/dgraph_unwgtf90.f90
@@ -0,0 +1,213 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This program is Fortran version of dgraph_unwgt.c
+! Specify a distributed graph of a bidirectional ring of the MPI_COMM_WORLD,
+! i.e. everyone only talks to left and right neighbors.
+
+ logical function validate_dgraph(dgraph_comm)
+ use mpi_f08
+
+ type(MPI_Comm) dgraph_comm
+ integer comm_topo
+ integer src_sz, dest_sz
+ integer ierr;
+ logical wgt_flag;
+ integer srcs(2), dests(2)
+
+ integer world_rank, world_size;
+ integer idx, nbr_sep
+
+ comm_topo = MPI_UNDEFINED
+ call MPI_Topo_test(dgraph_comm, comm_topo, ierr);
+ if (comm_topo .ne. MPI_DIST_GRAPH) then
+ validate_dgraph = .false.
+ write(6,*) "dgraph_comm is NOT of type MPI_DIST_GRAPH."
+ return
+ endif
+
+ call MPI_Dist_graph_neighbors_count(dgraph_comm, &
+ & src_sz, dest_sz, wgt_flag, &
+ & ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ validate_dgraph = .false.
+ write(6,*) "MPI_Dist_graph_neighbors_count() fails!"
+ return
+ endif
+ if (wgt_flag) then
+ validate_dgraph = .false.
+ write(6,*) "dgraph_comm is NOT created with MPI_UNWEIGHTED."
+ return
+ endif
+
+ if (src_sz .ne. 2 .or. dest_sz .ne. 2) then
+ validate_dgraph = .false.
+ write(6,*) "source or destination edge array is not size 2."
+ write(6,"('src_sz = ',I3,', dest_sz = ',I3)") src_sz, dest_sz
+ return
+ endif
+
+ call MPI_Dist_graph_neighbors(dgraph_comm, &
+ & src_sz, srcs, MPI_UNWEIGHTED, &
+ & dest_sz, dests, MPI_UNWEIGHTED, &
+ & ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ validate_dgraph = .false.
+ write(6,*) "MPI_Dist_graph_neighbors() fails!"
+ return
+ endif
+
+! Check if the neighbors returned from MPI are really
+! the nearest neighbors that within a ring.
+ call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
+ call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
+
+ do idx = 1, src_sz
+ nbr_sep = iabs(srcs(idx) - world_rank)
+ if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then
+ validate_dgraph = .false.
+ write(6,"('srcs[',I3,']=',I3, &
+ & ' is NOT a neighbor of my rank',I3)") &
+ & idx, srcs(idx), world_rank
+ return
+ endif
+ enddo
+ do idx = 1, dest_sz
+ nbr_sep = iabs(dests(idx) - world_rank)
+ if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then
+ validate_dgraph = .false.
+ write(6,"('dests[',I3,']=',I3, &
+ & ' is NOT a neighbor of my rank',I3)") &
+ & idx, dests(idx), world_rank
+ return
+ endif
+ enddo
+
+ validate_dgraph = .true.
+ return
+ end
+
+ integer function ring_rank(world_size, in_rank)
+ integer world_size, in_rank
+ if (in_rank .ge. 0 .and. in_rank .lt. world_size) then
+ ring_rank = in_rank
+ return
+ endif
+ if (in_rank .lt. 0 ) then
+ ring_rank = in_rank + world_size
+ return
+ endif
+ if (in_rank .ge. world_size) then
+ ring_rank = in_rank - world_size
+ return
+ endif
+ ring_rank = -99999
+ return
+ end
+
+
+
+ program dgraph_unwgt
+ use mpi_f08
+
+ integer ring_rank
+ external ring_rank
+ logical validate_dgraph
+ external validate_dgraph
+ integer errs, ierr
+
+ type(MPI_Comm) dgraph_comm
+ integer world_size, world_rank
+ integer src_sz, dest_sz
+ integer degs(1)
+ integer srcs(2), dests(2)
+
+ errs = 0
+ call MTEST_Init(ierr)
+ call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
+ call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
+
+ srcs(1) = world_rank
+ degs(1) = 2;
+ dests(1) = ring_rank(world_size, world_rank-1)
+ dests(2) = ring_rank(world_size, world_rank+1)
+ call MPI_Dist_graph_create(MPI_COMM_WORLD, 1, srcs, degs, dests, &
+ & MPI_UNWEIGHTED, MPI_INFO_NULL, &
+ & .true., dgraph_comm, ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ write(6,*) "MPI_Dist_graph_create() fails!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ if (.not. validate_dgraph(dgraph_comm)) then
+ write(6,*) "MPI_Dist_graph_create() does not create" &
+ & //"a bidirectional ring graph!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ call MPI_Comm_free(dgraph_comm, ierr)
+
+! now create one with MPI_WEIGHTS_EMPTY
+! NOTE that MPI_WEIGHTS_EMPTY was added in MPI-3 and does not
+! appear before then. Incluing this test means that this test cannot
+! be compiled if the MPI version is less than 3 (see the testlist file)
+
+ degs(1) = 0;
+ call MPI_Dist_graph_create(MPI_COMM_WORLD, 1, srcs, degs, dests, &
+ & MPI_WEIGHTS_EMPTY, MPI_INFO_NULL, &
+ & .true., dgraph_comm, ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ write(6,*) "MPI_Dist_graph_create() fails!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ call MPI_Comm_free(dgraph_comm, ierr)
+
+ src_sz = 2
+ srcs(1) = ring_rank(world_size, world_rank-1)
+ srcs(2) = ring_rank(world_size, world_rank+1)
+ dest_sz = 2
+ dests(1) = ring_rank(world_size, world_rank-1)
+ dests(2) = ring_rank(world_size, world_rank+1)
+ call MPI_Dist_graph_create_adjacent(MPI_COMM_WORLD, &
+ & src_sz, srcs, &
+ & MPI_UNWEIGHTED, &
+ & dest_sz, dests, &
+ & MPI_UNWEIGHTED, &
+ & MPI_INFO_NULL, .true., &
+ & dgraph_comm, ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ write(6,*) "MPI_Dist_graph_create_adjacent() fails!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ if (.not. validate_dgraph(dgraph_comm)) then
+ write(6,*) "MPI_Dist_graph_create_adjacent() does not create" &
+ & //"a bidirectional ring graph!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ call MPI_Comm_free(dgraph_comm, ierr)
+
+! now create one with MPI_WEIGHTS_EMPTY
+ src_sz = 0
+ dest_sz = 0
+ call MPI_Dist_graph_create_adjacent(MPI_COMM_WORLD, &
+ & src_sz, srcs, &
+ & MPI_WEIGHTS_EMPTY, &
+ & dest_sz, dests, &
+ & MPI_WEIGHTS_EMPTY, &
+ & MPI_INFO_NULL, .true., &
+ & dgraph_comm, ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ write(6,*) "MPI_Dist_graph_create_adjacent() fails!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ call MPI_Comm_free(dgraph_comm, ierr)
+
+ call MTEST_Finalize(errs)
+ call MPI_Finalize(ierr)
+ end
diff --git a/test/mpi/f08/topo/dgraph_wgtf90.f90 b/test/mpi/f08/topo/dgraph_wgtf90.f90
new file mode 100644
index 0000000..0ee67de
--- /dev/null
+++ b/test/mpi/f08/topo/dgraph_wgtf90.f90
@@ -0,0 +1,198 @@
+! -*- Mode: Fortran; -*-
+!
+! (C) 2014 by Argonne National Laboratory.
+! See COPYRIGHT in top-level directory.
+!
+! This program is Fortran version of dgraph_unwgt.c
+! Specify a distributed graph of a bidirectional ring of the MPI_COMM_WORLD,
+! i.e. everyone only talks to left and right neighbors.
+
+ logical function validate_dgraph(dgraph_comm)
+ use mpi_f08
+
+ type(MPI_Comm) dgraph_comm
+ integer comm_topo
+ integer src_sz, dest_sz
+ integer ierr;
+ logical wgt_flag;
+ integer srcs(2), dests(2)
+ integer src_wgts(2), dest_wgts(2)
+
+ integer world_rank, world_size;
+ integer idx, nbr_sep
+
+ comm_topo = MPI_UNDEFINED
+ call MPI_Topo_test(dgraph_comm, comm_topo, ierr);
+ if (comm_topo .ne. MPI_DIST_GRAPH) then
+ validate_dgraph = .false.
+ write(6,*) "dgraph_comm is NOT of type MPI_DIST_GRAPH."
+ return
+ endif
+
+ call MPI_Dist_graph_neighbors_count(dgraph_comm, &
+ & src_sz, dest_sz, wgt_flag, &
+ & ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ validate_dgraph = .false.
+ write(6,*) "MPI_Dist_graph_neighbors_count() fails!"
+ return
+ endif
+ if (.not. wgt_flag) then
+ validate_dgraph = .false.
+ write(6,*) "dgraph_comm is created with MPI_UNWEIGHTED!"
+ return
+ endif
+
+ if (src_sz .ne. 2 .or. dest_sz .ne. 2) then
+ validate_dgraph = .false.
+ write(6,*) "source or destination edge array is not size 2."
+ write(6,"('src_sz = ',I3,', dest_sz = ',I3)") src_sz, dest_sz
+ return
+ endif
+
+ call MPI_Dist_graph_neighbors(dgraph_comm, &
+ & src_sz, srcs, src_wgts, &
+ & dest_sz, dests, dest_wgts, &
+ & ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ validate_dgraph = .false.
+ write(6,*) "MPI_Dist_graph_neighbors() fails!"
+ return
+ endif
+
+! Check if the neighbors returned from MPI are really
+! the nearest neighbors that within a ring.
+ call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
+ call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
+
+ do idx = 1, src_sz
+ nbr_sep = iabs(srcs(idx) - world_rank)
+ if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then
+ validate_dgraph = .false.
+ write(6,"('srcs[',I3,']=',I3, &
+ & ' is NOT a neighbor of my rank',I3)") &
+ & idx, srcs(idx), world_rank
+ return
+ endif
+ enddo
+ if (src_wgts(1) .ne. src_wgts(2)) then
+ validate_dgraph = .false.
+ write(6,"('src_wgts = [',I3,',',I3,']')") &
+ & src_wgts(1), src_wgts(2)
+ return
+ endif
+ do idx = 1, dest_sz
+ nbr_sep = iabs(dests(idx) - world_rank)
+ if (nbr_sep .ne. 1 .and. nbr_sep .ne. (world_size-1)) then
+ validate_dgraph = .false.
+ write(6,"('dests[',I3,']=',I3, &
+ & ' is NOT a neighbor of my rank',I3)") &
+ & idx, dests(idx), world_rank
+ return
+ endif
+ enddo
+ if (dest_wgts(1) .ne. dest_wgts(2)) then
+ validate_dgraph = .false.
+ write(6,"('dest_wgts = [',I3,',',I3,']')") &
+ & dest_wgts(1), dest_wgts(2)
+ return
+ endif
+
+ validate_dgraph = .true.
+ return
+ end
+
+ integer function ring_rank(world_size, in_rank)
+ integer world_size, in_rank
+ if (in_rank .ge. 0 .and. in_rank .lt. world_size) then
+ ring_rank = in_rank
+ return
+ endif
+ if (in_rank .lt. 0 ) then
+ ring_rank = in_rank + world_size
+ return
+ endif
+ if (in_rank .ge. world_size) then
+ ring_rank = in_rank - world_size
+ return
+ endif
+ ring_rank = -99999
+ return
+ end
+
+
+
+ program dgraph_unwgt
+ use mpi_f08
+
+ integer ring_rank
+ external ring_rank
+ logical validate_dgraph
+ external validate_dgraph
+ integer errs, ierr
+
+ type(MPI_Comm) dgraph_comm
+ integer world_size, world_rank
+ integer src_sz, dest_sz
+ integer degs(1)
+ integer srcs(2), dests(2)
+ integer src_wgts(2), dest_wgts(2)
+
+ errs = 0
+ call MTEST_Init(ierr)
+ call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
+ call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
+
+ srcs(1) = world_rank
+ degs(1) = 2;
+ dests(1) = ring_rank(world_size, world_rank-1)
+ dests(2) = ring_rank(world_size, world_rank+1)
+ dest_wgts(1) = 1
+ dest_wgts(2) = 1
+ call MPI_Dist_graph_create(MPI_COMM_WORLD, 1, srcs, degs, dests, &
+ & dest_wgts, MPI_INFO_NULL, &
+ & .true., dgraph_comm, ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ write(6,*) "MPI_Dist_graph_create() fails!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ if (.not. validate_dgraph(dgraph_comm)) then
+ write(6,*) "MPI_Dist_graph_create() does not create " &
+ & //"a bidirectional ring graph!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ call MPI_Comm_free(dgraph_comm, ierr)
+
+ src_sz = 2
+ srcs(1) = ring_rank(world_size, world_rank-1)
+ srcs(2) = ring_rank(world_size, world_rank+1)
+ src_wgts(1) = 1
+ src_wgts(2) = 1
+ dest_sz = 2
+ dests(1) = ring_rank(world_size, world_rank-1)
+ dests(2) = ring_rank(world_size, world_rank+1)
+ dest_wgts(1) = 1
+ dest_wgts(2) = 1
+ call MPI_Dist_graph_create_adjacent(MPI_COMM_WORLD, &
+ & src_sz, srcs, src_wgts, &
+ & dest_sz, dests, dest_wgts, &
+ & MPI_INFO_NULL, .true., &
+ & dgraph_comm, ierr)
+ if (ierr .ne. MPI_SUCCESS) then
+ write(6,*) "MPI_Dist_graph_create_adjacent() fails!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ if (.not. validate_dgraph(dgraph_comm)) then
+ write(6,*) "MPI_Dist_graph_create_adjacent() does not create " &
+ & //"a bidirectional ring graph!"
+ call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
+ stop
+ endif
+ call MPI_Comm_free(dgraph_comm, ierr)
+
+ call MTEST_Finalize(errs)
+ call MPI_Finalize(ierr)
+ end
diff --git a/test/mpi/f08/topo/testlist b/test/mpi/f08/topo/testlist
new file mode 100644
index 0000000..9836414
--- /dev/null
+++ b/test/mpi/f08/topo/testlist
@@ -0,0 +1,3 @@
+cartcrf90 4
+dgraph_wgtf90 4
+dgraph_unwgtf90 4
diff --git a/test/mpi/f08/util/mtestf08.f90 b/test/mpi/f08/util/mtestf08.f90
index 9026e1a..35858bc 100644
--- a/test/mpi/f08/util/mtestf08.f90
+++ b/test/mpi/f08/util/mtestf08.f90
@@ -104,3 +104,43 @@
print *, msg, ": Error class ", errclass, " &
& (", string(1:slen), ")"
end
+
+ subroutine MTestSpawnPossible( can_spawn, errs )
+ use mpi
+ integer can_spawn
+ integer errs
+ integer(kind=MPI_ADDRESS_KIND) val
+ integer ierror
+ logical flag
+ integer comm_size
+
+ call mpi_comm_get_attr( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, val, &
+ & flag, ierror )
+ if ( ierror .ne. MPI_SUCCESS ) then
+! MPI_UNIVERSE_SIZE keyval missing from MPI_COMM_WORLD attributes
+ can_spawn = -1
+ errs = errs + 1
+ else
+ if ( flag ) then
+ comm_size = -1
+
+ call mpi_comm_size( MPI_COMM_WORLD, comm_size, ierror )
+ if ( ierror .ne. MPI_SUCCESS ) then
+! MPI_COMM_SIZE failed for MPI_COMM_WORLD
+ can_spawn = -1
+ errs = errs + 1
+ return
+ endif
+
+ if ( val .le. comm_size ) then
+! no additional processes can be spawned
+ can_spawn = 0
+ else
+ can_spawn = 1
+ endif
+ else
+! No attribute associated with key MPI_UNIVERSE_SIZE of MPI_COMM_WORLD
+ can_spawn = -1
+ endif
+ endif
+ end
-----------------------------------------------------------------------
Summary of changes:
.../fortran/use_mpi_f08/mpi_c_interface_glue.F90 | 23 +-
.../fortran/use_mpi_f08/mpi_c_interface_nobuf.F90 | 8 +-
.../fortran/use_mpi_f08/wrappers_c/buildiface | 2 +-
.../fortran/use_mpi_f08/wrappers_c/comm_spawn_c.c | 3 +-
.../use_mpi_f08/wrappers_c/comm_spawn_multiple_c.c | 81 +++-
.../use_mpi_f08/wrappers_f/info_get_f08ts.F90 | 7 +-
.../wrappers_f/info_get_nthkey_f08ts.F90 | 2 +-
.../wrappers_f/info_get_valuelen_f08ts.F90 | 5 +-
test/mpi/configure.ac | 28 +-
test/mpi/f08/Makefile.am | 17 -
test/mpi/f08/ext/Makefile.am | 42 ++
test/mpi/f08/ext/allocmemf90.f90 | 36 ++
test/mpi/f08/ext/c2f2cf90.f90 | 131 +++++
test/mpi/f08/ext/c2f90mult.c | 61 ++
test/mpi/f08/ext/ctypesinf90.f90 | 49 ++
test/mpi/f08/ext/testlist | 4 +
test/mpi/f08/info/Makefile.am | 15 +
test/mpi/f08/info/infotest2f90.f90 | 140 +++++
test/mpi/f08/info/infotestf90.f90 | 56 ++
test/mpi/f08/info/testlist | 2 +
test/mpi/f08/init/Makefile.am | 25 +
test/mpi/f08/init/baseenvf90.f90 | 89 +++
test/mpi/f08/init/testlist | 1 +
test/mpi/f08/io/Makefile.am | 130 +++++
test/mpi/f08/io/atomicityf90.f90 | 201 +++++++
test/mpi/f08/io/c2f2ciof90.f90 | 62 ++
test/mpi/f08/io/c2f902cio.c | 97 ++++
test/mpi/f08/io/c2f90multio.c | 59 ++
test/mpi/f08/io/fileerrf90.f90 | 157 ++++++
test/mpi/f08/io/fileinfof90.f90 | 74 +++
test/mpi/f08/io/ioharness.defn | 593 ++++++++++++++++++++
test/mpi/f08/io/ioharness.tlt | 73 +++
test/mpi/f08/io/miscfilef90.f90 | 214 +++++++
test/mpi/f08/io/setviewcurf90.f90 | 121 ++++
test/mpi/f08/io/shpositionf90.f90 | 75 +++
test/mpi/f08/io/testlist | 20 +
test/mpi/f08/misc/Makefile.am | 19 +
.../f08/{hello_usempif08.f90 => misc/hello.f90} | 0
test/mpi/f08/{ring_usempif08.f90 => misc/ring.f90} | 0
test/mpi/f08/misc/sizeof2.f90 | 62 ++
test/mpi/f08/misc/testlist | 3 +
test/mpi/f08/profile/Makefile.am | 15 +
test/mpi/f08/profile/profile1f90.f90 | 118 ++++
test/mpi/f08/profile/testlist | 1 +
test/mpi/f08/spawn/Makefile.am | 23 +
test/mpi/f08/spawn/connaccf90.f90 | 127 +++++
test/mpi/f08/spawn/namepubf90.f90 | 95 ++++
test/mpi/f08/spawn/spawnargvf03.f90 | 127 +++++
test/mpi/f08/spawn/spawnargvf90.f90 | 125 ++++
test/mpi/f08/spawn/spawnf90.f90 | 98 ++++
test/mpi/f08/spawn/spawnmult2f90.f90 | 134 +++++
test/mpi/f08/spawn/spawnmultf03.f90 | 152 +++++
test/mpi/f08/spawn/spawnmultf90.f90 | 153 +++++
test/mpi/f08/spawn/testlist | 8 +
test/mpi/f08/testlist | 11 +-
test/mpi/f08/timer/Makefile.am | 14 +
test/mpi/{f90 => f08}/timer/testlist | 0
test/mpi/f08/timer/wtimef90.f90 | 32 +
test/mpi/f08/topo/Makefile.am | 14 +
test/mpi/f08/topo/cartcrf90.f90 | 102 ++++
test/mpi/f08/topo/dgraph_unwgtf90.f90 | 213 +++++++
test/mpi/f08/topo/dgraph_wgtf90.f90 | 198 +++++++
test/mpi/f08/topo/testlist | 3 +
test/mpi/f08/util/mtestf08.f90 | 40 ++
64 files changed, 4531 insertions(+), 59 deletions(-)
delete mode 100644 test/mpi/f08/Makefile.am
create mode 100644 test/mpi/f08/ext/Makefile.am
create mode 100644 test/mpi/f08/ext/allocmemf90.f90
create mode 100644 test/mpi/f08/ext/c2f2cf90.f90
create mode 100644 test/mpi/f08/ext/c2f90mult.c
create mode 100644 test/mpi/f08/ext/ctypesinf90.f90
create mode 100644 test/mpi/f08/ext/testlist
create mode 100644 test/mpi/f08/info/Makefile.am
create mode 100644 test/mpi/f08/info/infotest2f90.f90
create mode 100644 test/mpi/f08/info/infotestf90.f90
create mode 100644 test/mpi/f08/info/testlist
create mode 100644 test/mpi/f08/init/Makefile.am
create mode 100644 test/mpi/f08/init/baseenvf90.f90
create mode 100644 test/mpi/f08/init/testlist
create mode 100644 test/mpi/f08/io/Makefile.am
create mode 100644 test/mpi/f08/io/atomicityf90.f90
create mode 100644 test/mpi/f08/io/c2f2ciof90.f90
create mode 100644 test/mpi/f08/io/c2f902cio.c
create mode 100644 test/mpi/f08/io/c2f90multio.c
create mode 100644 test/mpi/f08/io/fileerrf90.f90
create mode 100644 test/mpi/f08/io/fileinfof90.f90
create mode 100644 test/mpi/f08/io/ioharness.defn
create mode 100644 test/mpi/f08/io/ioharness.tlt
create mode 100644 test/mpi/f08/io/miscfilef90.f90
create mode 100644 test/mpi/f08/io/setviewcurf90.f90
create mode 100644 test/mpi/f08/io/shpositionf90.f90
create mode 100644 test/mpi/f08/io/testlist
create mode 100644 test/mpi/f08/misc/Makefile.am
rename test/mpi/f08/{hello_usempif08.f90 => misc/hello.f90} (100%)
rename test/mpi/f08/{ring_usempif08.f90 => misc/ring.f90} (100%)
create mode 100644 test/mpi/f08/misc/sizeof2.f90
create mode 100644 test/mpi/f08/misc/testlist
create mode 100644 test/mpi/f08/profile/Makefile.am
create mode 100644 test/mpi/f08/profile/profile1f90.f90
create mode 100644 test/mpi/f08/profile/testlist
create mode 100644 test/mpi/f08/spawn/Makefile.am
create mode 100644 test/mpi/f08/spawn/connaccf90.f90
create mode 100644 test/mpi/f08/spawn/namepubf90.f90
create mode 100644 test/mpi/f08/spawn/spawnargvf03.f90
create mode 100644 test/mpi/f08/spawn/spawnargvf90.f90
create mode 100644 test/mpi/f08/spawn/spawnf90.f90
create mode 100644 test/mpi/f08/spawn/spawnmult2f90.f90
create mode 100644 test/mpi/f08/spawn/spawnmultf03.f90
create mode 100644 test/mpi/f08/spawn/spawnmultf90.f90
create mode 100644 test/mpi/f08/spawn/testlist
create mode 100644 test/mpi/f08/timer/Makefile.am
copy test/mpi/{f90 => f08}/timer/testlist (100%)
create mode 100644 test/mpi/f08/timer/wtimef90.f90
create mode 100644 test/mpi/f08/topo/Makefile.am
create mode 100644 test/mpi/f08/topo/cartcrf90.f90
create mode 100644 test/mpi/f08/topo/dgraph_unwgtf90.f90
create mode 100644 test/mpi/f08/topo/dgraph_wgtf90.f90
create mode 100644 test/mpi/f08/topo/testlist
hooks/post-receive
--
MPICH primary repository
More information about the commits
mailing list