printf("Proc 0: Request number - %p\n",req);
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, MPI_COMM_WORLD);
-
+
MPI_Recv (buf0, buf_size, MPI_INT, 1, 0, MPI_COMM_WORLD, &status);
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, MPI_COMM_WORLD);
memset (buf0, 0, buf_size*sizeof(int));
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm);
}
else if (drank == 1) {
memset (buf0, 0, buf_size*sizeof(int));
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm);
}
else if (drank == 1) {
memset (buf0, 0, buf_size*sizeof(int));
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm);
}
else if (drank == 1) {
memset (buf0, 0, buf_size*sizeof(int));
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm);
}
else if (drank == 1) {
memset (buf0, 0, buf_size*sizeof(int));
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm);
}
else if (drank == 1) {
}
else {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Recv (buf1, buf_size, MPI_INT, drank, 0, intercomm, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, drank, 0, intercomm);
}
}
if (dnprocs > 1) {
if (drank == 0) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm);
}
else if (drank == 1) {
if (rank == 0) {
memset (buf0, 0, buf_size*sizeof(int));
- MPI_Bcast (buf0, buf_size, MPI_INT, 1, MPI_COMM_WORLD);
- MPI_Bcast (buf0, buf_size, MPI_INT, 0, MPI_COMM_WORLD);
+ MPI_Bcast (buf0, buf_size, MPI_INT, 1, MPI_COMM_WORLD);
+ MPI_Bcast (buf0, buf_size, MPI_INT, 0, MPI_COMM_WORLD);
}
else {
if (rank == 1)
memset (buf1, 1, buf_size*sizeof(int));
- MPI_Bcast (buf0, buf_size, MPI_INT, 0, MPI_COMM_WORLD);
- MPI_Bcast (buf0, buf_size, MPI_INT, 1, MPI_COMM_WORLD);
+ MPI_Bcast (buf0, buf_size, MPI_INT, 0, MPI_COMM_WORLD);
+ MPI_Bcast (buf0, buf_size, MPI_INT, 1, MPI_COMM_WORLD);
}
MPI_Finalize ();
MPI_Wait (&aReq[j], &aStatus[j]);
}
break;
-
+
case 1:
/* use MPI_Waitall */
MPI_Waitall (NUM_SEND_TYPES * 2, aReq, aStatus);
}
break;
-
+
case 3:
/* use MPI_Waitsome */
total = 0;
}
break;
-
+
case 5:
/* use MPI_Testall */
flag = 0;
}
break;
-
+
case 7:
/* use MPI_Testsome */
total = 0;
struct_lb_ub_send_buf[i].dontsend_double2 = 1.0;
#endif
}
-
+
/* set up the sends */
#ifdef RUN_TYPE_STRUCT
MPI_Isend (struct_buf, MSG_COUNT, newtype[0], 1, 0, comm, &aReq[0]);
struct_lb_ub_send_buf[i].the_chars[0] = 'c';
#endif
}
-
+
if ((rank == 0) || (rank == 1))
/* wait on everything... */
MPI_Waitall (TYPE_CONSTRUCTOR_COUNT, aReq, aStatus);
#endif
}
}
-
+
for (i = 0; i < TYPE_CONSTRUCTOR_COUNT; i++)
MPI_Type_free (&newtype[i]);
INTERCOMM_CREATE_TAG, &intercomm);
if (tnprocs > 1) {
- if (trank == 0) {
+ if (trank == 0) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, temp);
}
}
}
else {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, drank, 0, intercomm);
-
+
MPI_Recv (buf1, buf_size, MPI_INT, drank, 0, intercomm, &status);
}
}
if ((trank == 0) && !(rank % 2)) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, temp);
}
else {
}
else {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, drank, 0, intercomm);
-
+
MPI_Recv (buf1, buf_size, MPI_INT, drank, 0, intercomm, &status);
}
}
if (rank == 0) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, MPI_COMM_WORLD);
}
}
else {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, drank, 0, intercomm);
-
+
MPI_Recv (buf1, buf_size, MPI_INT, drank, 0, intercomm, &status);
}
}
if (rank == 2) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, rleader, 0, MPI_COMM_WORLD);
}
else if (rank == 1) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, 0, 0, MPI_COMM_WORLD);
}
}
else {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, drank, 0, intercomm);
-
+
MPI_Recv (buf1, buf_size, MPI_INT, drank, 0, intercomm, &status);
}
}
}
else if (drank == 0) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm);
-
+
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm, &status);
}
}
}
else if (drank == 0) {
memset (buf0, 0, buf_size*sizeof(int));
-
+
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, comm2);
-
+
MPI_Recv (buf1, buf_size, MPI_INT, 1, 0, comm2, &status);
}
}
MPI_Wait (&aReq[j], &aStatus[j]);
}
break;
-
+
case 1:
/* use MPI_Waitall */
MPI_Waitall (2, aReq, aStatus);
MPI_Waitany (2, aReq, &index, aStatus);
}
break;
-
+
case 3:
/* use MPI_Waitsome */
j = 0;
}
}
break;
-
+
case 5:
/* use MPI_Testall */
flag = 0;
}
}
break;
-
+
case 7:
/* use MPI_Testsome */
j = 0;
for (i = 3; i > 0; i--) {
MPI_Recv (&flipbit, 1, MPI_INT, 0, i, MPI_COMM_WORLD, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 0, i, MPI_COMM_WORLD);
}
}
for (i = 0; i < NUMREPS; i++) {
MPI_Send (buf0, buf_size, MPI_INT, 1, 0, MPI_COMM_WORLD);
-
+
MPI_Recv (buf0, buf_size, MPI_INT, 1, 0, MPI_COMM_WORLD, &status);
}
for (i = 3; i > 0; i--) {
MPI_Recv (&flipbit, 1, MPI_INT,
MPI_ANY_SOURCE, i, MPI_COMM_WORLD, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 0, i, MPI_COMM_WORLD);
}
}
for (i = 3; i > 0; i--) {
MPI_Recv (&flipbit, 1, MPI_INT, 0, i, MPI_COMM_WORLD, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 0, i, MPI_COMM_WORLD);
}
}
for (i = 3; i >= 0; i--) {
MPI_Recv (&flipbit, 1, MPI_INT, 0, i, MPI_COMM_WORLD, &status);
-
+
if (i > 0) {
MPI_Send (buf0, buf_size, MPI_INT, 0, i, MPI_COMM_WORLD);
}
comm, &aReq[send_t_number * 2 + 1]);
send_t_number++;
-
+
MPI_Ibsend (&buf[send_t_number * 2 * BUF_SIZE], BUF_SIZE, MPI_INT,
1, send_t_number * 2, comm, &aReq[send_t_number * 2]);
MPI_Ibsend (&buf[(send_t_number * 2 + 1) * BUF_SIZE],
/* Barrier to ensure receives are posted for rsends... */
MPI_Barrier(MPI_COMM_WORLD);
-
+
MPI_Irsend (&buf[send_t_number * 2 * BUF_SIZE], BUF_SIZE, MPI_INT,
1, send_t_number * 2, comm, &aReq[send_t_number * 2]);
MPI_Irsend (&buf[(send_t_number * 2 + 1) * BUF_SIZE],
MPI_Start (&aReq[2 * send_t_number + j]);
}
}
-
+
/* complete the sends */
switch (k/2) {
case 0:
MPI_Wait (&aReq[j], &aStatus[j]);
}
break;
-
+
case 1:
/* use MPI_Waitall */
MPI_Waitall (NUM_SEND_TYPES * 2, aReq, aStatus);
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
MPI_Waitany (NUM_SEND_TYPES * 2, aReq, &index, aStatus);
}
-
+
break;
-
+
case 3:
/* use MPI_Waitsome */
total = 0;
/* use MPI_Test */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
flag = 0;
-
+
while (!flag) {
MPI_Test (&aReq[j], &flag, &aStatus[j]);
}
}
-
+
break;
-
+
case 5:
/* use MPI_Testall */
flag = 0;
while (!flag) {
MPI_Testall (NUM_SEND_TYPES * 2, aReq, &flag, aStatus);
}
-
+
break;
-
+
case 6:
/* use MPI_Testany */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
}
break;
-
+
case 7:
/* use MPI_Testsome */
total = 0;
/* Barrier to ensure receives are posted for rsends... */
MPI_Barrier(MPI_COMM_WORLD);
-
+
/* complete all of the receives... */
switch (l/2) {
case 0:
MPI_Wait (&aReq[j], &aStatus[j]);
}
break;
-
+
case 1:
/* use MPI_Waitall */
MPI_Waitall (NUM_SEND_TYPES * 2, aReq, aStatus);
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
MPI_Waitany (NUM_SEND_TYPES * 2, aReq, &index, aStatus);
}
-
+
break;
-
+
case 3:
/* use MPI_Waitsome */
total = 0;
}
break;
-
+
case 4:
/* use MPI_Test */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
flag = 0;
-
+
while (!flag) {
MPI_Test (&aReq[j], &flag, &aStatus[j]);
}
}
-
+
break;
-
+
case 5:
/* use MPI_Testall */
flag = 0;
while (!flag) {
MPI_Testall (NUM_SEND_TYPES * 2, aReq, &flag, aStatus);
}
-
+
break;
-
+
case 6:
/* use MPI_Testany */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
&index, &flag, aStatus);
}
}
-
+
break;
-
+
case 7:
/* use MPI_Testsome */
total = 0;
MPI_Testsome (NUM_SEND_TYPES * 2, aReq,
&outcount, indices, aStatus);
}
-
+
total += outcount;
}
-
+
break;
-
+
default:
assert (0);
break;
/* use MPI_Test */
for (j = 0; j < 2; j++) {
flag = 0;
-
+
while (!flag) {
MPI_Test (&aReq[j], &flag, &aStatus[j]);
}
small_struct_buf[i].the_double = 1.0;
small_struct_buf[i].the_char = 'a';
}
-
+
for (i = 0; i < BIG_SIZE; i++) {
big_struct_buf[i].the_double = 1.0;
big_struct_buf[i].the_char = 'a';
big_struct_buf[i].the_other_double = 1.0;
}
-
+
/* set up the sends */
MPI_Isend (small_struct_buf, 1, newtype[0], 1, 0, comm, &aReq[0]);
MPI_Isend (big_struct_buf, 1, newtype[1], 1, 1, comm, &aReq[1]);
comm, &aReq[send_t_number * 2 + 1]);
send_t_number++;
-
+
MPI_Ibsend (&buf[send_t_number * 2 * BUF_SIZE], BUF_SIZE, MPI_INT,
1, send_t_number * 2, comm, &aReq[send_t_number * 2]);
MPI_Ibsend (&buf[(send_t_number * 2 + 1) * BUF_SIZE],
/* Barrier to ensure receives are posted for rsends... */
MPI_Barrier(MPI_COMM_WORLD);
-
+
MPI_Irsend (&buf[send_t_number * 2 * BUF_SIZE], BUF_SIZE, MPI_INT,
1, send_t_number * 2, comm, &aReq[send_t_number * 2]);
MPI_Irsend (&buf[(send_t_number * 2 + 1) * BUF_SIZE],
MPI_Start (&aReq[2 * send_t_number + j]);
}
}
-
+
/* complete the sends */
switch (k/2) {
case 0:
MPI_Wait (&aReq[j], &aStatus[j]);
}
break;
-
+
case 1:
/* use MPI_Waitall */
MPI_Waitall (NUM_SEND_TYPES * 2, aReq, aStatus);
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
MPI_Waitany (NUM_SEND_TYPES * 2, aReq, &index, aStatus);
}
-
+
break;
-
+
case 3:
/* use MPI_Waitsome */
total = 0;
/* use MPI_Test */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
flag = 0;
-
+
while (!flag) {
MPI_Test (&aReq[j], &flag, &aStatus[j]);
}
}
-
+
break;
-
+
case 5:
/* use MPI_Testall */
flag = 0;
while (!flag) {
MPI_Testall (NUM_SEND_TYPES * 2, aReq, &flag, aStatus);
}
-
+
break;
-
+
case 6:
/* use MPI_Testany */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
}
break;
-
+
case 7:
/* use MPI_Testsome */
total = 0;
/* Barrier to ensure receives are posted for rsends... */
MPI_Barrier(MPI_COMM_WORLD);
-
+
/* complete all of the receives... */
switch (l/2) {
case 0:
MPI_Wait (&aReq[j], &aStatus[j]);
}
break;
-
+
case 1:
/* use MPI_Waitall */
MPI_Waitall (NUM_SEND_TYPES * 2, aReq, aStatus);
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
MPI_Waitany (NUM_SEND_TYPES * 2, aReq, &index, aStatus);
}
-
+
break;
-
+
case 3:
/* use MPI_Waitsome */
total = 0;
}
break;
-
+
case 4:
/* use MPI_Test */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
flag = 0;
-
+
while (!flag) {
MPI_Test (&aReq[j], &flag, &aStatus[j]);
}
}
-
+
break;
-
+
case 5:
/* use MPI_Testall */
flag = 0;
while (!flag) {
MPI_Testall (NUM_SEND_TYPES * 2, aReq, &flag, aStatus);
}
-
+
break;
-
+
case 6:
/* use MPI_Testany */
for (j = 0; j < NUM_SEND_TYPES * 2; j++) {
&index, &flag, aStatus);
}
}
-
+
break;
-
+
case 7:
/* use MPI_Testsome */
total = 0;
MPI_Testsome (NUM_SEND_TYPES * 2, aReq,
&outcount, indices, aStatus);
}
-
+
total += outcount;
}
-
+
break;
-
+
default:
assert (0);
break;
struct_lb_ub_send_buf[i].dontsend_double2 = 1.0;
#endif
}
-
+
/* set up the sends */
#ifdef RUN_TYPE_STRUCT
MPI_Isend (struct_buf, MSG_COUNT, newtype[0], 1, 0, comm, &aReq[0]);
#endif
}
}
-
+
if ((rank == 0) || (rank == 1)) {
/* wait on everything... */
MPI_Waitall (TYPE_CONSTRUCTOR_COUNT, aReq, aStatus);
#endif
}
}
-
+
for (i = 0; i < TYPE_CONSTRUCTOR_COUNT; i++) {
MPI_Type_free (&newtype[i]);
}
for (i = 3; i > 0; i--) {
MPI_Recv (&flipbit, 1, MPI_INT, 0, i, MPI_COMM_WORLD, &status);
-
+
MPI_Send (buf0, buf_size, MPI_INT, 0, 0, MPI_COMM_WORLD);
}
}
MPICH Test Suite
This test suite is a *supplement* to other test suites, including the
-original MPICH testsuite, the Intel testsuite, and the IBM MPI test suite
+original MPICH testsuite, the Intel testsuite, and the IBM MPI test suite
(or test suites derived from that test, including the MPI C++ tests).
Building the Test Suite
./configure CC=xlc MPICC=mpcc F77=xlf MPIF77=mpxlf CXX=xlC \
MPICXX="mpCC -cpp" F90=xlf90 MPIF90=mpxlf90 \
- --disable-spawn \
- --enable-strictmpi
+ --disable-spawn \
+ --enable-strictmpi
(or the _r versions of the compilers)
add them), you can specify the path with --with-mpi=<path>. For example,
if they are in /usr/local/mympi/bin, use
-./configure --with-mpi=/usr/local/mympi
+./configure --with-mpi=/usr/local/mympi
(configure will append the bin to the path that you give).
C++ bindings of the MPI routines.
For implementations that do not implement all of MPI-2, there are --disable
-options, including --disable-spawn and --disable-cxx. To restrict tests to
+options, including --disable-spawn and --disable-cxx. To restrict tests to
just what is defined in the MPI specification, use --enable-strictmpi .
The script that runs the tests assumes that the MPI implementation
MPITEST_VERBOSE - if set to an integer value, output messages whose
level is at least that value (0 is a good choice here)
MPITEST_RETURN_WITH_CODE - Set the return code from the test programs based on
- success or failure, with a zero for success and one
- for failure (value must be yes, YES, true, or TRUE to
- turn this on)
-MPITEST_THREADLEVEL_DEFAULT - Set the default thread level. Values are
- multiple, serialized, funneled, and single.
+ success or failure, with a zero for success and one
+ for failure (value must be yes, YES, true, or TRUE to
+ turn this on)
+MPITEST_THREADLEVEL_DEFAULT - Set the default thread level. Values are
+ multiple, serialized, funneled, and single.
Batch Systems
=============
For systems that run applications through a batch system, the option "-batch"
-to the runtests script will create a script file that can be edited and
-submitted to the batch system. The script checktests can be run to
-summarize the results.
+to the runtests script will create a script file that can be edited and
+submitted to the batch system. The script checktests can be run to
+summarize the results.
Specifically, (assuming the bash shell, and that the directory "btest", a
subdirectory of the test suite directory, is used for running the tests):
runtests -batch -tests=testlist
... edit btest/runtests.batch to make it a value batch submissions script
... run that script and wait for the batch job to complete
-cd btest && ../checktests
+cd btest && ../checktests
If a program other than mpiexec is used in the batch form to run programs, then
specify that to runtests:
(Here, aprun is the command used on Cray XE6 systems.)
-Note that some programs that are used to run MPI programs add extra output,
+Note that some programs that are used to run MPI programs add extra output,
which can confuse any tool that depends on clean output in STDOUT. Since
-such unfortunate behavior is common, the option -ignorebogus can be given
+such unfortunate behavior is common, the option -ignorebogus can be given
to checktests:
cd btest && ../checktests --ignorebogus
Controlling the Tests that are Run
==================================
-The tests are actually built and run by the script "runtests". This script
+The tests are actually built and run by the script "runtests". This script
can be given a file that contains a list of the tests to run. This file has
two primary types of entries:
- directories: Enter directory and look for the file "testlist".
+ directories: Enter directory and look for the file "testlist".
Recursively run the contents of that file
program names: Build and run that program
sendrecv1 4
-In addition, the program line can contain key=value pairs that provide
-special information about running the test. For example,
+In addition, the program line can contain key=value pairs that provide
+special information about running the test. For example,
sendflood 8 timeLimit=600
env=name=value : Run the program with environment variable "name" given the
value "value"
-mpiversion=x.y : Build and run the program only if the MPI version is at
- least x.y. For example,
+mpiversion=x.y : Build and run the program only if the MPI version is at
+ least x.y. For example,
distgraph1 4 mpiversion=2.2
- will build and run distgraph1 with 4 MPI processes only
- if the MPI version is at least 2.2.
+ will build and run distgraph1 with 4 MPI processes only
+ if the MPI version is at least 2.2.
-strict=bool : If bool is false, only build and run the program if
+strict=bool : If bool is false, only build and run the program if
--enable-strictmpi was not used in configuring the test suite.
- That is, a line such as
+ That is, a line such as
neighb_coll 4 strict=false
Says that this test is not valid for a strict MPI implementation;
it contains extensions to the standard, or in the case of some
- MPICH development, MPIX routines
+ MPICH development, MPIX routines
-resultTest=proc : This is used to change the way in which the success or
- failure of a test is evaluated. proc is one of several
+resultTest=proc : This is used to change the way in which the success or
+ failure of a test is evaluated. proc is one of several
Perl subroutines defined within the runtest program. These
are primarily used within the testsuite for tests programs
- exit with expected status values or that timeouts are
+ exit with expected status values or that timeouts are
in fact handled.
-
-
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C Simple attribute put and get
C
call mpi_keyval_create( MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN,
- $ mykey, extra,ierr )
+ $ mykey, extra,ierr )
call mpi_attr_get( MPI_COMM_WORLD, mykey, value, flag, ierr )
if (flag) then
errs = errs + 1
print *, "Neg Attribute value ", rvalue," should be ",svalue
endif
endif
-C
+C
call mpi_keyval_free( mykey, ierr )
call mtest_finalize( errs )
call mpi_finalize( ierr )
call mpi_comm_rank( MPI_COMM_WORLD, commrank, ierr )
call mpi_attr_get( MPI_COMM_WORLD, MPI_TAG_UB, value, flag, ierr
- $ )
+ $ )
if (.not. flag) then
errs = errs + 1
print *, "Could not get TAG_UB"
else
if (value .lt. 32767) then
errs = errs + 1
- print *, "Got too-small value (", value, ") for TAG_UB"
+ print *, "Got too-small value (", value, ") for TAG_UB"
endif
endif
if (.not. flag) then
errs = errs + 1
print *, "Could not get HOST"
- else
+ else
if ((value .lt. 0 .or. value .ge. commsize) .and. value .ne.
- $ MPI_PROC_NULL) then
+ $ MPI_PROC_NULL) then
errs = errs + 1
print *, "Got invalid value ", value, " for HOST"
endif
- endif
+ endif
call mpi_attr_get( MPI_COMM_WORLD, MPI_IO, value, flag, ierr )
if (.not. flag) then
$ flag, ierr )
if (flag) then
C Wtime need not be set
- if (value .lt. 0 .or. value .gt. 1) then
+ if (value .lt. 0 .or. value .gt. 1) then
errs = errs + 1
print *, "Invalid value for WTIME_IS_GLOBAL (got ", value,
- $ ")"
+ $ ")"
endif
endif
if (value .lt. 0) then
errs = errs + 1
print *, "MPI_APPNUM is defined as ", value,
- $ " but must be nonnegative"
+ $ " but must be nonnegative"
endif
endif
$ ", less than comm world (", commsize, ")"
endif
endif
-
+
call mpi_attr_get( MPI_COMM_WORLD, MPI_LASTUSEDCODE, value, flag
$ , ierr )
C Last used code must be defined and >= MPI_ERR_LASTCODE
$ MPI_ERR_LASTCODE, ") smaller than MPI_ERR_LASTCODE (",
$ value, ")"
endif
- else
+ else
errs = errs + 1
print *, "MPI_LASTUSECODE is not defined"
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
call mpi_attr_get( MPI_COMM_WORLD, MPI_LASTUSEDCODE, value, flag,
$ ierr )
- ! Last used code must be defined and >= MPI_ERR_LASTCODE
+ ! Last used code must be defined and >= MPI_ERR_LASTCODE
if (flag) then
if (value .lt. MPI_ERR_LASTCODE) then
errs = errs + 1
$ (", value, ") smaller than MPI_ERR_LASTCODE (",
$ MPI_ERR_LASTCODE, ")"
endif
- else
+ else
errs = errs + 1
print *, "MPI_LASTUSECODE is not defined"
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
call mtest_init( ierr )
call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr )
-C
+C
extrastate = 1001
- call mpi_comm_create_keyval( MPI_COMM_DUP_FN,
- & MPI_COMM_NULL_DELETE_FN, keyval,
+ call mpi_comm_create_keyval( MPI_COMM_DUP_FN,
+ & MPI_COMM_NULL_DELETE_FN, keyval,
& extrastate, ierr )
flag = .true.
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
if (valout .ne. 2003) then
errs = errs + 1
- print *, 'Unexpected value (should be 2003)', valout,
+ print *, 'Unexpected value (should be 2003)', valout,
& ' from attr'
endif
-
+
valin = 2001
call mpi_comm_set_attr( comm1, keyval, valin, ierr )
flag = .false.
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
if (valout .ne. 2001) then
errs = errs + 1
- print *, 'Unexpected value (should be 2001)', valout,
+ print *, 'Unexpected value (should be 2001)', valout,
& ' from attr'
endif
-
+
C
C Test the copy function
valin = 5001
errs = errs + 1
print *, 'Unexpected output value in comm2 ', valout
endif
-C Test the delete function
+C Test the delete function
call mpi_comm_free( comm2, ierr )
C
C Test the attr delete function
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2004 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
call mtest_init( ierr )
call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr )
-C
+C
extrastate = 1001
- call mpi_comm_create_keyval( MPI_COMM_NULL_COPY_FN,
- & MPI_COMM_NULL_DELETE_FN, keyval,
+ call mpi_comm_create_keyval( MPI_COMM_NULL_COPY_FN,
+ & MPI_COMM_NULL_DELETE_FN, keyval,
& extrastate, ierr )
flag = .true.
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
valin = 5001
call mpi_comm_set_attr( comm1, keyval, valin, ierr )
call mpi_comm_dup( comm1, comm2, ierr )
-C Because we set NULL_COPY_FN, the attribute should not
+C Because we set NULL_COPY_FN, the attribute should not
C appear on the dup'ed communicator
flag = .false.
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
errs = errs + 1
print *, ' Attribute incorrectly present on dup communicator'
endif
-C Test the delete function
+C Test the delete function
call mpi_comm_free( comm2, ierr )
C
C Test the attr delete function
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
callcount = 0
delcount = 0
call mtest_init( ierr )
call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr )
-C
+C
extrastate = 1001
- call mpi_comm_create_keyval( mycopyfn, mydelfn, keyval,
+ call mpi_comm_create_keyval( mycopyfn, mydelfn, keyval,
& extrastate, ierr )
flag = .true.
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
if (valout .ne. 2003) then
errs = errs + 1
- print *, 'Unexpected value (should be 2003)', valout,
+ print *, 'Unexpected value (should be 2003)', valout,
& ' from attr'
endif
-
+
valin = 2001
call mpi_comm_set_attr( comm1, keyval, valin, ierr )
flag = .false.
call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr )
if (valout .ne. 2001) then
errs = errs + 1
- print *, 'Unexpected value (should be 2001)', valout,
+ print *, 'Unexpected value (should be 2001)', valout,
& ' from attr'
endif
-
+
C
C Test the copy function
valin = 5001
errs = errs + 1
print *, 'Unexpected output value in comm2 ', valout
endif
-C Test the delete function
+C Test the delete function
curcount = delcount
call mpi_comm_free( comm2, ierr )
if (delcount .ne. curcount + 1) then
errs = errs + 1
- print *, ' did not get expected value of delcount ',
+ print *, ' did not get expected value of delcount ',
& delcount, curcount + 1
endif
C
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
call mtest_init( ierr )
type1 = MPI_INTEGER
-C
+C
extrastate = 1001
- call mpi_type_create_keyval( MPI_TYPE_DUP_FN,
- & MPI_TYPE_NULL_DELETE_FN, keyval,
+ call mpi_type_create_keyval( MPI_TYPE_DUP_FN,
+ & MPI_TYPE_NULL_DELETE_FN, keyval,
& extrastate, ierr )
flag = .true.
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
if (valout .ne. 2003) then
errs = errs + 1
- print *, 'Unexpected value (should be 2003)', valout,
+ print *, 'Unexpected value (should be 2003)', valout,
& ' from attr'
endif
-
+
valin = 2001
call mpi_type_set_attr( type1, keyval, valin, ierr )
flag = .false.
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
if (valout .ne. 2001) then
errs = errs + 1
- print *, 'Unexpected value (should be 2001)', valout,
+ print *, 'Unexpected value (should be 2001)', valout,
& ' from attr'
endif
-
+
C
C Test the copy function
valin = 5001
errs = errs + 1
print *, 'Unexpected output value in type2 ', valout
endif
-C Test the delete function
+C Test the delete function
call mpi_type_free( type2, ierr )
C
C Test the attr delete function
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2004 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
call mtest_init( ierr )
type1 = MPI_INTEGER
-C
+C
extrastate = 1001
- call mpi_type_create_keyval( MPI_TYPE_NULL_COPY_FN,
- & MPI_TYPE_NULL_DELETE_FN, keyval,
+ call mpi_type_create_keyval( MPI_TYPE_NULL_COPY_FN,
+ & MPI_TYPE_NULL_DELETE_FN, keyval,
& extrastate, ierr )
flag = .true.
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
valin = 5001
call mpi_type_set_attr( type1, keyval, valin, ierr )
call mpi_type_dup( type1, type2, ierr )
-C Because we set NULL_COPY_FN, the attribute should not
+C Because we set NULL_COPY_FN, the attribute should not
C appear on the dup'ed communicator
flag = .false.
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
errs = errs + 1
print *, ' Attribute incorrectly present on dup datatype'
endif
-C Test the delete function
+C Test the delete function
call mpi_type_free( type2, ierr )
C
C Test the attr delete function
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
callcount = 0
delcount = 0
call mtest_init( ierr )
-C
+C
C Attach an attribute to a predefined object
type1 = MPI_INTEGER
extrastate = 1001
- call mpi_type_create_keyval( mycopyfn, mydelfn, keyval,
+ call mpi_type_create_keyval( mycopyfn, mydelfn, keyval,
& extrastate, ierr )
flag = .true.
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
if (valout .ne. 2003) then
errs = errs + 1
- print *, 'Unexpected value (should be 2003)', valout,
+ print *, 'Unexpected value (should be 2003)', valout,
& ' from attr'
endif
-
+
valin = 2001
call mpi_type_set_attr( type1, keyval, valin, ierr )
flag = .false.
call mpi_type_get_attr( type1, keyval, valout, flag, ierr )
if (valout .ne. 2001) then
errs = errs + 1
- print *, 'Unexpected value (should be 2001)', valout,
+ print *, 'Unexpected value (should be 2001)', valout,
& ' from attr'
endif
-
+
C
C Test the copy function
valin = 5001
errs = errs + 1
print *, 'Unexpected output value in type2 ', valout
endif
-C Test the delete function
+C Test the delete function
curcount = delcount
call mpi_type_free( type2, ierr )
if (delcount .ne. curcount + 1) then
errs = errs + 1
- print *, ' did not get expected value of delcount ',
+ print *, ' did not get expected value of delcount ',
& delcount, curcount + 1
endif
C
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2006 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer errs, ierr
errs = 0
-
+
call mtest_init( ierr )
C
C A simple test of allreduce for the optional integer*8 type
- call mpi_allreduce(inbuf, outbuf, 1, MPI_INTEGER8, MPI_SUM,
+ call mpi_allreduce(inbuf, outbuf, 1, MPI_INTEGER8, MPI_SUM,
& MPI_COMM_WORLD, ierr)
-
+
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2007 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer errs, ierr
errs = 0
-
+
call mtest_init( ierr )
call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
C
inbuf = 1
outbuf = 0
- call mpi_allreduce(inbuf, outbuf, 1, MPI_INTEGER8, MPI_SUM,
+ call mpi_allreduce(inbuf, outbuf, 1, MPI_INTEGER8, MPI_SUM,
& MPI_COMM_WORLD, ierr)
if (outbuf .ne. wsize ) then
errs = errs + 1
- print *, "result wrong for sum with integer*8 = got ", outbuf,
+ print *, "result wrong for sum with integer*8 = got ", outbuf,
& " but should have ", wsize
endif
zinbuf = (1,1)
zoutbuf = (0,0)
- call mpi_allreduce(zinbuf, zoutbuf, 1, MPI_DOUBLE_COMPLEX,
+ call mpi_allreduce(zinbuf, zoutbuf, 1, MPI_DOUBLE_COMPLEX,
& MPI_SUM, MPI_COMM_WORLD, ierr)
if (dreal(zoutbuf) .ne. wsize ) then
errs = errs + 1
- print *, "result wrong for sum with double complex = got ",
+ print *, "result wrong for sum with double complex = got ",
& outbuf, " but should have ", wsize
endif
if (dimag(zoutbuf) .ne. wsize ) then
errs = errs + 1
- print *, "result wrong for sum with double complex = got ",
+ print *, "result wrong for sum with double complex = got ",
& outbuf, " but should have ", wsize
endif
call mtest_finalize( errs )
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2011 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer sbuf(maxSize), rbuf(maxSize)
errs = 0
-
+
call mtest_init( ierr )
C Get a comm
call mpi_comm_size( comm, size, ierr )
endif
call mpi_comm_rank( comm, rank, ierr )
-C
+C
if (size .le. maxSize) then
C Initialize the data. Just use this as an all to all
C Use the same test as alltoallwf.c , except displacements are in units of
rbuf(i) = -1
enddo
call mpi_alltoallv( sbuf, scounts, sdispls, stypes,
- & rbuf, rcounts, rdispls, rtypes, comm, ierr )
+ & rbuf, rcounts, rdispls, rtypes, comm, ierr )
C
C check rbuf(i) = data from the ith location of the ith send buf, or
-C rbuf(i) = (i-1) * size + i
+C rbuf(i) = (i-1) * size + i
do i=1, size
ans = (i-1) * size + rank + 1
if (rbuf(i) .ne. ans) then
errs = errs + 1
- print *, rank, ' rbuf(', i, ') = ', rbuf(i),
+ print *, rank, ' rbuf(', i, ') = ', rbuf(i),
& ' expected ', ans
endif
enddo
sbuf(1+displ) = rank
displ = displ + 1
if (rank .lt. size-1) then
- scounts(1+rank+1) = 1
+ scounts(1+rank+1) = 1
rcounts(1+rank+1) = 1
sdispls(1+rank+1) = displ
rdispls(1+rank+1) = rank+1
do i=0,rank-2
if (rbuf(1+i) .ne. -1) then
errs = errs + 1
- print *, rank, ' rbuf(', 1+i, ') = ', rbuf(1+i),
+ print *, rank, ' rbuf(', 1+i, ') = ', rbuf(1+i),
& 'expected -1'
endif
enddo
do i=rank+2,size-1
if (rbuf(1+i) .ne. -1) then
errs = errs + 1
- print *, rank, ' rbuf(', i, ') = ', rbuf(1+i),
+ print *, rank, ' rbuf(', i, ') = ', rbuf(1+i),
& 'expected -1'
endif
enddo
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-
+
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize)
integer sbuf(maxSize), rbuf(maxSize)
errs = 0
-
+
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
call mpi_comm_size( comm, size, ierr )
endif
call mpi_comm_rank( comm, rank, ierr )
-
+
if (size .le. maxSize) then
C Initialize the data. Just use this as an all to all
do i=1, size
rbuf(i) = -1
enddo
call mpi_alltoallw( sbuf, scounts, sdispls, stypes,
- & rbuf, rcounts, rdispls, rtypes, comm, ierr )
+ & rbuf, rcounts, rdispls, rtypes, comm, ierr )
C
C check rbuf(i) = data from the ith location of the ith send buf, or
-C rbuf(i) = (i-1) * size + i
+C rbuf(i) = (i-1) * size + i
do i=1, size
ans = (i-1) * size + rank + 1
if (rbuf(i) .ne. ans) then
errs = errs + 1
- print *, rank, ' rbuf(', i, ') = ', rbuf(i),
+ print *, rank, ' rbuf(', i, ') = ', rbuf(i),
& ' expected ', ans
endif
enddo
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-
+
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer cin(*), cout(*)
integer count, datatype
integer i
-
+
if (.false.) then
if (datatype .ne. MPI_INTEGER) then
write(6,*) 'Invalid datatype passed to user_op()'
external uop
errs = 0
-
+
call mtest_init( ierr )
C
C A simple test of exscan
inbuf(1) = rank
inbuf(2) = -rank
- call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, MPI_SUM, comm,
+ call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, MPI_SUM, comm,
& ierr )
C this process has the sum of i from 0 to rank-1, which is
C (rank)(rank-1)/2 and -i
endif
endif
C
-C Try a user-defined operation
+C Try a user-defined operation
C
call mpi_op_create( uop, .true., sumop, ierr )
inbuf(1) = rank
inbuf(2) = -rank
- call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
+ call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
& ierr )
C this process has the sum of i from 0 to rank-1, which is
C (rank)(rank-1)/2 and -i
endif
endif
call mpi_op_free( sumop, ierr )
-
+
C
C Try a user-defined operation (and don't claim it is commutative)
C
call mpi_op_create( uop, .false., sumop, ierr )
inbuf(1) = rank
inbuf(2) = -rank
- call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
+ call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
& ierr )
C this process has the sum of i from 0 to rank-1, which is
C (rank)(rank-1)/2 and -i
endif
endif
call mpi_op_free( sumop, ierr )
-
+
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2005 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer MAX_SIZE
parameter (MAX_SIZE=1024)
integer rbuf(MAX_SIZE), rdispls(MAX_SIZE), rcount(MAX_SIZE),
- $ sbuf(MAX_SIZE)
+ $ sbuf(MAX_SIZE)
errs = 0
call mtest_init( ierr )
do i=1,size
if (rbuf(i) .ne. i-1) then
errs = errs + 1
- print *, '[',rank,'] rbuf(', i, ') = ', rbuf(i),
- $ ' in gather'
+ print *, '[',rank,'] rbuf(', i, ') = ', rbuf(i),
+ $ ' in gather'
endif
enddo
else
call mpi_gather( rank, 1, MPI_INTEGER, rbuf, 1, MPI_INTEGER,
$ root, comm, ierr )
- endif
+ endif
C Gatherv with inplace
do i=1,size
do i=1,size
if (rbuf(i) .ne. i-1) then
errs = errs + 1
- print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i),
+ print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i),
$ ' in gatherv'
endif
enddo
else
call mpi_gatherv( rank, 1, MPI_INTEGER, rbuf, rcount, rdispls,
$ MPI_INTEGER, root, comm, ierr )
- endif
+ endif
C Scatter with inplace
do i=1,size
if (rbuf(1) .ne. rank+1) then
errs = errs + 1
print *, '[', rank, '] rbuf = ', rbuf(1),
- $ ' in scatter'
+ $ ' in scatter'
endif
- endif
+ endif
call mtest_finalize( errs )
call mpi_finalize( ierr )
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2012 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2012 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
comm = MPI_COMM_WORLD
call MPI_Comm_size(comm, size, ierr)
call MPI_Comm_rank(comm, rank, ierr)
-C
+C
do ii = 1, size
sbuf(2*ii-1) = ii
sbuf(2*ii) = ii
. MPI_SUM, comm, req, ierr)
call MPI_Wait(req, MPI_STATUS_IGNORE, ierr)
- call MPI_Iscatter(sbuf, NUM_INTS, MPI_INTEGER, rbuf,
+ call MPI_Iscatter(sbuf, NUM_INTS, MPI_INTEGER, rbuf,
. NUM_INTS, MPI_INTEGER, 0, comm, req, ierr)
call MPI_Wait(req, MPI_STATUS_IGNORE, ierr)
. rbuf, NUM_INTS, MPI_INTEGER, comm, req, ierr)
call MPI_Wait(req, MPI_STATUS_IGNORE, ierr)
- call MPI_Iallgatherv(sbuf, NUM_INTS, MPI_INTEGER,
- . rbuf, rcounts, rdispls, MPI_INTEGER,
+ call MPI_Iallgatherv(sbuf, NUM_INTS, MPI_INTEGER,
+ . rbuf, rcounts, rdispls, MPI_INTEGER,
. comm, req, ierr)
call MPI_Wait(req, MPI_STATUS_IGNORE, ierr)
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2012 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2011 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
C Test of reduce scatter.
C
-C Each processor contributes its rank + the index to the reduction,
+C Each processor contributes its rank + the index to the reduction,
C then receives the ith sum
C
C Can be called with any number of processors.
recvcounts(i) = 1
enddo
- call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
+ call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
& MPI_INTEGER, MPI_SUM, comm, ierr )
sumval = size * rank + ((size - 1) * size)/2
-C recvbuf should be size * (rank + i)
+C recvbuf should be size * (rank + i)
if (recvbuf .ne. sumval) then
errs = errs + 1
print *, "Did not get expected value for reduce scatter"
endif
call mpi_op_create( uop, .true., sumop, ierr )
- call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
+ call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
& MPI_INTEGER, sumop, comm, ierr )
sumval = size * rank + ((size - 1) * size)/2
-C recvbuf should be size * (rank + i)
+C recvbuf should be size * (rank + i)
if (recvbuf .ne. sumval) then
errs = errs + 1
print *, "sumop: Did not get expected value for reduce scatter"
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2009 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
write(6,*) 'Invalid datatype passed to user_op()'
return
endif
-
+
do ii=1, count
outvec(ii) = invec(ii) * 2 + outvec(ii)
enddo
integer ierr, errs
integer count, myop
integer ii
-
+
errs = 0
call mtest_init(ierr)
do ii = 1,count
vin(ii) = ii
vout(ii) = ii
- enddo
+ enddo
call mpi_reduce_local( vin, vout, count,
& MPI_INTEGER, MPI_SUM, ierr )
C Check if the result is correct
if ( vout(ii) .ne. 2*ii ) then
errs = errs + 1
endif
- enddo
+ enddo
if ( count .gt. 0 ) then
count = count + count
else
call mpi_op_create( user_op, .false., myop, ierr )
count = 0
- do while (count .le. max_buf_size)
+ do while (count .le. max_buf_size)
do ii = 1, count
vin(ii) = ii
vout(ii) = ii
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer cin(*), cout(*)
integer count, datatype
integer i
-
+
C if (datatype .ne. MPI_INTEGER) then
C print *, 'Invalid datatype (',datatype,') passed to user_op()'
C return
integer ierr, errs
integer count, sumop, vin(65000), vout(65000), i, size
integer comm
-
+
errs = 0
call mtest_init(ierr)
comm = MPI_COMM_WORLD
call mpi_comm_size( comm, size, ierr )
count = 1
- do while (count .lt. 65000)
+ do while (count .lt. 65000)
do i=1, count
vin(i) = i
vout(i) = -1
enddo
- call mpi_allreduce( vin, vout, count, MPI_INTEGER, sumop,
+ call mpi_allreduce( vin, vout, count, MPI_INTEGER, sumop,
* comm, ierr )
C Check that all results are correct
do i=1, count
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2012 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
character*(MPI_MAX_ERROR_STRING) errstring
integer comm, rlen
external myerrhanfunc
-CF90 INTERFACE
+CF90 INTERFACE
CF90 SUBROUTINE myerrhanfunc(vv0,vv1)
CF90 INTEGER vv0,vv1
CF90 END SUBROUTINE
call mpi_comm_call_errhandler( comm, newerrclass, ierr )
call mpi_comm_call_errhandler( comm, code(1), ierr )
call mpi_comm_call_errhandler( comm, code(2), ierr )
-
+
if (callcount .ne. 3) then
errs = errs + 1
- print *, ' Expected 3 calls to error handler, found ',
+ print *, ' Expected 3 calls to error handler, found ',
& callcount
else
if (codesSeen(1) .ne. newerrclass) then
errs = errs + 1
- print *, 'Expected class ', newerrclass, ' got ',
+ print *, 'Expected class ', newerrclass, ' got ',
& codesSeen(1)
endif
if (codesSeen(2) .ne. code(1)) then
errs = errs + 1
- print *, 'Expected code ', code(1), ' got ',
+ 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 ',
+ print *, 'Expected code ', code(2), ' got ',
& codesSeen(3)
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
errs = 0
call mtest_init( ierr )
-
+
C Test the predefined communicators
do ln=1,MPI_MAX_OBJECT_NAME
cname(ln:ln) = 'X'
endif
call MTestFreeComm( comm(i) )
enddo
-C
+C
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2004 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer atype, ierr
C
call mtest_init(ierr)
- call mpi_comm_set_errhandler( MPI_COMM_WORLD, MPI_ERRORS_RETURN,
+ call mpi_comm_set_errhandler( MPI_COMM_WORLD, MPI_ERRORS_RETURN,
* ierr )
C
C Check that all Ctypes are available in Fortran (MPI 2.1, p 483, line 46)
call checkdtype( MPI_LONG_DOUBLE, "MPI_LONG_DOUBLE", ierr )
endif
if (MPI_LONG_LONG_INT .ne. MPI_DATATYPE_NULL) then
- call checkdtype2( MPI_LONG_LONG_INT, "MPI_LONG_LONG_INT",
+ call checkdtype2( MPI_LONG_LONG_INT, "MPI_LONG_LONG_INT",
* "MPI_LONG_LONG", ierr )
endif
if (MPI_UNSIGNED_LONG_LONG .ne. MPI_DATATYPE_NULL) then
- call checkdtype( MPI_UNSIGNED_LONG_LONG,
+ call checkdtype( MPI_UNSIGNED_LONG_LONG,
* "MPI_UNSIGNED_LONG_LONG", ierr )
endif
if (MPI_LONG_LONG .ne. MPI_DATATYPE_NULL) then
- call checkdtype2( MPI_LONG_LONG, "MPI_LONG_LONG",
+ call checkdtype2( MPI_LONG_LONG, "MPI_LONG_LONG",
* "MPI_LONG_LONG_INT", ierr )
endif
call checkdtype( MPI_PACKED, "MPI_PACKED", ierr )
C Note that because of implicit declarations in Fortran, this
C code should compile even with pre MPI 2.2 implementations.
C
- if (MPI_VERSION .gt. 2 .or. (MPI_VERSION .eq. 2 .and.
+ if (MPI_VERSION .gt. 2 .or. (MPI_VERSION .eq. 2 .and.
* MPI_SUBVERSION .ge. 2)) then
call checkdtype( MPI_INT8_T, "MPI_INT8_T", ierr )
call checkdtype( MPI_INT16_T, "MPI_INT16_T", ierr )
call checkdtype( MPI_C_BOOL, "MPI_C_BOOL", ierr )
call checkdtype( MPI_C_FLOAT_COMPLEX, "MPI_C_FLOAT_COMPLEX",
* ierr)
- call checkdtype2( MPI_C_COMPLEX, "MPI_C_COMPLEX",
+ call checkdtype2( MPI_C_COMPLEX, "MPI_C_COMPLEX",
* "MPI_C_FLOAT_COMPLEX", ierr )
- call checkdtype( MPI_C_DOUBLE_COMPLEX, "MPI_C_DOUBLE_COMPLEX",
+ call checkdtype( MPI_C_DOUBLE_COMPLEX, "MPI_C_DOUBLE_COMPLEX",
* ierr )
if (MPI_C_LONG_DOUBLE_COMPLEX .ne. MPI_DATATYPE_NULL) then
- call checkdtype( MPI_C_LONG_DOUBLE_COMPLEX,
+ call checkdtype( MPI_C_LONG_DOUBLE_COMPLEX,
* "MPI_C_LONG_DOUBLE_COMPLEX", ierr )
endif
-C address/offset types
+C address/offset types
call checkdtype( MPI_AINT, "MPI_AINT", ierr )
call checkdtype( MPI_OFFSET, "MPI_OFFSET", ierr )
endif
character *(*) name
integer ir, rlen
character *(MPI_MAX_OBJECT_NAME) outname
-C
+C
outname = ""
call MPI_TYPE_GET_NAME( intype, outname, rlen, ir )
if (ir .ne. MPI_SUCCESS) then
ierr = ierr + 1
endif
endif
-
+
return
end
C
character *(*) name, name2
integer ir, rlen
character *(MPI_MAX_OBJECT_NAME) outname
-C
+C
outname = ""
call MPI_TYPE_GET_NAME( intype, outname, rlen, ir )
if (ir .ne. MPI_SUCCESS) then
ierr = ierr + 1
endif
endif
-
+
return
end
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C
C (C) 2003 by Argonne National Laboratory.
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C
C (C) 2011 by Argonne National Laboratory.
integer inbuf(bufsize), outbuf(bufsize), packbuf(bufsize)
integer position, len, psize
C
-C Test for hindexed;
-C
+C Test for hindexed;
+C
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
-
+
do i=1, 10
displs(i) = (10-i)*intsize
counts(i) = 1
enddo
call mpi_type_hindexed( 10, counts, displs, MPI_INTEGER, dtype,
- & ierr )
+ & ierr )
call mpi_type_commit( dtype, ierr )
C
call mpi_pack_size( 1, dtype, MPI_COMM_WORLD, psize, ierr )
position = 0
call mpi_unpack( packbuf, len, position, outbuf, 10,
$ MPI_INTEGER, MPI_COMM_WORLD, ierr )
-C
+C
do i=1, 10
if (outbuf(i) .ne. 11-i) then
errs = errs + 1
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
call mpi_type_size( MPI_INTEGER, intsize, ierr )
pbufsize = 1000 * intsize
- call mpi_pack_external_size( 'external32', 10, MPI_INTEGER,
- & aint, ierr )
+ call mpi_pack_external_size( 'external32', 10, MPI_INTEGER,
+ & aint, ierr )
if (aint .ne. 10 * 4) then
errs = errs + 1
print *, 'Expected 40 for size of 10 external32 integers',
& ', got ', aint
endif
- call mpi_pack_external_size( 'external32', 10, MPI_LOGICAL,
- & aint, ierr )
+ call mpi_pack_external_size( 'external32', 10, MPI_LOGICAL,
+ & aint, ierr )
if (aint .ne. 10 * 4) then
errs = errs + 1
print *, 'Expected 40 for size of 10 external32 logicals',
& ', got ', aint
endif
- call mpi_pack_external_size( 'external32', 10, MPI_CHARACTER,
- & aint, ierr )
+ call mpi_pack_external_size( 'external32', 10, MPI_CHARACTER,
+ & aint, ierr )
if (aint .ne. 10 * 1) then
errs = errs + 1
print *, 'Expected 10 for size of 10 external32 characters',
& ', got ', aint
endif
-
+
call mpi_pack_external_size( 'external32', 3, MPI_INTEGER2,
& aint, ierr )
if (aint .ne. 3 * 2) then
aintv(1) = pbufsize
aintv(2) = 0
aintv(3) = 0
-C One MPI implementation failed to increment the position; instead,
+C One MPI implementation failed to increment the position; instead,
C it set the value with the amount of data packed in this call
C We use aintv(3) to detect and report this specific error
call mpi_pack_external( 'external32', inbuf, insize, MPI_INTEGER,
print *, ' Position decreased after pack of integer!'
endif
aintv(3) = aintv(2)
- call mpi_pack_external( 'external32', rbuf, rsize,
- & MPI_DOUBLE_PRECISION, packbuf, aintv(1),
+ call mpi_pack_external( 'external32', rbuf, rsize,
+ & MPI_DOUBLE_PRECISION, packbuf, aintv(1),
& aintv(2), ierr )
if (aintv(2) .le. aintv(3)) then
print *, ' Position decreased after pack of real!'
endif
aintv(3) = aintv(2)
- call mpi_pack_external( 'external32', cbuf, csize,
- & MPI_CHARACTER, packbuf, aintv(1),
+ call mpi_pack_external( 'external32', cbuf, csize,
+ & MPI_CHARACTER, packbuf, aintv(1),
& aintv(2), ierr )
if (aintv(2) .le. aintv(3)) then
print *, ' Position decreased after pack of character!'
endif
aintv(3) = aintv(2)
- call mpi_pack_external( 'external32', inbuf2, insize2,
+ call mpi_pack_external( 'external32', inbuf2, insize2,
& MPI_INTEGER,
& packbuf, aintv(1), aintv(2), ierr )
if (aintv(2) .le. aintv(3)) then
do i=1, rsize
if (routbuf(i) .ne. 1000.0 * i) then
errs = errs + 1
- print *, 'routbuf(',i,') = ', routbuf(i), ' expected ', &
+ print *, 'routbuf(',i,') = ', routbuf(i), ' expected ', &
& 1000.0 * i
endif
enddo
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer ntype1, ntype2
C
C This is a very simple test that just tests that the contents/envelope
-C routines can be called. This should be upgraded to test the new
+C routines can be called. This should be upgraded to test the new
C MPI-2 datatype routines (which use address-sized integers)
C
call explore( MPI_INTEGER, MPI_COMBINER_NAMED, errs )
call explore( MPI_BYTE, MPI_COMBINER_NAMED, errs )
- call mpi_type_vector( 10, 1, 30, MPI_DOUBLE_PRECISION, ntype1,
+ call mpi_type_vector( 10, 1, 30, MPI_DOUBLE_PRECISION, ntype1,
& ierr )
call explore( ntype1, MPI_COMBINER_VECTOR, errs )
call mpi_type_dup( ntype1, ntype2, ierr )
call explore( ntype2, MPI_COMBINER_DUP, errs )
call mpi_type_free( ntype2, ierr )
call mpi_type_free( ntype1, ierr )
-
+
C
call mtest_finalize( errs )
call mpi_finalize( ierr )
& combiner, ierr )
C
if (combiner .ne. MPI_COMBINER_NAMED) then
- call mpi_type_get_contents( dtype,
+ call mpi_type_get_contents( dtype,
& max_nints, max_asizev, max_dtypes,
& intv, aintv, dtypesv, ierr )
C
errs = errs + 1
print *, ' Unknown combiner ', combiner
endif
-
+
return
end
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
aintv(1) = 0
aintv(2) = 3 * intsize
- call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2),
+ call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2),
& type1, ierr )
call mpi_type_commit( type1, ierr )
aintv(1) = -1
blocklens(i) = 1
aintv(i) = (i-1) * 3 * intsize
enddo
- call mpi_type_create_hindexed( 10, blocklens, aintv,
+ call mpi_type_create_hindexed( 10, blocklens, aintv,
& MPI_INTEGER, type2, ierr )
call mpi_type_commit( type2, ierr )
C
aint = 3 * intsize
- call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3,
+ call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3,
& ierr )
call mpi_type_commit( type3, ierr )
C
do i=1,10
displs(i) = (i-1) * 3
enddo
- call mpi_type_create_indexed_block( 10, 1, displs,
+ call mpi_type_create_indexed_block( 10, 1, displs,
& MPI_INTEGER, type5, ierr )
call mpi_type_commit( type5, ierr )
C
do i=1, max_asizev
sendbuf(i) = i
enddo
- call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
- & recvbuf, max_asizev, type1, rank, 0,
+ call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
+ & recvbuf, max_asizev, type1, rank, 0,
& MPI_COMM_WORLD, status, ierr )
do i=1, max_asizev
if (recvbuf(1+(i-1)*3) .ne. i ) then
do i=1, max_asizev
sendbuf(i) = i
enddo
- call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
- & recvbuf, 1, type2, rank, 0,
+ call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
+ & recvbuf, 1, type2, rank, 0,
& MPI_COMM_WORLD, status, ierr )
do i=1, max_asizev
if (recvbuf(1+(i-1)*3) .ne. i ) then
do i=1, max_asizev
sendbuf(i) = i
enddo
- call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
- & recvbuf, 1, type3, rank, 0,
+ call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
+ & recvbuf, 1, type3, rank, 0,
& MPI_COMM_WORLD, status, ierr )
do i=1, max_asizev
if (recvbuf(1+(i-1)*3) .ne. i ) then
do i=1, max_asizev
sendbuf(i) = i
enddo
- call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
- & recvbuf, 1, type4, rank, 0,
+ call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
+ & recvbuf, 1, type4, rank, 0,
& MPI_COMM_WORLD, status, ierr )
do i=1, max_asizev
if (recvbuf(1+(i-1)*3) .ne. i ) then
do i=1, max_asizev
sendbuf(i) = i
enddo
- call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
- & recvbuf, 1, type5, rank, 0,
+ call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0,
+ & recvbuf, 1, type5, rank, 0,
& MPI_COMM_WORLD, status, ierr )
do i=1, max_asizev
if (recvbuf(1+(i-1)*3) .ne. i ) then
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C
C (C) 2012 by Argonne National Laboratory.
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C
C (C) 2003 by Argonne National Laboratory.
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer ntype1, ntype2, errs, ierr
errs = 0
-
+
call MTest_Init( ierr )
call mpi_type_vector( 10, 1, 100, MPI_INTEGER, ntype1, ierr )
errs = errs + 1
print *, ' (type2) Datatype name is not all blank'
endif
-
+
call mpi_type_free( ntype1, ierr )
call mpi_type_free( ntype2, ierr )
-
+
call MTest_Finalize( errs )
call MPI_Finalize( ierr )
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C and the subarray is
C a(1+1:(maxn-3) +(1+1)-1,2+1:(maxm-4)+(2+1)-1)
C i.e., a (start:(len + start - 1),...)
- call mpi_type_create_subarray( 2, fullsizes, subsizes, starts,
+ call mpi_type_create_subarray( 2, fullsizes, subsizes, starts,
& MPI_ORDER_FORTRAN, MPI_INTEGER, newtype, ierr )
call mpi_type_commit( newtype, ierr )
C
enddo
enddo
ssize = subsizes(1)*subsizes(2)
- call mpi_sendrecv( fullarr, 1, newtype, rank, 0,
- & subarr, ssize, MPI_INTEGER, rank, 0,
+ call mpi_sendrecv( fullarr, 1, newtype, rank, 0,
+ & subarr, ssize, MPI_INTEGER, rank, 0,
& MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr )
C
C Check the data
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2004 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
implicit none
include 'mpif.h'
C
-C This program makes use of a common (but not universal; g77 doesn't
+C This program makes use of a common (but not universal; g77 doesn't
C have it) extension: the "Cray" pointer. This allows MPI_Alloc_mem
C to allocate memory and return it to Fortran, where it can be used.
C As this is not standard Fortran, this test is not run by default.
fprintf( stderr, "Errhandler: did not get errors return\n" );
return 1;
}
-
+
return 0;
}
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
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 )
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
call mpi_finalize( ierr )
end
-
+
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2010 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
call mtest_finalize( errs )
call mpi_finalize( ierr )
- end
+ end
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
errs = 0
call mtest_init( ierr )
-
+
C Note that the MPI standard requires that leading an trailing blanks
C are stripped from keys and values (Section 4.10, The Info Object)
C
if (myvalue(ln:ln) .ne. ' ') then
if (vlen .ne. ln) then
errs = errs + 1
- print *, ' length is ', ln,
- & ' but valuelen gave ', vlen,
+ print *, ' length is ', ln,
+ & ' but valuelen gave ', vlen,
& ' for key ', mykey
endif
goto 100
print *, ' Found unexpected key ', keys(i)
endif
myvalue = 'A test'
- call mpi_info_get( i2, keys(i), MPI_MAX_INFO_VAL,
+ 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
+ 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,
+ 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
+ else
if (myvalue .ne. values(i)) then
errs = errs + 1
- print *, ' Found wrong value (', myvalue, ') for key ',
+ print *, ' Found wrong value (', myvalue, ') for key ',
& keys(i)
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
-C Simple info test
+C Simple info test
program main
implicit none
include 'mpif.h'
if (.not. flag ) then
print *, "Did not find key1 in info1"
errs = errs + 1
- else
+ else
if (value .ne. "value1") then
print *, "Found wrong value (", value, "), expected value1"
errs = errs + 1
else
-C check for trailing blanks
+C check for trailing blanks
do i=7,valuelen
if (value(i:i) .ne. " ") then
print *, "Found non blank in info value"
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
provided = -1
call mpi_init_thread( MPI_THREAD_MULTIPLE, provided, ierr )
- if (provided .ne. MPI_THREAD_MULTIPLE .and.
+ 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
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, '.',
+ print *, 'Version in mpif.h is ', MPI_VERSION, '.',
& MPI_SUBVERSION
print *, 'Version in get_version is ', iv, '.', isubv
endif
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
endif
if (rank .eq. 0) then
- if (errs .eq. 0) then
+ if (errs .eq. 0) then
print *, ' No Errors'
else
print *, ' Found ', errs, ' errors'
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2012 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
logical mtestGetIntraComm
logical verbose
common /flags/ verbose
-
+
errs = 0
verbose = .false.
C verbose = .true.
call test_pair_sendrecvrepl( comm, errs )
call mtestFreeComm( comm )
enddo
-C
+C
call MTest_Finalize( errs )
call MPI_Finalize(ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Send(send_buf, count, MPI_REAL, next, tag,
- . comm, ierr)
+ . comm, ierr)
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'send and recv', errs )
C
- call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
+ call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
end if
C
end
call clear_test_data(recv_buf,TEST_SIZE)
C
if (rank .eq. 0) then
-C
+C
call init_test_data(send_buf,TEST_SIZE)
C
- call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
+ call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
. comm, status, ierr )
C
call MPI_Rsend(send_buf, count, MPI_REAL, next, tag,
- . comm, ierr)
+ . comm, ierr)
C
- call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
+ call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
C
if (status(MPI_SOURCE) .ne. next) then
print *, 'Rsend: Incorrect source, expected', next,
end if
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
+ . MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
C
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
- call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,
+ call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,
. comm, ierr )
call MPI_Wait( requests(1), status, ierr )
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'rsend and recv', errs )
C
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag,
- . comm, ierr)
+ . comm, ierr)
end if
C
end
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Iprobe(MPI_ANY_SOURCE, tag,
- . comm, flag, status, ierr)
+ . comm, flag, status, ierr)
C
if (flag) then
- print *, 'Ssend: Iprobe succeeded! source',
+ print *, 'Ssend: Iprobe succeeded! source',
. status(MPI_SOURCE),
. ', tag', status(MPI_TAG)
errs = errs + 1
end if
C
call MPI_Ssend(send_buf, count, MPI_REAL, next, tag,
- . comm, ierr)
+ . comm, ierr)
C
do while (.not. flag)
call MPI_Iprobe(MPI_ANY_SOURCE, tag,
- . comm, flag, status, ierr)
+ . comm, flag, status, ierr)
end do
-C
+C
if (status(MPI_SOURCE) .ne. next) then
print *, 'Ssend: Incorrect source, expected', next,
. ', got', status(MPI_SOURCE)
. status, ierr)
C
call msg_check( recv_buf, next, tag, count, status,
- . TEST_SIZE, 'ssend and recv', errs )
+ . TEST_SIZE, 'ssend and recv', errs )
C
else if (prev .eq. 0) then
C
. 'ssend and recv', errs )
C
call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag,
- . comm, ierr)
+ . comm, ierr)
end if
C
end
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Isend(send_buf, count, MPI_REAL, next, tag,
- . comm, requests(2), ierr)
+ . comm, requests(2), ierr)
C
call MPI_Waitall(2, requests, statuses, ierr)
C
. 'isend and irecv', errs )
C
call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag,
- . comm, requests(1), ierr)
+ . comm, requests(1), ierr)
C
call MPI_Wait(requests(1), status, ierr)
C
C
call init_test_data(send_buf,TEST_SIZE)
C
- call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
- . MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
+ call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
+ . MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
. dupcom, status, ierr )
C
call MPI_Irsend(send_buf, count, MPI_REAL, next, tag,
- . comm, requests(2), ierr)
+ . comm, requests(2), ierr)
C
index = -1
do while (index .ne. 1)
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
C
- call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,
- . MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,
+ call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,
+ . MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,
. dupcom, status, ierr )
C
flag = .FALSE.
. 'irsend and irecv', errs )
C
call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag,
- . comm, requests(1), ierr)
+ . comm, requests(1), ierr)
C
call MPI_Waitall(1, requests, statuses, ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Issend(send_buf, count, MPI_REAL, next, tag,
- . comm, requests(2), ierr)
+ . comm, requests(2), ierr)
C
flag = .FALSE.
do while (.not. flag)
. 'issend and recv', errs )
call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag,
- . comm, requests(1), ierr)
+ . comm, requests(1), ierr)
C
flag = .FALSE.
do while (.not. flag)
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Send_init(send_buf, count, MPI_REAL, next, tag,
- . comm, requests(1), ierr)
+ . comm, requests(1), ierr)
C
- call MPI_Startall(2, requests, ierr)
+ call MPI_Startall(2, requests, ierr)
call MPI_Waitall(2, requests, statuses, ierr)
C
call msg_check( recv_buf, next, tag, count, statuses(1,2),
else if (prev .eq. 0) then
C
call MPI_Send_init(send_buf, count, MPI_REAL, prev, tag,
- . comm, requests(1), ierr)
- call MPI_Start(requests(2), ierr)
+ . comm, requests(1), ierr)
+ call MPI_Start(requests(2), ierr)
call MPI_Wait(requests(2), status, ierr)
C
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
send_buf(i) = recv_buf(i)
end do
C
- call MPI_Start(requests(1), ierr)
+ call MPI_Start(requests(1), ierr)
call MPI_Wait(requests(1), status, ierr)
C
call MPI_Request_free(requests(1), ierr)
if (rank .eq. 0) then
C
call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag,
- . comm, requests(1), ierr)
+ . comm, requests(1), ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
- call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
+ call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
. comm, status, ierr )
C
call MPI_Startall(2, requests, ierr)
else if (prev .eq. 0) then
C
call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag,
- . comm, requests(1), ierr)
+ . comm, requests(1), ierr)
C
call MPI_Start(requests(2), ierr)
C
- call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,
+ call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,
. comm, ierr )
C
flag = .FALSE.
if (rank .eq. 0) then
C
call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag,
- . comm, requests(2), ierr)
+ . comm, requests(2), ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
else if (prev .eq. 0) then
C
call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag,
- . comm, requests(2), ierr)
+ . comm, requests(2), ierr)
C
call MPI_Start(requests(1), ierr)
C
call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag,
. recv_buf, count, MPI_REAL, next, tag,
- . comm, status, ierr)
+ . comm, status, ierr)
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
. 'sendrecv', errs )
. 'recv/send', errs )
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag,
- . comm, ierr)
+ . comm, ierr)
end if
C
end
C
call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL,
. next, tag, next, tag,
- . comm, status, ierr)
+ . comm, status, ierr)
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
. 'sendrecvreplace', errs )
. 'recv/send for replace', errs )
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag,
- . comm, ierr)
+ . comm, ierr)
end if
C
end
c Check for correct source, tag, count, and data in test message.
c
c------------------------------------------------------------------------------
- subroutine msg_check( recv_buf, source, tag, count, status, n,
+ subroutine msg_check( recv_buf, source, tag, count, status, n,
* name, errs )
implicit none
include 'mpif.h'
call MPI_Get_count(status, MPI_REAL, recv_count, ierr)
if (recv_src .ne. source) then
- print *, '[', rank, '] Unexpected source:', recv_src,
+ print *, '[', rank, '] Unexpected source:', recv_src,
* ' in ', name
errs = errs + 1
end if
* ' in ', name
errs = errs + 1
end if
-
+
call verify_test_data(recv_buf, count, n, name, errs )
end
print *, 'Nonnull request in ', msg
endif
10 continue
-c
+c
end
c------------------------------------------------------------------------------
c
errs = errs + 1
endif
20 continue
-C
+C
100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
C
end
C
-C This routine is used to prevent the compiler from deallocating the
-C array "a", which may happen in some of the tests (see the text in
-C the MPI standard about why this may be a problem in valid Fortran
+C This routine is used to prevent the compiler from deallocating the
+C array "a", which may happen in some of the tests (see the text in
+C the MPI standard about why this may be a problem in valid Fortran
C codes). Without this, for example, tests fail with the Cray ftn
C compiler.
C
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2010 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
C
C This file is used to disable certain compiler optimizations that
-C can cause incorrect results with the test in greqf.f. It provides a
+C can cause incorrect results with the test in greqf.f. It provides a
C point where extrastate may be modified, limiting the compilers ability
C to move code around.
-C The include of mpif.h is not needed in the F77 case but in the
+C The include of mpif.h is not needed in the F77 case but in the
C F90 case it is, because in that case, extrastate is defined as an
C integer (kind=MPI_ADDRESS_KIND), and the script that creates the
C F90 tests from the F77 tests looks for mpif.h
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
extrastate = extrastate - 1
C The value returned by the free function is the error code
-C returned by the wait/test function
+C returned by the wait/test function
ierr = MPI_SUCCESS
end
C
C MPI_Grequest_complete function would be called from another routine,
C often running in a separate thread. This simple code allows us to
C check that requests can be created, tested, and waited on in the
-C case where the request is complete before the wait is called.
+C case where the request is complete before the wait is called.
C
C Note that MPI did *not* define a routine that can be called within
-C test or wait to advance the state of a generalized request.
+C test or wait to advance the state of a generalized request.
C Most uses of generalized requests will need to use a separate thread.
C
program main
errs = 0
freefncall = 0
-
+
call MTest_Init( ierr )
extrastate = 0
- call mpi_grequest_start( query_fn, free_fn, cancel_fn,
+ call mpi_grequest_start( query_fn, free_fn, cancel_fn,
& extrastate, request, ierr )
call mpi_test( request, flag, status, ierr )
if (flag) then
errs = errs + 1
print *, 'Generalized request marked as complete'
endif
-
+
call mpi_grequest_complete( request, ierr )
call MPI_Wait( request, status, ierr )
extrastate = 1
- call mpi_grequest_start( query_fn, free_fn, cancel_fn,
+ call mpi_grequest_start( query_fn, free_fn, cancel_fn,
& extrastate, request, ierr )
call mpi_grequest_complete( request, ierr )
call mpi_wait( request, MPI_STATUS_IGNORE, ierr )
-C
-C The following routine may prevent an optimizing compiler from
+C
+C The following routine may prevent an optimizing compiler from
C just remembering that extrastate was set in grequest_start
call dummyupdate(extrastate)
if (extrastate .ne. 0) then
errs = errs + 1
if (freefncall .eq. 0) then
print *, 'Free routine not called'
- else
+ else
print *, 'Free routine did not update extra_data'
print *, 'extrastate = ', extrastate
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2012 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
call mpi_init( ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, ' Unexpected return from MPI_INIT', ierr
+ print *, ' Unexpected return from MPI_INIT', ierr
endif
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
if (size .lt. 2) then
errs = errs + 1
- print *, ' This test requires at least 2 processes'
-C Abort now - do not continue in this case.
+ print *, ' This test requires at least 2 processes'
+C Abort now - do not continue in this case.
call mpi_abort( MPI_COMM_WORLD, 1, ierr )
endif
if (size .gt. 2) then
print *, ' This test is running with ', size, ' processes,'
- print *, ' only 2 processes are used.'
+ print *, ' only 2 processes are used.'
endif
C Test 0: simple Send and Mprobe+Mrecv.
if (rreq .eq. MPI_REQUEST_NULL) then
errs = errs + 1
print *, 'rreq is unmodified at T1 Imrecv().'
- endif
+ endif
call MPI_Wait(rreq, s2, ierr)
if (recvbuf(1) .ne. 1735928559) then
errs = errs + 1
if (rreq .eq. MPI_REQUEST_NULL) then
errs = errs + 1
print *, 'rreq is unmodified at T3 Imrecv().'
- endif
+ endif
call MPI_Wait(rreq, s2, ierr)
if (recvbuf(1) .ne. 1735928559) then
errs = errs + 1
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
call mpi_init( ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_INIT', ierr
+ print *, 'Unexpected return from MPI_INIT', ierr
endif
ierr = -1
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_COMM_WORLD', ierr
+ print *, 'Unexpected return from MPI_COMM_WORLD', ierr
endif
do i=1, nreqs, 2
ierr = -1
$ MPI_COMM_WORLD, reqs(i), ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_ISEND', ierr
+ print *, 'Unexpected return from MPI_ISEND', ierr
endif
ierr = -1
call mpi_irecv( MPI_BOTTOM, 0, MPI_BYTE, rank, i,
$ MPI_COMM_WORLD, reqs(i+1), ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_IRECV', ierr
+ print *, 'Unexpected return from MPI_IRECV', ierr
endif
enddo
call mpi_waitall( nreqs, reqs, MPI_STATUSES_IGNORE, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_WAITALL', ierr
+ print *, 'Unexpected return from MPI_WAITALL', ierr
endif
call mtest_finalize( errs )
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
include 'addsize.h'
errs = 0
-
+
call mtest_init( ierr )
call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr )
-C Create a window; then extract the values
+C Create a window; then extract the values
asize = 1024
disp = 4
- call MPI_Win_create( base, asize, disp, MPI_INFO_NULL,
+ call MPI_Win_create( base, asize, disp, MPI_INFO_NULL,
& MPI_COMM_WORLD, win, ierr )
C
C In order to check the base, we need an address-of function.
errs = errs + 1
print *, "Could not get WIN_BASE"
C
-C There is no easy way to get the actual value of base to compare
-C against. MPI_Address gives a value relative to MPI_BOTTOM, which
+C There is no easy way to get the actual value of base to compare
+C against. MPI_Address gives a value relative to MPI_BOTTOM, which
C is different from 0 in Fortran (unless you can define MPI_BOTTOM
C as something like %pointer(0)).
C else
C call MPI_Address( base, baseadd, ierr )
C if (valout .ne. baseadd) then
C errs = errs + 1
-C print *, "Got incorrect value for WIN_BASE (", valout,
+C print *, "Got incorrect value for WIN_BASE (", valout,
C & ", should be ", baseadd, ")"
C endif
endif
else
if (valout .ne. asize) then
errs = errs + 1
- print *, "Got incorrect value for WIN_SIZE (", valout,
+ print *, "Got incorrect value for WIN_SIZE (", valout,
& ", should be ", asize, ")"
endif
endif
else
if (valout .ne. disp) then
errs = errs + 1
- print *, "Got wrong value for WIN_DISP_UNIT (", valout,
+ print *, "Got wrong value for WIN_DISP_UNIT (", valout,
& ", should be ", disp, ")"
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
-C
+C
C Test just MPI-RMA
C
program main
C Test passing a Fortran MPI object to C
call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
asize = 0
- call mpi_win_create( 0, asize, 1, MPI_INFO_NULL,
+ call mpi_win_create( 0, asize, 1, MPI_INFO_NULL,
$ MPI_COMM_WORLD, win, ierr )
errs = errs + c2fwin( win )
call mpi_win_free( win, ierr )
C no info, in comm world, created with no memory (base address 0,
C displacement unit 1
call mpi_win_free( win, ierr )
-
+
C
C Summarize the errors
C
call mpi_finalize( ierr )
end
-
+
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
logical mtestGetIntraComm
C Include addsize defines asize as an address-sized integer
include 'addsize.h'
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
- call mpi_win_create( buf, asize, intsize * nrows,
+ call mpi_win_create( buf, asize, intsize * nrows,
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
left = rank - 1
right = MPI_PROC_NULL
endif
C
-C Initialize the buffer
+C Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
enddo
call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr )
-C
+C
asize = ncols + 1
- call mpi_accumulate( buf(1,1), nrows, MPI_INTEGER,
- & left, asize,
+ call mpi_accumulate( buf(1,1), nrows, MPI_INTEGER,
+ & left, asize,
& nrows, MPI_INTEGER, MPI_SUM, win, ierr )
asize = 0
call mpi_accumulate( buf(1,ncols), nrows, MPI_INTEGER, right,
& asize, nrows, MPI_INTEGER, MPI_SUM, win, ierr )
-C
- call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT +
+C
+ call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT +
& MPI_MODE_NOSUCCEED, win, ierr )
C
C Check the results
if (buf(i,ncols+1) .ne. ans) then
errs = errs + 1
if (errs .le. 10) then
- print *, ' buf(',i,',',ncols+1,') = ',
+ print *, ' buf(',i,',',ncols+1,') = ',
& buf(i,ncols+1)
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
call mtest_init( ierr )
val = 10
call mpi_win_create( buf, val, 1,
& MPI_INFO_NULL, comm, win, ierr )
-C
+C
extrastate = 1001
- call mpi_win_create_keyval( MPI_WIN_DUP_FN,
- & MPI_WIN_NULL_DELETE_FN, keyval,
+ call mpi_win_create_keyval( MPI_WIN_DUP_FN,
+ & MPI_WIN_NULL_DELETE_FN, keyval,
& extrastate, ierr )
flag = .true.
call mpi_win_get_attr( win, keyval, valout, flag, ierr )
call mpi_win_get_attr( win, keyval, valout, flag, ierr )
if (valout .ne. 2003) then
errs = errs + 1
- print *, 'Unexpected value (should be 2003)', valout,
+ print *, 'Unexpected value (should be 2003)', valout,
& ' from attr'
endif
-
+
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
flag = .false.
call mpi_win_get_attr( win, keyval, valout, flag, ierr )
if (valout .ne. 2001) then
errs = errs + 1
- print *, 'Unexpected value (should be 2001)', valout,
+ print *, 'Unexpected value (should be 2001)', valout,
& ' from attr'
endif
C
errs = errs + 1
print *, ' Delete_attr did not delete attribute'
endif
-
+
C Test the delete function on window free
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C The only difference between the MPI-2 and MPI-1 attribute caching
C routines in Fortran is that the take an address-sized integer
C instead of a simple integer. These still are not pointers,
-C so the values are still just integers.
+C so the values are still just integers.
C
errs = 0
callcount = 0
val = 10
call mpi_win_create( buf, val, 1,
& MPI_INFO_NULL, comm, win, ierr )
-C
+C
extrastate = 1001
- call mpi_win_create_keyval( mycopyfn, mydelfn, keyval,
+ call mpi_win_create_keyval( mycopyfn, mydelfn, keyval,
& extrastate, ierr )
flag = .true.
call mpi_win_get_attr( win, keyval, valout, flag, ierr )
call mpi_win_get_attr( win, keyval, valout, flag, ierr )
if (valout .ne. 2003) then
errs = errs + 1
- print *, 'Unexpected value (should be 2003)', valout,
+ print *, 'Unexpected value (should be 2003)', valout,
& ' from attr'
endif
-
+
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
flag = .false.
call mpi_win_get_attr( win, keyval, valout, flag, ierr )
if (valout .ne. 2001) then
errs = errs + 1
- print *, 'Unexpected value (should be 2001)', valout,
+ print *, 'Unexpected value (should be 2001)', valout,
& ' from attr'
endif
C
errs = errs + 1
print *, ' Delete_attr did not delete attribute'
endif
-
+
C Test the delete function on window free
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
call mpi_win_free( win, ierr )
if (delcount .ne. curcount + 1) then
errs = errs + 1
- print *, ' did not get expected value of delcount ',
+ print *, ' did not get expected value of delcount ',
& delcount, curcount + 1
endif
valout = -1
ierr = -1
call MPI_WIN_DUP_FN( win, keyval, extrastate, valin, valout,
- $ flag, ierr )
+ $ flag, ierr )
if (.not. flag) then
errs = errs + 1
print *, " Flag was false after MPI_WIN_DUP_FN"
else if (valout .ne. 7001) then
errs = errs + 1
if (valout .eq. -1 ) then
- print *, " output attr value was not copied in MPI_WIN_DUP_FN"
+ print *, " output attr value was not copied in MPI_WIN_DUP_FN"
endif
print *, " value was ", valout, " but expected 7001"
else if (ierr .ne. MPI_SUCCESS) then
valout = -1
ierr = -1
call MPI_WIN_NULL_COPY_FN( win, keyval, extrastate, valin, valout
- $ ,flag, ierr )
+ $ ,flag, ierr )
if (flag) then
errs = errs + 1
print *, " Flag was true after MPI_WIN_NULL_COPY_FN"
else if (valout .ne. -1) then
errs = errs + 1
print *,
- $ " output attr value was copied in MPI_WIN_NULL_COPY_FN"
+ $ " output attr value was copied in MPI_WIN_NULL_COPY_FN"
else if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
print *, " MPI_WIN_NULL_COPY_FN did not return MPI_SUCCESS"
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
integer buf(10)
integer win
external myerrhanfunc
-CF90 INTERFACE
+CF90 INTERFACE
CF90 SUBROUTINE myerrhanfunc(vv0,vv1)
CF90 INTEGER vv0,vv1
CF90 END SUBROUTINE
call mpi_win_call_errhandler( win, newerrclass, ierr )
call mpi_win_call_errhandler( win, code(1), ierr )
call mpi_win_call_errhandler( win, code(2), ierr )
-
+
if (callcount .ne. 3) then
errs = errs + 1
- print *, ' Expected 3 calls to error handler, found ',
+ print *, ' Expected 3 calls to error handler, found ',
& callcount
else
if (codesSeen(1) .ne. newerrclass) then
errs = errs + 1
- print *, 'Expected class ', newerrclass, ' got ',
+ print *, 'Expected class ', newerrclass, ' got ',
& codesSeen(1)
endif
if (codesSeen(2) .ne. code(1)) then
errs = errs + 1
- print *, 'Expected code ', code(1), ' got ',
+ 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 ',
+ print *, 'Expected code ', code(2), ' got ',
& codesSeen(3)
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
logical mtestGetIntraComm
C Include addsize defines asize as an address-sized integer
include 'addsize.h'
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
- call mpi_win_create( buf, asize, intsize * nrows,
+ call mpi_win_create( buf, asize, intsize * nrows,
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
left = rank - 1
right = MPI_PROC_NULL
endif
C
-C Initialize the buffer
+C Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
enddo
call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr )
-C
+C
asize = ncols+1
- call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize,
+ call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize,
& nrows, MPI_INTEGER, win, ierr )
asize = 0
- call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize,
+ call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize,
& nrows, MPI_INTEGER, win, ierr )
-C
- call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT +
+C
+ call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT +
& MPI_MODE_NOSUCCEED, win, ierr )
C
C Check the results
if (buf(i,ncols+1) .ne. ans) then
errs = errs + 1
if (errs .le. 10) then
- print *, rank, ' buf(',i,',',ncols+1,') = ',
+ print *, rank, ' buf(',i,',',ncols+1,') = ',
& buf(i,ncols+1), ' expected ', ans
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
logical mtestGetIntraComm
C Include addsize defines asize as an address-sized integer
include 'addsize.h'
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
- call mpi_win_create( buf, asize, intsize * nrows,
+ call mpi_win_create( buf, asize, intsize * nrows,
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
left = rank - 1
right = MPI_PROC_NULL
endif
C
-C Initialize the buffer
+C Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
enddo
call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr )
-C
+C
asize = 1
call mpi_get( buf(1,ncols+1), nrows, MPI_INTEGER, right,
& asize, nrows, MPI_INTEGER, win, ierr )
asize = ncols
- call mpi_get( buf(1,0), nrows, MPI_INTEGER, left,
+ call mpi_get( buf(1,0), nrows, MPI_INTEGER, left,
& asize, nrows, MPI_INTEGER, win, ierr )
-C
- call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT +
+C
+ call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT +
& MPI_MODE_NOSUCCEED, win, ierr )
C
C Check the results
if (buf(i,ncols+1) .ne. ans) then
errs = errs + 1
if (errs .le. 10) then
- print *, rank, ' buf(',i,',',ncols+1,') = ',
+ print *, rank, ' buf(',i,',',ncols+1,') = ',
& buf(i,ncols+1), ' expected ', ans
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = 10
- call mpi_win_create( buf, asize, intsize,
+ call mpi_win_create( buf, asize, intsize,
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_group( comm, group1, ierr )
call mpi_win_get_group( win, group2, ierr )
call mpi_group_compare( group1, group2, result, ierr )
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
call mtest_init( ierr )
C
C Create a window and get, set the names on it
-C
+C
call mpi_type_size( MPI_INTEGER, intsize, ierr )
asize = 10
- call mpi_win_create( buf, asize, intsize,
+ call mpi_win_create( buf, asize, intsize,
& MPI_INFO_NULL, MPI_COMM_WORLD, win, ierr )
C
C Check that there is no name yet
print *, ' window name is not blank padded'
endif
endif
-C
+C
call mpi_win_free( win, ierr )
call mtest_finalize( errs )
call mpi_finalize( ierr )
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
logical mtestGetIntraComm
C Include addsize defines asize as an address-sized integer
include 'addsize.h'
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
- call mpi_win_create( buf, asize, intsize * nrows,
+ call mpi_win_create( buf, asize, intsize * nrows,
& MPI_INFO_NULL, comm, win, ierr )
-
+
C Create the group for the neighbors
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
call mpi_group_incl( group, nneighbors, nbrs, group2, ierr )
call mpi_group_free( group, ierr )
C
-C Initialize the buffer
+C Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
call mpi_win_post( group2, 0, win, ierr )
call mpi_win_start( group2, 0, win, ierr )
-C
+C
asize = ncols+1
- call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize,
+ call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize,
& nrows, MPI_INTEGER, win, ierr )
asize = 0
- call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize,
+ call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize,
& nrows, MPI_INTEGER, win, ierr )
-C
+C
call mpi_win_complete( win, ierr )
call mpi_win_wait( win, ierr )
C
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
logical flag
C Include addsize defines asize as an address-sized integer
include 'addsize.h'
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
- call mpi_win_create( buf, asize, intsize * nrows,
+ call mpi_win_create( buf, asize, intsize * nrows,
& MPI_INFO_NULL, comm, win, ierr )
-
+
C Create the group for the neighbors
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
call mpi_group_incl( group, nneighbors, nbrs, group2, ierr )
call mpi_group_free( group, ierr )
C
-C Initialize the buffer
+C Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
call mpi_win_post( group2, 0, win, ierr )
call mpi_win_start( group2, 0, win, ierr )
-C
+C
asize = ncols+1
call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize,
& nrows, MPI_INTEGER, win, ierr )
asize = 0
- call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize,
+ call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize,
& nrows, MPI_INTEGER, win, ierr )
-C
+C
call mpi_win_complete( win, ierr )
flag = .false.
do while (.not. flag)
if (buf(i,0) .ne. ans) then
errs = errs + 1
if (errs .le. 10) then
- print *, ' buf(',i,',0) = ', buf(i,0),
+ print *, ' buf(',i,',0) = ', buf(i,0),
& 'expected ', ans
endif
endif
if (buf(i,ncols+1) .ne. ans) then
errs = errs + 1
if (errs .le. 10) then
- print *, ' buf(',i,',',ncols+1,') = ',
+ print *, ' buf(',i,',',ncols+1,') = ',
& buf(i,ncols+1), ' expected ', ans
endif
endif
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2004 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
-C Test various combinations of periodic and non-periodic Cartesian
+C Test various combinations of periodic and non-periodic Cartesian
C communicators
C
program main
endif
endif
endif
-
+
call mpi_cart_shift( newcomm, i-1, -1, source, dest,
$ ierr )
if (outcoords(i) .eq. 0) then
enddo
call mpi_comm_free( newcomm, ierr )
endif
-
+
enddo
enddo
-
+
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2011 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
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,*) "source or destination edge array is not size 2."
write(6,"('src_sz = ',I3,', dest_sz = ',I3)") src_sz, dest_sz
return
endif
C 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
integer srcs(2), dests(2)
errs = 0
- call MTEST_Init(ierr)
+ call MTEST_Init(ierr)
call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
call MPI_Comm_free(dgraph_comm, ierr)
C now create one with MPI_WEIGHTS_EMPTY
-C NOTE that MPI_WEIGHTS_EMPTY was added in MPI-3 and does not
+C NOTE that MPI_WEIGHTS_EMPTY was added in MPI-3 and does not
C appear before then. Including this test means that this test cannot
C be compiled if the MPI version is less than 3 (see the testlist file)
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2011 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
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,*) "source or destination edge array is not size 2."
write(6,"('src_sz = ',I3,', dest_sz = ',I3)") src_sz, dest_sz
return
endif
C 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
integer src_wgts(2), dest_wgts(2)
errs = 0
- call MTEST_Init(ierr)
+ call MTEST_Init(ierr)
call MPI_Comm_rank(MPI_COMM_WORLD, world_rank, ierr)
call MPI_Comm_size(MPI_COMM_WORLD, world_size, ierr)
-C -*- Mode: Fortran; -*-
+C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
include 'mpif.h'
integer errs
integer rank, toterrs, ierr
-
+
call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
- call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
- * MPI_COMM_WORLD, ierr )
-
+ call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
+ * MPI_COMM_WORLD, ierr )
+
if (rank .eq. 0) then
- if (toterrs .gt. 0) then
+ if (toterrs .gt. 0) then
print *, " Found ", toterrs, " errors"
else
print *, " No Errors"
else if (myindex .eq. 2) then
call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
- call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm,
+ call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm,
& ierr )
else
if (min_size .eq. 1 .and. myindex .eq. 3) then
call MPI_Error_class( errcode, errclass, ierr )
call MPI_Error_string( errcode, string, slen, ierr )
print *, msg, ": Error class ", errclass, "
- $ (", string(1:slen), ")"
+ $ (", string(1:slen), ")"
end
! This file created from test/mpi/f77/coll/allredint8f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2006 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer errs, ierr
errs = 0
-
+
call mtest_init( ierr )
!
! A simple test of allreduce for the optional integer*8 type
call mpi_allreduce(inbuf, outbuf, 1, MPI_INTEGER8, MPI_SUM, &
& MPI_COMM_WORLD, ierr)
-
+
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
! This file created from test/mpi/f77/coll/allredopttf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2007 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer errs, ierr
errs = 0
-
+
call mtest_init( ierr )
call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
!
! This file created from test/mpi/f77/coll/alltoallvf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2011 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer sbuf(maxSize), rbuf(maxSize)
errs = 0
-
+
call mtest_init( ierr )
! Get a comm
call mpi_comm_size( comm, size, ierr )
endif
call mpi_comm_rank( comm, rank, ierr )
-!
+!
if (size .le. maxSize) then
! Initialize the data. Just use this as an all to all
! Use the same test as alltoallwf.c , except displacements are in units of
rbuf(i) = -1
enddo
call mpi_alltoallv( sbuf, scounts, sdispls, stypes, &
- & rbuf, rcounts, rdispls, rtypes, comm, ierr )
+ & rbuf, rcounts, rdispls, rtypes, comm, ierr )
!
! check rbuf(i) = data from the ith location of the ith send buf, or
-! rbuf(i) = (i-1) * size + i
+! rbuf(i) = (i-1) * size + i
do i=1, size
ans = (i-1) * size + rank + 1
if (rbuf(i) .ne. ans) then
sbuf(1+displ) = rank
displ = displ + 1
if (rank .lt. size-1) then
- scounts(1+rank+1) = 1
+ scounts(1+rank+1) = 1
rcounts(1+rank+1) = 1
sdispls(1+rank+1) = displ
rdispls(1+rank+1) = rank+1
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-
+
! This file created from test/mpi/f77/coll/alltoallwf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize)
integer sbuf(maxSize), rbuf(maxSize)
errs = 0
-
+
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
call mpi_comm_size( comm, size, ierr )
endif
call mpi_comm_rank( comm, rank, ierr )
-
+
if (size .le. maxSize) then
! Initialize the data. Just use this as an all to all
do i=1, size
rbuf(i) = -1
enddo
call mpi_alltoallw( sbuf, scounts, sdispls, stypes, &
- & rbuf, rcounts, rdispls, rtypes, comm, ierr )
+ & rbuf, rcounts, rdispls, rtypes, comm, ierr )
!
! check rbuf(i) = data from the ith location of the ith send buf, or
-! rbuf(i) = (i-1) * size + i
+! rbuf(i) = (i-1) * size + i
do i=1, size
ans = (i-1) * size + rank + 1
if (rbuf(i) .ne. ans) then
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
-
+
! This file created from test/mpi/f77/coll/exscanf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer cin(*), cout(*)
integer count, datatype
integer i
-
+
if (.false.) then
if (datatype .ne. MPI_INTEGER) then
write(6,*) 'Invalid datatype passed to user_op()'
allocate(inbuf(2), STAT=status)
allocate(outbuf(2), STAT=status)
errs = 0
-
+
call mtest_init( ierr )
!
! A simple test of exscan
endif
endif
!
-! Try a user-defined operation
+! Try a user-defined operation
!
call mpi_op_create( uop, .true., sumop, ierr )
inbuf(1) = rank
endif
endif
call mpi_op_free( sumop, ierr )
-
+
!
! Try a user-defined operation (and don't claim it is commutative)
!
! This file created from test/mpi/f77/coll/inplacef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2005 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer MAX_SIZE
parameter (MAX_SIZE=1024)
integer rbuf(MAX_SIZE), rdispls(MAX_SIZE), rcount(MAX_SIZE), &
- & sbuf(MAX_SIZE)
+ & sbuf(MAX_SIZE)
errs = 0
call mtest_init( ierr )
if (rbuf(i) .ne. i-1) then
errs = errs + 1
print *, '[',rank,'] rbuf(', i, ') = ', rbuf(i), &
- & ' in gather'
+ & ' in gather'
endif
enddo
else
call mpi_gather( rank, 1, MPI_INTEGER, rbuf, 1, MPI_INTEGER, &
& root, comm, ierr )
- endif
+ endif
! Gatherv with inplace
do i=1,size
else
call mpi_gatherv( rank, 1, MPI_INTEGER, rbuf, rcount, rdispls, &
& MPI_INTEGER, root, comm, ierr )
- endif
+ endif
! Scatter with inplace
do i=1,size
if (rbuf(1) .ne. rank+1) then
errs = errs + 1
print *, '[', rank, '] rbuf = ', rbuf(1), &
- & ' in scatter'
+ & ' in scatter'
endif
- endif
+ endif
call mtest_finalize( errs )
call mpi_finalize( ierr )
! This file created from test/mpi/f77/coll/nonblocking_inpf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2012 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! This file created from test/mpi/f77/coll/nonblockingf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2012 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
comm = MPI_COMM_WORLD
call MPI_Comm_size(comm, size, ierr)
call MPI_Comm_rank(comm, rank, ierr)
-!
+!
do ii = 1, size
sbuf(2*ii-1) = ii
sbuf(2*ii) = ii
! This file created from test/mpi/f77/coll/red_scat_blockf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2012 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! This file created from test/mpi/f77/coll/redscatf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2011 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer cin(*), cout(*)
integer count, datatype
integer i
-
+
if (.false.) then
if (datatype .ne. MPI_INTEGER) then
write(6,*) 'Invalid datatype ',datatype,' passed to user_op()'
!
! Test of reduce scatter.
!
-! Each processor contributes its rank + the index to the reduction,
+! Each processor contributes its rank + the index to the reduction,
! then receives the ith sum
!
! Can be called with any number of processors.
& MPI_INTEGER, MPI_SUM, comm, ierr )
sumval = size * rank + ((size - 1) * size)/2
-! recvbuf should be size * (rank + i)
+! recvbuf should be size * (rank + i)
if (recvbuf .ne. sumval) then
errs = errs + 1
print *, "Did not get expected value for reduce scatter"
& MPI_INTEGER, sumop, comm, ierr )
sumval = size * rank + ((size - 1) * size)/2
-! recvbuf should be size * (rank + i)
+! recvbuf should be size * (rank + i)
if (recvbuf .ne. sumval) then
errs = errs + 1
print *, "sumop: Did not get expected value for reduce scatter"
! This file created from test/mpi/f77/coll/reducelocalf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2009 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
write(6,*) 'Invalid datatype passed to user_op()'
return
endif
-
+
do ii=1, count
outvec(ii) = invec(ii) * 2 + outvec(ii)
enddo
integer ierr, errs
integer count, myop
integer ii
-
+
errs = 0
call mtest_init(ierr)
do ii = 1,count
vin(ii) = ii
vout(ii) = ii
- enddo
+ enddo
call mpi_reduce_local( vin, vout, count, &
& MPI_INTEGER, MPI_SUM, ierr )
! Check if the result is correct
if ( vout(ii) .ne. 2*ii ) then
errs = errs + 1
endif
- enddo
+ enddo
if ( count .gt. 0 ) then
count = count + count
else
call mpi_op_create( user_op, .false., myop, ierr )
count = 0
- do while (count .le. max_buf_size)
+ do while (count .le. max_buf_size)
do ii = 1, count
vin(ii) = ii
vout(ii) = ii
! This file created from test/mpi/f77/coll/uallreducef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer cin(*), cout(*)
integer count, datatype
integer i
-
+
if (datatype .ne. MPI_INTEGER) then
print *, 'Invalid datatype (',datatype,') passed to user_op()'
return
integer, DIMENSION(:), ALLOCATABLE :: vin, vout
integer comm
integer status
-
+
errs = 0
ALLOCATE(vin(65000), STAT=status)
ALLOCATE(vout(65000), STAT=status)
comm = MPI_COMM_WORLD
call mpi_comm_size( comm, size, ierr )
count = 1
- do while (count .lt. 65000)
+ do while (count .lt. 65000)
do i=1, count
vin(i) = i
vout(i) = -1
! This file created from test/mpi/f77/coll/vw_inplacef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2012 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! This file created from test/mpi/f77/datatype/allctypesf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2004 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
call checkdtype( MPI_C_LONG_DOUBLE_COMPLEX, &
& "MPI_C_LONG_DOUBLE_COMPLEX", ierr )
endif
-! address/offset types
+! address/offset types
call checkdtype( MPI_AINT, "MPI_AINT", ierr )
call checkdtype( MPI_OFFSET, "MPI_OFFSET", ierr )
endif
character *(*) name
integer ir, rlen
character *(MPI_MAX_OBJECT_NAME) outname
-!
+!
outname = ""
call MPI_TYPE_GET_NAME( intype, outname, rlen, ir )
if (ir .ne. MPI_SUCCESS) then
ierr = ierr + 1
endif
endif
-
+
return
end
!
character *(*) name, name2
integer ir, rlen
character *(MPI_MAX_OBJECT_NAME) outname
-!
+!
outname = ""
call MPI_TYPE_GET_NAME( intype, outname, rlen, ir )
if (ir .ne. MPI_SUCCESS) then
ierr = ierr + 1
endif
endif
-
+
return
end
-!
+!
! (C) 2004 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
print *, "parameter was ", nparms(1), " should be 9"
endif
endif
-
+
call mpi_type_create_f90_integer( 8, ntype2, ierr )
if (ntype1 .eq. ntype2) then
errs = errs + 1
call mtest_finalize( errs )
call mpi_finalize( ierr )
-
+
end
! This file created from test/mpi/f77/datatype/gaddressf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
!
! (C) 2003 by Argonne National Laboratory.
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2013 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2013 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
PROGRAM get_elem_u
- USE mpi
- IMPLICIT NONE
- INTEGER RANK, SIZE, IERR, COMM, errs
+ USE mpi
+ IMPLICIT NONE
+ INTEGER RANK, SIZE, IERR, COMM, errs
INTEGER MAX, I, K, dest
INTEGER STATUS(MPI_STATUS_SIZE)
INTEGER :: type1, type2, extent
REAL :: a(amax)
- errs = 0
- CALL MPI_Init( ierr )
- COMM = MPI_COMM_WORLD
- CALL MPI_Comm_rank(COMM,RANK,IERR)
- CALL MPI_Comm_size(COMM,SIZE,IERR)
+ errs = 0
+ CALL MPI_Init( ierr )
+ COMM = MPI_COMM_WORLD
+ CALL MPI_Comm_rank(COMM,RANK,IERR)
+ CALL MPI_Comm_size(COMM,SIZE,IERR)
dest=size-1
CALL MPI_Type_create_struct(nb, blklen, disp, types, type1, ierr)
CALL MPI_Type_commit(type1, ierr)
CALL MPI_Type_extent(type1, extent, ierr)
- CALL MPI_Type_contiguous(4, Type1, Type2, ierr)
- CALL MPI_Type_commit(Type2, ierr)
+ CALL MPI_Type_contiguous(4, Type1, Type2, ierr)
+ CALL MPI_Type_commit(Type2, ierr)
CALL MPI_Type_extent(Type2, extent, ierr)
DO k=1,17
- IF(rank .EQ. 0) THEN
+ IF(rank .EQ. 0) THEN
! send k copies of datatype Type1
- CALL MPI_Send(a, k, Type1, dest, 0, comm, ierr)
+ CALL MPI_Send(a, k, Type1, dest, 0, comm, ierr)
ELSE IF (rank == dest) THEN
- CALL MPI_Recv(a, 200, Type2, 0, 0, comm, status, ierr)
+ CALL MPI_Recv(a, 200, Type2, 0, 0, comm, status, ierr)
CALL MPI_Get_elements(status, Type2, i, ierr)
IF (i .NE. 2*k) THEN
errs = errs+1
! This file created from test/mpi/f77/datatype/hindex1f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
!
! (C) 2011 by Argonne National Laboratory.
integer inbuf(bufsize), outbuf(bufsize), packbuf(bufsize)
integer position, len, psize
!
-! Test for hindexed;
-!
+! Test for hindexed;
+!
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
-
+
do i=1, 10
displs(i) = (10-i)*intsize
counts(i) = 1
enddo
call mpi_type_hindexed( 10, counts, displs, MPI_INTEGER, dtype, &
- & ierr )
+ & ierr )
call mpi_type_commit( dtype, ierr )
!
call mpi_pack_size( 1, dtype, MPI_COMM_WORLD, psize, ierr )
position = 0
call mpi_unpack( packbuf, len, position, outbuf, 10, &
& MPI_INTEGER, MPI_COMM_WORLD, ierr )
-!
+!
do i=1, 10
if (outbuf(i) .ne. 11-i) then
errs = errs + 1
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
double precision,dimension(:,:),allocatable :: sndbuf, rcvbuf
logical verbose
- verbose = .false.
+ verbose = .false.
call mtest_init ( ierr )
call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
enddo
! bug occurs when first two displacements are 0
- displs(1) = 0
- displs(2) = 0
+ displs(1) = 0
+ displs(2) = 0
displs(3) = 10
- displs(4) = 10
+ displs(4) = 10
call mpi_type_indexed( count, blocklens, displs*blocklens(1), &
& MPI_DOUBLE_PRECISION, type, ierr )
call mpi_send( sndbuf(1,1), 1, type, 1, 0, MPI_COMM_WORLD,ierr )
else if (rank .eq. 1) then
-
+
xfersize=count * blocklens(1)
call mpi_recv( rcvbuf(1,1), xfersize, MPI_DOUBLE_PRECISION, 0, 0, &
& MPI_COMM_WORLD,status, ierr )
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2011 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
call MPI_SEND( aint, 1, MPI_AINT, 1, 0, MPI_COMM_WORLD, ierr )
call MPI_SEND( oint, 1, MPI_OFFSET, 1, 1, MPI_COMM_WORLD, ierr )
call MPI_SEND( iint, 1, MPI_INTEGER, 1, 2, MPI_COMM_WORLD, ierr )
-!
+!
else if (wrank .eq. 1) then
if (range(taint) .ge. 10) then
taint = 1
! This file created from test/mpi/f77/datatype/packef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
pbufsize = 1000 * intsize
call mpi_pack_external_size( 'external32', 10, MPI_INTEGER, &
- & aint, ierr )
+ & aint, ierr )
if (aint .ne. 10 * 4) then
errs = errs + 1
print *, 'Expected 40 for size of 10 external32 integers', &
& ', got ', aint
endif
call mpi_pack_external_size( 'external32', 10, MPI_LOGICAL, &
- & aint, ierr )
+ & aint, ierr )
if (aint .ne. 10 * 4) then
errs = errs + 1
print *, 'Expected 40 for size of 10 external32 logicals', &
& ', got ', aint
endif
call mpi_pack_external_size( 'external32', 10, MPI_CHARACTER, &
- & aint, ierr )
+ & aint, ierr )
if (aint .ne. 10 * 1) then
errs = errs + 1
print *, 'Expected 10 for size of 10 external32 characters', &
& ', got ', aint
endif
-
+
call mpi_pack_external_size( 'external32', 3, MPI_INTEGER2, &
& aint, ierr )
if (aint .ne. 3 * 2) then
aintv(1) = pbufsize
aintv(2) = 0
aintv(3) = 0
-! One MPI implementation failed to increment the position; instead,
+! One MPI implementation failed to increment the position; instead,
! it set the value with the amount of data packed in this call
! We use aintv(3) to detect and report this specific error
call mpi_pack_external( 'external32', inbuf, insize, MPI_INTEGER, &
do i=1, rsize
if (routbuf(i) .ne. 1000.0 * i) then
errs = errs + 1
- print *, 'routbuf(',i,') = ', routbuf(i), ' expected ', &
+ print *, 'routbuf(',i,') = ', routbuf(i), ' expected ', &
& 1000.0 * i
endif
enddo
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2007 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
-! This program tests that the MPI_SIZEOF routine is implemented for the
+! This program tests that the MPI_SIZEOF routine is implemented for the
! predefined scalar Fortran types. It confirms that the size of these
! types matches the size of the corresponding MPI datatypes.
!
-!
+!
! (C) 2004 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
-! Thanks to
+! Thanks to
! William R. Magro
! for this test
!
use mpi
implicit none
-
+
integer comm
integer newtype
integer me
call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
call mpi_type_free(newtype,ierr)
! write(*,*) "Sent ",name(1:5),x
- else
+ else
! Everyone calls barrier in case size > 2
call mpi_barrier( MPI_COMM_WORLD, ierr )
if (me.eq.dest) then
x = 0.0d0
call mpi_recv(buf,bufsize,MPI_PACKED, src, &
& 1, comm, status, ierr)
-
+
call mpi_unpack(buf,bufsize,position, &
& name,5,MPI_CHARACTER, comm,ierr)
call mpi_unpack(buf,bufsize,position, &
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2011 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! This file created from test/mpi/f77/datatype/typecntsf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer ntype1, ntype2
!
! This is a very simple test that just tests that the contents/envelope
-! routines can be called. This should be upgraded to test the new
+! routines can be called. This should be upgraded to test the new
! MPI-2 datatype routines (which use address-sized integers)
!
call explore( ntype2, MPI_COMBINER_DUP, errs )
call mpi_type_free( ntype2, ierr )
call mpi_type_free( ntype1, ierr )
-
+
!
call mtest_finalize( errs )
call mpi_finalize( ierr )
errs = errs + 1
print *, ' Unknown combiner ', combiner
endif
-
+
return
end
! This file created from test/mpi/f77/datatype/typem2f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! This file created from test/mpi/f77/datatype/typename3f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
!
! (C) 2012 by Argonne National Laboratory.
! This file created from test/mpi/f77/datatype/typenamef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
!
! (C) 2003 by Argonne National Laboratory.
! This file created from test/mpi/f77/datatype/typesnamef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer ntype1, ntype2, errs, ierr
errs = 0
-
+
call MTest_Init( ierr )
call mpi_type_vector( 10, 1, 100, MPI_INTEGER, ntype1, ierr )
errs = errs + 1
print *, ' (type2) Datatype name is not all blank'
endif
-
+
call mpi_type_free( ntype1, ierr )
call mpi_type_free( ntype2, ierr )
-
+
call MTest_Finalize( errs )
call MPI_Finalize( ierr )
! This file created from test/mpi/f77/datatype/typesubf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! This file created from test/mpi/f77/info/infotest2f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
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)
!
if (flag) then
errs = errs + 1
print *, ' Found unexpected key in MPI_Info_get ', keys(i)
- else
+ 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 = ' '
if (.not. flag) then
errs = errs + 1
print *, ' Did not find key ', keys(i)
- else
+ else
if (myvalue .ne. values(i)) then
errs = errs + 1
print *, ' Found wrong value (', myvalue, ') for key ', &
! This file created from test/mpi/f77/info/infotestf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
-! Simple info test
+! Simple info test
program main
use mpi
integer i1, i2
if (.not. flag ) then
print *, "Did not find key1 in info1"
errs = errs + 1
- else
+ else
if (value .ne. "value1") then
print *, "Found wrong value (", value, "), expected value1"
errs = errs + 1
else
-! check for trailing blanks
+! check for trailing blanks
do i=7,valuelen
if (value(i:i) .ne. " ") then
print *, "Found non blank in info value"
! This file created from test/mpi/f77/init/baseenvf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
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
endif
if (rank .eq. 0) then
- if (errs .eq. 0) then
+ if (errs .eq. 0) then
print *, ' No Errors'
else
print *, ' Found ', errs, ' errors'
! This file created from test/mpi/f77/pt2pt/allpairf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2012 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
logical mtestGetIntraComm
logical verbose
common /flags/ verbose
-
+
errs = 0
verbose = .false.
! verbose = .true.
call test_pair_sendrecvrepl( comm, errs )
call mtestFreeComm( comm )
enddo
-!
+!
call MTest_Finalize( errs )
call MPI_Finalize(ierr)
!
call init_test_data(send_buf,TEST_SIZE)
!
call MPI_Send(send_buf, count, MPI_REAL, next, tag, &
- & comm, ierr)
+ & comm, ierr)
!
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
& MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
& 'send and recv', errs )
!
- call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
+ call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
end if
!
end
call clear_test_data(recv_buf,TEST_SIZE)
!
if (rank .eq. 0) then
-!
+!
call init_test_data(send_buf,TEST_SIZE)
!
call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
& comm, status, ierr )
!
call MPI_Rsend(send_buf, count, MPI_REAL, next, tag, &
- & comm, ierr)
+ & comm, ierr)
!
- call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
+ call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
!
if (status(MPI_SOURCE) .ne. next) then
print *, 'Rsend: Incorrect source, expected', next, &
& 'rsend and recv', errs )
!
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
- & comm, ierr)
+ & comm, ierr)
end if
!
end
call init_test_data(send_buf,TEST_SIZE)
!
call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
- & comm, flag, status, ierr)
+ & comm, flag, status, ierr)
!
if (flag) then
print *, 'Ssend: Iprobe succeeded! source', &
end if
!
call MPI_Ssend(send_buf, count, MPI_REAL, next, tag, &
- & comm, ierr)
+ & comm, ierr)
!
do while (.not. flag)
call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
- & comm, flag, status, ierr)
+ & comm, flag, status, ierr)
end do
-!
+!
if (status(MPI_SOURCE) .ne. next) then
print *, 'Ssend: Incorrect source, expected', next, &
& ', got', status(MPI_SOURCE)
& status, ierr)
!
call msg_check( recv_buf, next, tag, count, status, &
- & TEST_SIZE, 'ssend and recv', errs )
+ & TEST_SIZE, 'ssend and recv', errs )
!
else if (prev .eq. 0) then
!
& 'ssend and recv', errs )
!
call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag, &
- & comm, ierr)
+ & comm, ierr)
end if
!
end
call init_test_data(send_buf,TEST_SIZE)
!
call MPI_Isend(send_buf, count, MPI_REAL, next, tag, &
- & comm, requests(2), ierr)
+ & comm, requests(2), ierr)
!
call MPI_Waitall(2, requests, statuses, ierr)
!
& 'isend and irecv', errs )
!
call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag, &
- & comm, requests(1), ierr)
+ & comm, requests(1), ierr)
!
call MPI_Wait(requests(1), status, ierr)
!
& dupcom, status, ierr )
!
call MPI_Irsend(send_buf, count, MPI_REAL, next, tag, &
- & comm, requests(2), ierr)
+ & comm, requests(2), ierr)
!
index = -1
do while (index .ne. 1)
& 'irsend and irecv', errs )
!
call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag, &
- & comm, requests(1), ierr)
+ & comm, requests(1), ierr)
!
call MPI_Waitall(1, requests, statuses, ierr)
!
call init_test_data(send_buf,TEST_SIZE)
!
call MPI_Issend(send_buf, count, MPI_REAL, next, tag, &
- & comm, requests(2), ierr)
+ & comm, requests(2), ierr)
!
flag = .FALSE.
do while (.not. flag)
& 'issend and recv', errs )
call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag, &
- & comm, requests(1), ierr)
+ & comm, requests(1), ierr)
!
flag = .FALSE.
do while (.not. flag)
call init_test_data(send_buf,TEST_SIZE)
!
call MPI_Send_init(send_buf, count, MPI_REAL, next, tag, &
- & comm, requests(1), ierr)
+ & comm, requests(1), ierr)
!
- call MPI_Startall(2, requests, ierr)
+ call MPI_Startall(2, requests, ierr)
call MPI_Waitall(2, requests, statuses, ierr)
!
call msg_check( recv_buf, next, tag, count, statuses(1,2), &
else if (prev .eq. 0) then
!
call MPI_Send_init(send_buf, count, MPI_REAL, prev, tag, &
- & comm, requests(1), ierr)
- call MPI_Start(requests(2), ierr)
+ & comm, requests(1), ierr)
+ call MPI_Start(requests(2), ierr)
call MPI_Wait(requests(2), status, ierr)
!
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
send_buf(i) = recv_buf(i)
end do
!
- call MPI_Start(requests(1), ierr)
+ call MPI_Start(requests(1), ierr)
call MPI_Wait(requests(1), status, ierr)
!
call MPI_Request_free(requests(1), ierr)
if (rank .eq. 0) then
!
call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag, &
- & comm, requests(1), ierr)
+ & comm, requests(1), ierr)
!
call init_test_data(send_buf,TEST_SIZE)
!
else if (prev .eq. 0) then
!
call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag, &
- & comm, requests(1), ierr)
+ & comm, requests(1), ierr)
!
call MPI_Start(requests(2), ierr)
!
if (rank .eq. 0) then
!
call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag, &
- & comm, requests(2), ierr)
+ & comm, requests(2), ierr)
!
call init_test_data(send_buf,TEST_SIZE)
!
else if (prev .eq. 0) then
!
call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag, &
- & comm, requests(2), ierr)
+ & comm, requests(2), ierr)
!
call MPI_Start(requests(1), ierr)
!
call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag, &
& recv_buf, count, MPI_REAL, next, tag, &
- & comm, status, ierr)
+ & comm, status, ierr)
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
& 'sendrecv', errs )
& 'recv/send', errs )
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
- & comm, ierr)
+ & comm, ierr)
end if
!
end
!
call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL, &
& next, tag, next, tag, &
- & comm, status, ierr)
+ & comm, status, ierr)
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
& 'sendrecvreplace', errs )
& 'recv/send for replace', errs )
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
- & comm, ierr)
+ & comm, ierr)
end if
!
end
errs = errs + 1
foundError = .true.
end if
-
+
call verify_test_data(recv_buf, count, n, name, errs )
end
print *, 'Nonnull request in ', msg
endif
10 continue
-!
+!
end
!------------------------------------------------------------------------------
!
errs = errs + 1
endif
20 continue
-!
+!
100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
!
end
!
-! This routine is used to prevent the compiler from deallocating the
-! array "a", which may happen in some of the tests (see the text in
-! the MPI standard about why this may be a problem in valid Fortran
+! This routine is used to prevent the compiler from deallocating the
+! array "a", which may happen in some of the tests (see the text in
+! the MPI standard about why this may be a problem in valid Fortran
! codes). Without this, for example, tests fail with the Cray ftn
! compiler.
!
! This file created from test/mpi/f77/pt2pt/dummyf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2010 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
!
! This file is used to disable certain compiler optimizations that
-! can cause incorrect results with the test in greqf.f. It provides a
+! can cause incorrect results with the test in greqf.f. It provides a
! point where extrastate may be modified, limiting the compilers ability
! to move code around.
-! The include of mpif.h is not needed in the F77 case but in the
+! The include of mpif.h is not needed in the F77 case but in the
! F90 case it is, because in that case, extrastate is defined as an
! integer (kind=MPI_ADDRESS_KIND), and the script that creates the
! F90 tests from the F77 tests looks for mpif.h
! This file created from test/mpi/f77/pt2pt/greqf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
extrastate = extrastate - 1
! The value returned by the free function is the error code
-! returned by the wait/test function
+! returned by the wait/test function
ierr = MPI_SUCCESS
end
!
! MPI_Grequest_complete function would be called from another routine,
! often running in a separate thread. This simple code allows us to
! check that requests can be created, tested, and waited on in the
-! case where the request is complete before the wait is called.
+! case where the request is complete before the wait is called.
!
! Note that MPI did *not* define a routine that can be called within
-! test or wait to advance the state of a generalized request.
+! test or wait to advance the state of a generalized request.
! Most uses of generalized requests will need to use a separate thread.
!
program main
errs = 0
freefncall = 0
-
+
call MTest_Init( ierr )
extrastate = 0
errs = errs + 1
print *, 'Generalized request marked as complete'
endif
-
+
call mpi_grequest_complete( request, ierr )
call MPI_Wait( request, status, ierr )
& extrastate, request, ierr )
call mpi_grequest_complete( request, ierr )
call mpi_wait( request, MPI_STATUS_IGNORE, ierr )
-!
-! The following routine may prevent an optimizing compiler from
+!
+! The following routine may prevent an optimizing compiler from
! just remembering that extrastate was set in grequest_start
call dummyupdate(extrastate)
if (extrastate .ne. 0) then
errs = errs + 1
if (freefncall .eq. 0) then
print *, 'Free routine not called'
- else
+ else
print *, 'Free routine did not update extra_data'
print *, 'extrastate = ', extrastate
endif
! This file created from test/mpi/f77/pt2pt/mprobef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2012 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
call mpi_init( ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, ' Unexpected return from MPI_INIT', ierr
+ print *, ' Unexpected return from MPI_INIT', ierr
endif
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
if (size .lt. 2) then
errs = errs + 1
- print *, ' This test requires at least 2 processes'
-! Abort now - do not continue in this case.
+ print *, ' This test requires at least 2 processes'
+! Abort now - do not continue in this case.
call mpi_abort( MPI_COMM_WORLD, 1, ierr )
endif
if (size .gt. 2) then
print *, ' This test is running with ', size, ' processes,'
- print *, ' only 2 processes are used.'
+ print *, ' only 2 processes are used.'
endif
! Test 0: simple Send and Mprobe+Mrecv.
if (rreq .eq. MPI_REQUEST_NULL) then
errs = errs + 1
print *, 'rreq is unmodified at T1 Imrecv().'
- endif
+ endif
call MPI_Wait(rreq, s2, ierr)
if (recvbuf(1) .ne. 1735928559) then
errs = errs + 1
if (rreq .eq. MPI_REQUEST_NULL) then
errs = errs + 1
print *, 'rreq is unmodified at T3 Imrecv().'
- endif
+ endif
call MPI_Wait(rreq, s2, ierr)
if (recvbuf(1) .ne. 1735928559) then
errs = errs + 1
! This file created from test/mpi/f77/pt2pt/statusesf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
call mpi_init( ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_INIT', ierr
+ print *, 'Unexpected return from MPI_INIT', ierr
endif
ierr = -1
call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_COMM_WORLD', ierr
+ print *, 'Unexpected return from MPI_COMM_WORLD', ierr
endif
do i=1, nreqs, 2
ierr = -1
& MPI_COMM_WORLD, reqs(i), ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_ISEND', ierr
+ print *, 'Unexpected return from MPI_ISEND', ierr
endif
ierr = -1
call mpi_irecv( MPI_BOTTOM, 0, MPI_BYTE, rank, i, &
& MPI_COMM_WORLD, reqs(i+1), ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_IRECV', ierr
+ print *, 'Unexpected return from MPI_IRECV', ierr
endif
enddo
call mpi_waitall( nreqs, reqs, MPI_STATUSES_IGNORE, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
- print *, 'Unexpected return from MPI_WAITALL', ierr
+ print *, 'Unexpected return from MPI_WAITALL', ierr
endif
call mtest_finalize( errs )
! This file created from test/mpi/f77/rma/baseattrwinf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
errs = 0
-
+
call mtest_init( ierr )
call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr )
-! Create a window; then extract the values
+! Create a window; then extract the values
asize = 1024
disp = 4
call MPI_Win_create( base, asize, disp, MPI_INFO_NULL, &
errs = errs + 1
print *, "Could not get WIN_BASE"
!
-! There is no easy way to get the actual value of base to compare
-! against. MPI_Address gives a value relative to MPI_BOTTOM, which
+! There is no easy way to get the actual value of base to compare
+! against. MPI_Address gives a value relative to MPI_BOTTOM, which
! is different from 0 in Fortran (unless you can define MPI_BOTTOM
! as something like %pointer(0)).
! else
! call MPI_Address( base, baseadd, ierr )
! if (valout .ne. baseadd) then
! errs = errs + 1
-! print *, "Got incorrect value for WIN_BASE (", valout,
+! print *, "Got incorrect value for WIN_BASE (", valout,
! & ", should be ", baseadd, ")"
! endif
endif
! This file created from test/mpi/f77/rma/c2f2cwinf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
-!
+!
! Test just MPI-RMA
!
program main
! no info, in comm world, created with no memory (base address 0,
! displacement unit 1
call mpi_win_free( win, ierr )
-
+
!
! Summarize the errors
!
call mpi_finalize( ierr )
end
-
+
! This file created from test/mpi/f77/rma/winaccf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! Include addsize defines asize as an address-sized integer
integer (kind=MPI_ADDRESS_KIND) asize
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
call mpi_win_create( buf, asize, intsize * nrows, &
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
left = rank - 1
right = MPI_PROC_NULL
endif
!
-! Initialize the buffer
+! Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
enddo
call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr )
-!
+!
asize = ncols + 1
call mpi_accumulate( buf(1,1), nrows, MPI_INTEGER, &
& left, asize, &
asize = 0
call mpi_accumulate( buf(1,ncols), nrows, MPI_INTEGER, right, &
& asize, nrows, MPI_INTEGER, MPI_SUM, win, ierr )
-!
+!
call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + &
& MPI_MODE_NOSUCCEED, win, ierr )
!
! This file created from test/mpi/f77/rma/winattr2f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! The only difference between the MPI-2 and MPI-1 attribute caching
! routines in Fortran is that the take an address-sized integer
! instead of a simple integer. These still are not pointers,
-! so the values are still just integers.
+! so the values are still just integers.
!
errs = 0
call mtest_init( ierr )
val = 10
call mpi_win_create( buf, val, 1, &
& MPI_INFO_NULL, comm, win, ierr )
-!
+!
extrastate = 1001
call mpi_win_create_keyval( MPI_WIN_DUP_FN, &
& MPI_WIN_NULL_DELETE_FN, keyval, &
print *, 'Unexpected value (should be 2003)', valout, &
& ' from attr'
endif
-
+
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
flag = .false.
errs = errs + 1
print *, ' Delete_attr did not delete attribute'
endif
-
+
! Test the delete function on window free
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
! This file created from test/mpi/f77/rma/winattrf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! The only difference between the MPI-2 and MPI-1 attribute caching
! routines in Fortran is that the take an address-sized integer
! instead of a simple integer. These still are not pointers,
-! so the values are still just integers.
+! so the values are still just integers.
!
errs = 0
callcount = 0
val = 10
call mpi_win_create( buf, val, 1, &
& MPI_INFO_NULL, comm, win, ierr )
-!
+!
extrastate = 1001
call mpi_win_create_keyval( mycopyfn, mydelfn, keyval, &
& extrastate, ierr )
print *, 'Unexpected value (should be 2003)', valout, &
& ' from attr'
endif
-
+
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
flag = .false.
errs = errs + 1
print *, ' Delete_attr did not delete attribute'
endif
-
+
! Test the delete function on window free
valin = 2001
call mpi_win_set_attr( win, keyval, valin, ierr )
valout = -1
ierr = -1
call MPI_WIN_DUP_FN( win, keyval, extrastate, valin, valout, &
- & flag, ierr )
+ & flag, ierr )
if (.not. flag) then
errs = errs + 1
print *, " Flag was false after MPI_WIN_DUP_FN"
else if (valout .ne. 7001) then
errs = errs + 1
if (valout .eq. -1 ) then
- print *, " output attr value was not copied in MPI_WIN_DUP_FN"
+ print *, " output attr value was not copied in MPI_WIN_DUP_FN"
endif
print *, " value was ", valout, " but expected 7001"
else if (ierr .ne. MPI_SUCCESS) then
valout = -1
ierr = -1
call MPI_WIN_NULL_COPY_FN( win, keyval, extrastate, valin, valout &
- & ,flag, ierr )
+ & ,flag, ierr )
if (flag) then
errs = errs + 1
print *, " Flag was true after MPI_WIN_NULL_COPY_FN"
else if (valout .ne. -1) then
errs = errs + 1
print *, &
- & " output attr value was copied in MPI_WIN_NULL_COPY_FN"
+ & " output attr value was copied in MPI_WIN_NULL_COPY_FN"
else if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
print *, " MPI_WIN_NULL_COPY_FN did not return MPI_SUCCESS"
! This file created from test/mpi/f77/rma/winerrf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
integer buf(10)
integer win
! external myerrhanfunc
- INTERFACE
+ INTERFACE
SUBROUTINE myerrhanfunc(vv0,vv1)
INTEGER vv0,vv1
END SUBROUTINE
call mpi_win_call_errhandler( win, newerrclass, ierr )
call mpi_win_call_errhandler( win, code(1), ierr )
call mpi_win_call_errhandler( win, code(2), ierr )
-
+
if (callcount .ne. 3) then
errs = errs + 1
print *, ' Expected 3 calls to error handler, found ', &
! This file created from test/mpi/f77/rma/winfencef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! Include addsize defines asize as an address-sized integer
integer (kind=MPI_ADDRESS_KIND) asize
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
call mpi_win_create( buf, asize, intsize * nrows, &
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
left = rank - 1
right = MPI_PROC_NULL
endif
!
-! Initialize the buffer
+! Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
enddo
call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr )
-!
+!
asize = ncols+1
call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize, &
& nrows, MPI_INTEGER, win, ierr )
asize = 0
call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize, &
& nrows, MPI_INTEGER, win, ierr )
-!
+!
call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + &
& MPI_MODE_NOSUCCEED, win, ierr )
!
! This file created from test/mpi/f77/rma/wingetf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! Include addsize defines asize as an address-sized integer
integer (kind=MPI_ADDRESS_KIND) asize
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
call mpi_win_create( buf, asize, intsize * nrows, &
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
left = rank - 1
right = MPI_PROC_NULL
endif
!
-! Initialize the buffer
+! Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
enddo
call mpi_win_fence( MPI_MODE_NOPRECEDE, win, ierr )
-!
+!
asize = 1
call mpi_get( buf(1,ncols+1), nrows, MPI_INTEGER, right, &
& asize, nrows, MPI_INTEGER, win, ierr )
asize = ncols
call mpi_get( buf(1,0), nrows, MPI_INTEGER, left, &
& asize, nrows, MPI_INTEGER, win, ierr )
-!
+!
call mpi_win_fence( MPI_MODE_NOSTORE + MPI_MODE_NOPUT + &
& MPI_MODE_NOSUCCEED, win, ierr )
!
! This file created from test/mpi/f77/rma/wingroupf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = 10
call mpi_win_create( buf, asize, intsize, &
& MPI_INFO_NULL, comm, win, ierr )
-
+
call mpi_comm_group( comm, group1, ierr )
call mpi_win_get_group( win, group2, ierr )
call mpi_group_compare( group1, group2, result, ierr )
! This file created from test/mpi/f77/rma/winnamef.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
call mtest_init( ierr )
!
! Create a window and get, set the names on it
-!
+!
call mpi_type_size( MPI_INTEGER, intsize, ierr )
asize = 10
call mpi_win_create( buf, asize, intsize, &
print *, ' window name is not blank padded'
endif
endif
-!
+!
call mpi_win_free( win, ierr )
call mtest_finalize( errs )
call mpi_finalize( ierr )
! This file created from test/mpi/f77/rma/winscale1f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! Include addsize defines asize as an address-sized integer
integer (kind=MPI_ADDRESS_KIND) asize
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
call mpi_win_create( buf, asize, intsize * nrows, &
& MPI_INFO_NULL, comm, win, ierr )
-
+
! Create the group for the neighbors
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
call mpi_group_incl( group, nneighbors, nbrs, group2, ierr )
call mpi_group_free( group, ierr )
!
-! Initialize the buffer
+! Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
call mpi_win_post( group2, 0, win, ierr )
call mpi_win_start( group2, 0, win, ierr )
-!
+!
asize = ncols+1
call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize, &
& nrows, MPI_INTEGER, win, ierr )
asize = 0
call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize, &
& nrows, MPI_INTEGER, win, ierr )
-!
+!
call mpi_win_complete( win, ierr )
call mpi_win_wait( win, ierr )
!
! This file created from test/mpi/f77/rma/winscale2f.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
! Include addsize defines asize as an address-sized integer
integer (kind=MPI_ADDRESS_KIND) asize
-
+
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
- do while( mtestGetIntraComm( comm, 2, .false. ) )
+ do while( mtestGetIntraComm( comm, 2, .false. ) )
asize = nrows * (ncols + 2) * intsize
call mpi_win_create( buf, asize, intsize * nrows, &
& MPI_INFO_NULL, comm, win, ierr )
-
+
! Create the group for the neighbors
call mpi_comm_size( comm, size, ierr )
call mpi_comm_rank( comm, rank, ierr )
call mpi_group_incl( group, nneighbors, nbrs, group2, ierr )
call mpi_group_free( group, ierr )
!
-! Initialize the buffer
+! Initialize the buffer
do i=1,nrows
buf(i,0) = -1
buf(i,ncols+1) = -1
enddo
call mpi_win_post( group2, 0, win, ierr )
call mpi_win_start( group2, 0, win, ierr )
-!
+!
asize = ncols+1
call mpi_put( buf(1,1), nrows, MPI_INTEGER, left, asize, &
& nrows, MPI_INTEGER, win, ierr )
asize = 0
call mpi_put( buf(1,ncols), nrows, MPI_INTEGER, right, asize, &
& nrows, MPI_INTEGER, win, ierr )
-!
+!
call mpi_win_complete( win, ierr )
flag = .false.
do while (.not. flag)
! This file created from test/mpi/f77/util/mtestf.f with f77tof90
-! -*- Mode: Fortran; -*-
+! -*- Mode: Fortran; -*-
!
! (C) 2003 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
use mpi
integer errs
integer rank, toterrs, ierr
-
+
call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
- & MPI_COMM_WORLD, ierr )
-
+ & MPI_COMM_WORLD, ierr )
+
if (rank .eq. 0) then
- if (toterrs .gt. 0) then
+ if (toterrs .gt. 0) then
print *, " Found ", toterrs, " errors"
else
print *, " No Errors"
call MPI_Error_class( errcode, errclass, ierr )
call MPI_Error_string( errcode, string, slen, ierr )
print *, msg, ": Error class ", errclass, " &
- & (", string(1:slen), ")"
+ & (", string(1:slen), ")"
end
-This directory contains some performance tests. These are not
+This directory contains some performance tests. These are not
general performance tests; rather, they reflect our experience with
particular performance articfacts that users (or ourselves) haver
reported or experienced. The tests include:
sendrecvl - Send and receive (head to head) large messages.
mattrans - Matrix transpose example
-
#include <stdio.h>
#include <stdlib.h>
#include "mpitest.h"
-#define USE_STRICT_MPI 1
+#define USE_STRICT_MPI 1
/* Test Ibsend and Request_free */
int main(int argc, char *argv[])
{
