From: Pierre Veyre Date: Wed, 17 Jul 2013 07:57:16 +0000 (+0200) Subject: Merge branch 'master' of git+ssh://scm.gforge.inria.fr//gitroot/simgrid/simgrid X-Git-Tag: v3_9_90~130 X-Git-Url: http://info.iut-bm.univ-fcomte.fr/pub/gitweb/simgrid.git/commitdiff_plain/f4b7b8e6ce0fd35fc2ada5f5c06d212bcd2199c8?hp=79e90c963f37214684e948200fe61fc12945cc26 Merge branch 'master' of git+ssh://scm.gforge.inria.fr//gitroot/simgrid/simgrid --- diff --git a/ChangeLog b/ChangeLog index 98b7afe6b6..0add88dfef 100644 --- a/ChangeLog +++ b/ChangeLog @@ -40,7 +40,7 @@ SimGrid (3.10) NOT RELEASED; urgency=low * Add a --cfg:tracing/smpi/internals option, to trace internal communications happening inside a collective SMPI call. * Fix the behavior of complex datatypes handling - + * replace MPICH-1 test suite by the one from MPICH 3.0.4 PLATFORM: * Handle units for values (10ms, 10kiloflops, 10Bps, ...) diff --git a/buildtools/Cmake/AddTests.cmake b/buildtools/Cmake/AddTests.cmake index 5bd343e5f6..e38d36e5af 100644 --- a/buildtools/Cmake/AddTests.cmake +++ b/buildtools/Cmake/AddTests.cmake @@ -464,7 +464,8 @@ if(NOT enable_memcheck) ADD_TEST(smpi-mpich3-datatype-raw ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/datatype ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/datatype -tests=testlist -execarg=--cfg=contexts/factory:raw) ADD_TEST(smpi-mpich3-group-raw ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/group ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/group -tests=testlist -execarg=--cfg=contexts/factory:raw) ADD_TEST(smpi-mpich3-pt2pt-raw ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/pt2pt ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/pt2pt -tests=testlist -execarg=--cfg=contexts/factory:raw) - set_tests_properties(smpi-mpich3-attr-raw smpi-mpich3-coll-thread smpi-mpich3-coll-ompi-thread smpi-mpich3-coll-mpich-thread smpi-mpich3-comm-raw smpi-mpich3-init-raw smpi-mpich3-datatype-raw smpi-mpich3-pt2pt-raw smpi-mpich3-group-raw PROPERTIES PASS_REGULAR_EXPRESSION "tests passed!") + ADD_TEST(smpi-mpich3-thread-f77 ${CMAKE_COMMAND} -E chdir ${CMAKE_BINARY_DIR}/teshsuite/smpi/mpich3-test/f77/ ${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/runtests -mpiexec=${CMAKE_BINARY_DIR}/smpi_script/bin/smpirun -srcdir=${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/ -tests=testlist -execarg=--cfg=contexts/factory:thread) + set_tests_properties(smpi-mpich3-thread-f77 smpi-mpich3-attr-raw smpi-mpich3-coll-thread smpi-mpich3-coll-ompi-thread smpi-mpich3-coll-mpich-thread smpi-mpich3-comm-raw smpi-mpich3-init-raw smpi-mpich3-datatype-raw smpi-mpich3-pt2pt-raw smpi-mpich3-group-raw PROPERTIES PASS_REGULAR_EXPRESSION "tests passed!") endif() endif() diff --git a/buildtools/Cmake/DefinePackages.cmake b/buildtools/Cmake/DefinePackages.cmake index f53e862090..a6b4b421d2 100644 --- a/buildtools/Cmake/DefinePackages.cmake +++ b/buildtools/Cmake/DefinePackages.cmake @@ -914,12 +914,6 @@ set(TESHSUITE_CMAKEFILES_TXT teshsuite/simdag/partask/CMakeLists.txt teshsuite/simdag/platforms/CMakeLists.txt teshsuite/smpi/CMakeLists.txt - # teshsuite/smpi/mpich-test/CMakeLists.txt - # teshsuite/smpi/mpich-test/coll/CMakeLists.txt - # teshsuite/smpi/mpich-test/context/CMakeLists.txt - # teshsuite/smpi/mpich-test/env/CMakeLists.txt - # teshsuite/smpi/mpich-test/profile/CMakeLists.txt - # teshsuite/smpi/mpich-test/pt2pt/CMakeLists.txt teshsuite/smpi/mpich3-test/CMakeLists.txt teshsuite/smpi/mpich3-test/attr/CMakeLists.txt teshsuite/smpi/mpich3-test/comm/CMakeLists.txt @@ -931,6 +925,18 @@ set(TESHSUITE_CMAKEFILES_TXT teshsuite/xbt/CMakeLists.txt ) +if(SMPI_F2C) + set(TESHSUITE_CMAKEFILES_TXT + ${TESHSUITE_CMAKEFILES_TXT} + teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt + teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt + ) +endif() + set(TOOLS_CMAKEFILES_TXT tools/CMakeLists.txt tools/graphicator/CMakeLists.txt diff --git a/buildtools/Cmake/MakeExe.cmake b/buildtools/Cmake/MakeExe.cmake index f56dc002ed..fac59a6a1c 100644 --- a/buildtools/Cmake/MakeExe.cmake +++ b/buildtools/Cmake/MakeExe.cmake @@ -85,12 +85,6 @@ add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/simdag/network/p2p) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/simdag/partask) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/simdag/platforms) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi) -#add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich-test) -#add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich-test/coll) -#add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich-test/context) -#add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich-test/env) -#add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich-test/profile) -#add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich-test/pt2pt) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/attr) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/comm) @@ -99,8 +93,13 @@ add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/datatype) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/group) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/init) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/pt2pt) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/comm) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/coll) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/pt2pt) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/ext) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/datatype) +add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/smpi/mpich3-test/f77/init) add_subdirectory(${CMAKE_HOME_DIRECTORY}/teshsuite/xbt) - add_subdirectory(${CMAKE_HOME_DIRECTORY}/testsuite/surf) add_subdirectory(${CMAKE_HOME_DIRECTORY}/testsuite/xbt) diff --git a/include/smpi/mpif.h b/include/smpi/mpif.h index aabde41d59..690380e673 100644 --- a/include/smpi/mpif.h +++ b/include/smpi/mpif.h @@ -18,7 +18,9 @@ integer MPI_MAX_DATAREP_STRIN, MPI_MAX_INFO_KEY integer MPI_MAX_INFO_VAL, MPI_MAX_OBJECT_NAME, MPI_MAX_PORT_NAME integer MPI_ANY_SOURCE, MPI_PROC_NULL, MPI_ANY_TAG, MPI_UNDEFINED - integer MPI_IN_PLACE, MPI_TAG_UB, MPI_TAG_LB + integer MPI_IN_PLACE, MPI_BOTTOM, MPI_TAG_UB, MPI_TAG_LB + integer MPI_SOURCE, MPI_TAG, MPI_ERROR + integer MPI_VERSION, MPI_SUBVERSION parameter(MPI_MAX_PROCESSOR_NAME=100) parameter(MPI_MAX_ERROR_STRING=100) parameter(MPI_MAX_DATAREP_STRIN =100) @@ -31,13 +33,20 @@ parameter(MPI_ANY_TAG=-444) parameter(MPI_UNDEFINED=-333) parameter(MPI_IN_PLACE=-222) + parameter(MPI_BOTTOM=-111) + parameter(MPI_SOURCE=1) + parameter(MPI_TAG=2) + parameter(MPI_ERROR=3) parameter(MPI_TAG_UB=0) parameter(MPI_TAG_LB=0) + parameter(MPI_VERSION=1) + parameter(MPI_SUBVERSION=1) integer MPI_SUCCESS, MPI_ERR_COMM, MPI_ERR_ARG, MPI_ERR_TYPE integer MPI_ERR_REQUEST, MPI_ERR_INTERN, MPI_ERR_COUNT integer MPI_ERR_RANK, MPI_ERR_OTHER, MPI_ERR_UNKNOWN integer MPI_ERR_TAG, MPI_ERR_TRUNCATE, MPI_ERR_GROUP, MPI_ERR_OP + integer MPI_LASTUSEDCODE, MPI_ERR_LASTCODE integer MPI_IDENT, MPI_SIMILAR, MPI_UNEQUAL, MPI_CONGRUENT integer MPI_WTIME_IS_GLOBAL parameter(MPI_SUCCESS=0) @@ -54,22 +63,51 @@ parameter(MPI_ERR_OP=11) parameter(MPI_ERR_OTHER=12) parameter(MPI_ERR_UNKNOWN=13) + parameter(MPI_LASTUSEDCODE=0) + parameter(MPI_ERR_LASTCODE=0) parameter(MPI_IDENT=0) parameter(MPI_SIMILAR=1) parameter(MPI_UNEQUAL=2) parameter(MPI_CONGRUENT=3) parameter(MPI_WTIME_IS_GLOBAL=1) + integer MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN + parameter(MPI_NULL_COPY_FN =0) + parameter(MPI_NULL_DELETE_FN =0) + integer MPI_COMM_NULL_COPY_FN, MPI_COMM_NULL_DELETE_FN + parameter(MPI_COMM_NULL_COPY_FN =0) + parameter(MPI_COMM_NULL_DELETE_FN =0) + integer MPI_COMM_NULL_DUP_FN, MPI_COMM_DUP_FN + parameter(MPI_COMM_NULL_DUP_FN =0) + parameter(MPI_COMM_DUP_FN =0) + integer MPI_APPNUM, MPI_HOST, MPI_IO + parameter(MPI_APPNUM=0) + parameter(MPI_HOST=0) + parameter(MPI_IO=0) + integer MPI_ROOT, MPI_INFO_NULL,MPI_COMM_TYPE_SHARED + parameter(MPI_ROOT=0) + parameter(MPI_INFO_NULL=-1) + parameter(MPI_COMM_TYPE_SHARED=1) + ! These should be ordered as in smpi_f77.c integer MPI_COMM_NULL, MPI_COMM_WORLD, MPI_COMM_SELF + integer MPI_UNIVERSE_SIZE parameter(MPI_COMM_NULL=-1) parameter(MPI_COMM_SELF=-2) parameter(MPI_COMM_WORLD=0) + parameter(MPI_UNIVERSE_SIZE=0) + integer MPI_GROUP_NULL, MPI_GROUP_EMPTY parameter(MPI_GROUP_NULL=-1) parameter(MPI_GROUP_EMPTY=-2) + integer MPI_ERRORS_RETURN, MPI_ERRORS_ARE_FATAL + integer MPI_ERRHANDLER_NULL + parameter(MPI_ERRORS_RETURN=0) + parameter(MPI_ERRORS_ARE_FATAL=1) + parameter(MPI_ERRHANDLER_NULL=2) + ! This should be equal to the number of int fields in MPI_Status integer MPI_STATUS_SIZE, MPI_STATUSES_IGNORE parameter(MPI_STATUS_SIZE=4) @@ -88,6 +126,8 @@ integer MPI_DOUBLE_PRECISION, MPI_COMPLEX, MPI_DOUBLE_COMPLEX integer MPI_2INTEGER, MPI_LOGICAL1, MPI_LOGICAL2, MPI_LOGICAL4 integer MPI_LOGICAL8, MPI_2REAL, MPI_2DOUBLE_PRECISION + integer MPI_AINT, MPI_OFFSET, MPI_COUNT + integer MPI_REAL16, MPI_COMPLEX8,MPI_COMPLEX16,MPI_COMPLEX32 parameter(MPI_DATATYPE_NULL=-1) parameter(MPI_BYTE=0) parameter(MPI_CHARACTER=1) @@ -110,6 +150,15 @@ parameter(MPI_LOGICAL8=18) parameter(MPI_2REAL=19) parameter(MPI_2DOUBLE_PRECISION=19) + parameter(MPI_AINT=20) + parameter(MPI_OFFSET=21) + parameter(MPI_COUNT=22) + parameter(MPI_REAL16=23) + parameter(MPI_COMPLEX8=24) + parameter(MPI_COMPLEX16=25) + parameter(MPI_COMPLEX32=26) + + ! These should be ordered as in smpi_f77.c integer MPI_OP_NULL,MPI_MAX, MPI_MIN, MPI_MAXLOC, MPI_MINLOC @@ -136,6 +185,41 @@ INTEGER MPI_MODE_NOPRECEDE PARAMETER (MPI_MODE_NOPRECEDE=8192) + integer MPI_COMBINER_NAMED, MPI_COMBINER_DUP + integer MPI_COMBINER_CONTIGUOUS, MPI_COMBINER_VECTOR + integer MPI_COMBINER_HVECTOR_INTEGER, MPI_COMBINER_HVECTOR + integer MPI_COMBINER_INDEXED, MPI_COMBINER_HINDEXED_INTEGER + integer MPI_COMBINER_HINDEXED, MPI_COMBINER_INDEXED_BLOCK + integer MPI_COMBINER_STRUCT_INTEGER, MPI_COMBINER_STRUCT + integer MPI_COMBINER_SUBARRAY, MPI_COMBINER_DARRAY + integer MPI_COMBINER_F90_REAL, MPI_COMBINER_F90_COMPLEX + integer MPI_COMBINER_F90_INTEGER, MPI_COMBINER_RESIZED + integer MPI_COMBINER_HINDEXED_BLOCK + + parameter( MPI_COMBINER_NAMED=0) + parameter( MPI_COMBINER_DUP=1) + parameter( MPI_COMBINER_CONTIGUOUS=2) + parameter( MPI_COMBINER_VECTOR=3) + parameter( MPI_COMBINER_HVECTOR_INTEGER=4) + parameter( MPI_COMBINER_HVECTOR=5) + parameter( MPI_COMBINER_INDEXED=6) + parameter( MPI_COMBINER_HINDEXED_INTEGER=7) + parameter( MPI_COMBINER_HINDEXED=8) + parameter( MPI_COMBINER_INDEXED_BLOCK=9) + parameter( MPI_COMBINER_STRUCT_INTEGER=10) + parameter( MPI_COMBINER_STRUCT=11) + parameter( MPI_COMBINER_SUBARRAY=12) + parameter( MPI_COMBINER_DARRAY=13) + parameter( MPI_COMBINER_F90_REAL=14) + parameter( MPI_COMBINER_F90_COMPLEX=15) + parameter( MPI_COMBINER_F90_INTEGER=16) + parameter( MPI_COMBINER_RESIZED=17) + parameter( MPI_COMBINER_HINDEXED_BLOCK=18) + + integer MPI_ORDER_C, MPI_ORDER_FORTRAN + parameter(MPI_ORDER_C=1) + parameter(MPI_ORDER_FORTRAN=0) + external MPI_INIT, MPI_FINALIZE, MPI_ABORT external MPI_COMM_RANK, MPI_COMM_SIZE, MPI_COMM_DUP, MPI_COMM_SPLIT external MPI_SEND_INIT, MPI_ISEND, MPI_SEND diff --git a/include/smpi/smpi.h b/include/smpi/smpi.h index 9cff118109..1eebe9fbec 100644 --- a/include/smpi/smpi.h +++ b/include/smpi/smpi.h @@ -41,10 +41,13 @@ SG_BEGIN_DECL() #define SMPI_RAND_SEED 5 #define MPI_ANY_SOURCE -555 #define MPI_BOTTOM (void *)-111 +#define MPI_FORTRAN_BOTTOM -111 #define MPI_PROC_NULL -666 #define MPI_ANY_TAG -444 #define MPI_UNDEFINED -333 #define MPI_IN_PLACE (void *)-222 +#define MPI_FORTRAN_IN_PLACE -222 + // errorcodes #define MPI_SUCCESS 0 #define MPI_ERR_COMM 1 @@ -212,6 +215,7 @@ XBT_PUBLIC_DATA(MPI_Datatype) MPI_2DOUBLE; //for now we only send int values at max #define MPI_Count int #define MPI_COUNT MPI_INT + typedef void MPI_User_function(void *invec, void *inoutvec, int *len, MPI_Datatype * datatype); struct s_smpi_mpi_op; @@ -250,6 +254,7 @@ struct s_smpi_mpi_request; typedef struct s_smpi_mpi_request *MPI_Request; #define MPI_REQUEST_NULL NULL +#define MPI_FORTRAN_REQUEST_NULL -1 MPI_CALL(XBT_PUBLIC(int), MPI_Init, (int *argc, char ***argv)); MPI_CALL(XBT_PUBLIC(int), MPI_Finalize, (void)); @@ -279,6 +284,9 @@ MPI_CALL(XBT_PUBLIC(int), MPI_Type_commit, (MPI_Datatype* datatype)); MPI_CALL(XBT_PUBLIC(int), MPI_Type_hindexed, (int count, int* blocklens, MPI_Aint* indices, MPI_Datatype old_type, MPI_Datatype* newtype)); +MPI_CALL(XBT_PUBLIC(int), MPI_Type_create_hindexed, + (int count, int* blocklens, MPI_Aint* indices, + MPI_Datatype old_type, MPI_Datatype* newtype)); MPI_CALL(XBT_PUBLIC(int), MPI_Type_create_hindexed_block, (int count, int blocklength, MPI_Aint* indices, MPI_Datatype old_type, MPI_Datatype* newtype)); @@ -291,6 +299,9 @@ MPI_CALL(XBT_PUBLIC(int), MPI_Type_create_hvector, MPI_CALL(XBT_PUBLIC(int), MPI_Type_indexed, (int count, int* blocklens, int* indices, MPI_Datatype old_type, MPI_Datatype* newtype)); +MPI_CALL(XBT_PUBLIC(int), MPI_Type_create_indexed, + (int count, int* blocklens, int* indices, + MPI_Datatype old_type, MPI_Datatype* newtype)); MPI_CALL(XBT_PUBLIC(int), MPI_Type_create_indexed_block, (int count, int blocklength, int* indices, MPI_Datatype old_type, MPI_Datatype* newtype)); diff --git a/src/smpi/private.h b/src/smpi/private.h index 651841cdd0..0a63808f69 100644 --- a/src/smpi/private.h +++ b/src/smpi/private.h @@ -98,6 +98,9 @@ void smpi_process_init(int *argc, char ***argv); void smpi_process_destroy(void); void smpi_process_finalize(void); int smpi_process_finalized(void); +int smpi_process_initialized(void); +void smpi_process_mark_as_initialized(void); + smpi_process_data_t smpi_process_data(void); smpi_process_data_t smpi_process_remote_data(int index); @@ -388,6 +391,158 @@ void mpi_sendrecv_(void* sendbuf, int* sendcount, int* sendtype, int* dst, int* recvtype, int* src, int* recvtag, int* comm, MPI_Status* status, int* ierr); +void mpi_finalized_ (int * flag, int* ierr); +void mpi_init_thread_ (int *required, int *provided, int* ierr); +void mpi_query_thread_ (int *provided, int* ierr); +void mpi_is_thread_main_ (int *flag, int* ierr); +void mpi_address_ (void *location, MPI_Aint * address, int* ierr); +void mpi_get_address_ (void *location, MPI_Aint * address, int* ierr); +void mpi_type_dup_ (int* datatype, int* newdatatype, int* ierr); +void mpi_type_set_name_ (int* datatype, char * name, int* ierr); +void mpi_type_get_name_ (int* datatype, char * name, int* len, int* ierr); +void mpi_type_get_attr_ (int* type, int* type_keyval, void *attribute_val, int* flag, int* ierr); +void mpi_type_set_attr_ (int* type, int* type_keyval, void *attribute_val, int* ierr); +void mpi_type_delete_attr_ (int* type, int* type_keyval, int* ierr); +void mpi_type_create_keyval_ (void* copy_fn, void* delete_fn, int* keyval, void* extra_state, int* ierr); +void mpi_type_free_keyval_ (int* keyval, int* ierr) ; +void mpi_pcontrol_ (int* level , int* ierr); +void mpi_type_get_extent_ (int* datatype, MPI_Aint * lb, MPI_Aint * extent, int* ierr); +void mpi_type_get_true_extent_ (int* datatype, MPI_Aint * lb, MPI_Aint * extent, int* ierr); +void mpi_op_create_ (void * function, int* commute, int* op, int* ierr); +void mpi_op_free_ (int* op, int* ierr); +void mpi_group_free_ (int* group, int* ierr); +void mpi_group_size_ (int* group, int *size, int* ierr); +void mpi_group_rank_ (int* group, int *rank, int* ierr); +void mpi_group_translate_ranks_ (int* group1, int* n, int *ranks1, int* group2, int *ranks2, int* ierr); +void mpi_group_compare_ (int* group1, int* group2, int *result, int* ierr); +void mpi_group_union_ (int* group1, int* group2, int* newgroup, int* ierr); +void mpi_group_intersection_ (int* group1, int* group2, int* newgroup, int* ierr); +void mpi_group_difference_ (int* group1, int* group2, int* newgroup, int* ierr); +void mpi_group_excl_ (int* group, int* n, int *ranks, int* newgroup, int* ierr); +void mpi_group_range_incl_ (int* group, int* n, int ranges[][3], int* newgroup, int* ierr); +void mpi_group_range_excl_ (int* group, int* n, int ranges[][3], int* newgroup, int* ierr); +void mpi_comm_get_attr_ (int* comm, int* comm_keyval, void *attribute_val, int *flag, int* ierr); +void mpi_comm_set_attr_ (int* comm, int* comm_keyval, void *attribute_val, int* ierr); +void mpi_comm_delete_attr_ (int* comm, int* comm_keyval, int* ierr); +void mpi_comm_create_keyval_ (void* copy_fn, void* delete_fn, int* keyval, void* extra_state, int* ierr); +void mpi_comm_free_keyval_ (int* keyval, int* ierr) ; +void mpi_comm_get_name_ (int* comm, char* name, int* len, int* ierr); +void mpi_comm_compare_ (int* comm1, int* comm2, int *result, int* ierr); +void mpi_comm_disconnect_ (int* comm, int* ierr); +void mpi_request_free_ (int* request, int* ierr); +void mpi_sendrecv_replace_ (void *buf, int* count, int* datatype, int* dst, int* sendtag, int* src, int* recvtag, + int* comm, MPI_Status* status, int* ierr); +void mpi_testany_ (int* count, int* requests, int *index, int *flag, MPI_Status* status, int* ierr); +void mpi_waitsome_ (int* incount, int* requests, int *outcount, int *indices, MPI_Status* status, int* ierr); +void mpi_reduce_local_ (void *inbuf, void *inoutbuf, int* count, int* datatype, int* op, int* ierr); +void mpi_reduce_scatter_block_ (void *sendbuf, void *recvbuf, int* recvcount, int* datatype, int* op, int* comm, int* ierr); +void mpi_pack_size_ (int* incount, int* datatype, int* comm, int* size, int* ierr) ; +void mpi_cart_coords_ (int* comm, int* rank, int* maxdims, int* coords, int* ierr) ; +void mpi_cart_create_ (int* comm_old, int* ndims, int* dims, int* periods, int* reorder, int* comm_cart, int* ierr) ; +void mpi_cart_get_ (int* comm, int* maxdims, int* dims, int* periods, int* coords, int* ierr) ; +void mpi_cart_map_ (int* comm_old, int* ndims, int* dims, int* periods, int* newrank, int* ierr) ; +void mpi_cart_rank_ (int* comm, int* coords, int* rank, int* ierr) ; +void mpi_cart_shift_ (int* comm, int* direction, int* displ, int* source, int* dest, int* ierr) ; +void mpi_cart_sub_ (int* comm, int* remain_dims, int* comm_new, int* ierr) ; +void mpi_cartdim_get_ (int* comm, int* ndims, int* ierr) ; +void mpi_graph_create_ (int* comm_old, int* nnodes, int* index, int* edges, int* reorder, int* comm_graph, int* ierr) ; +void mpi_graph_get_ (int* comm, int* maxindex, int* maxedges, int* index, int* edges, int* ierr) ; +void mpi_graph_map_ (int* comm_old, int* nnodes, int* index, int* edges, int* newrank, int* ierr) ; +void mpi_graph_neighbors_ (int* comm, int* rank, int* maxneighbors, int* neighbors, int* ierr) ; +void mpi_graph_neighbors_count_ (int* comm, int* rank, int* nneighbors, int* ierr) ; +void mpi_graphdims_get_ (int* comm, int* nnodes, int* nedges, int* ierr) ; +void mpi_topo_test_ (int* comm, int* top_type, int* ierr) ; +void mpi_error_class_ (int* errorcode, int* errorclass, int* ierr) ; +void mpi_errhandler_create_ (void* function, void* errhandler, int* ierr) ; +void mpi_errhandler_free_ (void* errhandler, int* ierr) ; +void mpi_errhandler_get_ (int* comm, void* errhandler, int* ierr) ; +void mpi_errhandler_set_ (int* comm, void* errhandler, int* ierr) ; +void mpi_comm_set_errhandler_ (int* comm, void* errhandler, int* ierr) ; +void mpi_type_contiguous_ (int* count, int* old_type, int* newtype, int* ierr) ; +void mpi_cancel_ (int* request, int* ierr) ; +void mpi_buffer_attach_ (void* buffer, int* size, int* ierr) ; +void mpi_buffer_detach_ (void* buffer, int* size, int* ierr) ; +void mpi_testsome_ (int* incount, int* requests, int* outcount, int* indices, MPI_Status* statuses, int* ierr) ; +void mpi_comm_test_inter_ (int* comm, int* flag, int* ierr) ; +void mpi_unpack_ (void* inbuf, int* insize, int* position, void* outbuf, int* outcount, int* type, int* comm, int* ierr) ; +void mpi_pack_external_size_ (char *datarep, int* incount, int* datatype, MPI_Aint *size, int* ierr); +void mpi_pack_external_ (char *datarep, void *inbuf, int* incount, int* datatype, void *outbuf, MPI_Aint* outcount, MPI_Aint *position, int* ierr); +void mpi_unpack_external_ ( char *datarep, void *inbuf, MPI_Aint* insize, MPI_Aint *position, void *outbuf, int* outcount, int* datatype, int* ierr); +void mpi_type_hindexed_ (int* count, int* blocklens, MPI_Aint* indices, int* old_type, int* newtype, int* ierr) ; +void mpi_type_create_hindexed_ (int* count, int* blocklens, MPI_Aint* indices, int* old_type, int* newtype, int* ierr) ; +void mpi_type_create_hindexed_block_ (int* count, int* blocklength, MPI_Aint* indices, int* old_type, int* newtype, int* ierr) ; +void mpi_type_indexed_ (int* count, int* blocklens, int* indices, int* old_type, int* newtype, int* ierr) ; +void mpi_type_create_indexed_block_ (int* count, int* blocklength, int* indices, int* old_type, int*newtype, int* ierr); +void mpi_type_struct_ (int* count, int* blocklens, MPI_Aint* indices, int* old_types, int* newtype, int* ierr) ; +void mpi_type_create_struct_ (int* count, int* blocklens, MPI_Aint* indices, int* old_types, int* newtype, int* ierr) ; +void mpi_ssend_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* ierr) ; +void mpi_ssend_init_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* request, int* ierr) ; +void mpi_intercomm_create_ (int* local_comm, int* local_leader, int* peer_comm, int* remote_leader, int* tag, int* comm_out, int* ierr) ; +void mpi_intercomm_merge_ (int* comm, int* high, int* comm_out, int* ierr) ; +void mpi_bsend_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* ierr) ; +void mpi_bsend_init_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* request, int* ierr) ; +void mpi_ibsend_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* request, int* ierr) ; +void mpi_comm_remote_group_ (int* comm, int* group, int* ierr) ; +void mpi_comm_remote_size_ (int* comm, int* size, int* ierr) ; +void mpi_issend_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* request, int* ierr) ; +void mpi_probe_ (int* source, int* tag, int* comm, MPI_Status* status, int* ierr) ; +void mpi_attr_delete_ (int* comm, int* keyval, int* ierr) ; +void mpi_attr_put_ (int* comm, int* keyval, void* attr_value, int* ierr) ; +void mpi_rsend_init_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* request, int* ierr) ; +void mpi_keyval_create_ (void* copy_fn, void* delete_fn, int* keyval, void* extra_state, int* ierr) ; +void mpi_keyval_free_ (int* keyval, int* ierr) ; +void mpi_test_cancelled_ (MPI_Status* status, int* flag, int* ierr) ; +void mpi_pack_ (void* inbuf, int* incount, int* type, void* outbuf, int* outcount, int* position, int* comm, int* ierr) ; +void mpi_get_elements_ (MPI_Status* status, int* datatype, int* elements, int* ierr) ; +void mpi_dims_create_ (int* nnodes, int* ndims, int* dims, int* ierr) ; +void mpi_iprobe_ (int* source, int* tag, int* comm, int* flag, MPI_Status* status, int* ierr) ; +void mpi_type_get_envelope_ ( int* datatype, int *num_integers, int *num_addresses, int *num_datatypes, int *combiner, int* ierr); +void mpi_type_get_contents_ (int* datatype, int* max_integers, int* max_addresses, int* max_datatypes, int* array_of_integers, MPI_Aint* array_of_addresses, + int*array_of_datatypes, int* ierr); +void mpi_type_create_darray_ (int* size, int* rank, int* ndims, int* array_of_gsizes, int* array_of_distribs, int* array_of_dargs, int* array_of_psizes, + int* order, int* oldtype, int*newtype, int* ierr) ; +void mpi_type_create_resized_ (int* oldtype,MPI_Aint* lb, MPI_Aint* extent, int*newtype, int* ierr); +void mpi_type_create_subarray_ (int* ndims,int *array_of_sizes, int *array_of_subsizes, int *array_of_starts, int* order, int* oldtype, int*newtype, int* ierr); +void mpi_type_match_size_ (int* typeclass,int* size,int*datatype, int* ierr); +void mpi_alltoallw_ ( void *sendbuf, int *sendcnts, int *sdispls, int*sendtypes, void *recvbuf, int *recvcnts, int *rdispls, int*recvtypes, + int* comm, int* ierr); +void mpi_exscan_ (void *sendbuf, void *recvbuf, int* count, int* datatype, int* op, int* comm, int* ierr); +void mpi_comm_set_name_ (int* comm, char* name, int* ierr); +void mpi_comm_dup_with_info_ (int* comm, int* info, int* newcomm, int* ierr); +void mpi_comm_split_type_ (int* comm, int* split_type, int* key, int* info, int*newcomm, int* ierr); +void mpi_comm_set_info_ (int* comm, int* info, int* ierr); +void mpi_comm_get_info_ (int* comm, int* info, int* ierr); +void mpi_info_get_ (int* info,char *key,int* valuelen, char *value, int *flag, int* ierr); +void mpi_comm_create_errhandler_ ( void *function, void *errhandler, int* ierr); +void mpi_add_error_class_ ( int *errorclass, int* ierr); +void mpi_add_error_code_ ( int* errorclass, int *errorcode, int* ierr); +void mpi_add_error_string_ ( int* errorcode, char *string, int* ierr); +void mpi_comm_call_errhandler_ (int* comm,int* errorcode, int* ierr); +void mpi_info_dup_ (int* info, int* newinfo, int* ierr); +void mpi_info_get_valuelen_ ( int* info, char *key, int *valuelen, int *flag, int* ierr); +void mpi_info_delete_ (int* info, char *key, int* ierr); +void mpi_info_get_nkeys_ ( int* info, int *nkeys, int* ierr); +void mpi_info_get_nthkey_ ( int* info, int* n, char *key, int* ierr); +void mpi_get_version_ (int *version,int *subversion, int* ierr); +void mpi_get_library_version_ (char *version,int *len, int* ierr); +void mpi_request_get_status_ ( int* request, int *flag, MPI_Status* status, int* ierr); +void mpi_grequest_start_ ( void *query_fn, void *free_fn, void *cancel_fn, void *extra_state, int*request, int* ierr); +void mpi_grequest_complete_ ( int* request, int* ierr); +void mpi_status_set_cancelled_ (MPI_Status* status,int* flag, int* ierr); +void mpi_status_set_elements_ ( MPI_Status* status, int* datatype, int* count, int* ierr); +void mpi_comm_connect_ ( char *port_name, int* info, int* root, int* comm, int* newcomm, int* ierr); +void mpi_publish_name_ ( char *service_name, int* info, char *port_name, int* ierr); +void mpi_unpublish_name_ ( char *service_name, int* info, char *port_name, int* ierr); +void mpi_lookup_name_ ( char *service_name, int* info, char *port_name, int* ierr); +void mpi_comm_join_ ( int* fd, int*intercomm, int* ierr); +void mpi_open_port_ ( int* info, char *port_name, int* ierr); +void mpi_close_port_ ( char *port_name, int* ierr); +void mpi_comm_accept_ ( char *port_name, int* info, int* root, int* comm, int* newcomm, int* ierr); +void mpi_comm_spawn_ ( char *command, char *argv, int* maxprocs, int* info, int* root, int* comm, int*intercomm, int* array_of_errcodes, int* ierr); +void mpi_comm_spawn_multiple_ ( int* count, char *array_of_commands, char** array_of_argv, int* array_of_maxprocs, int* array_of_info, int* root, + int* comm, int*intercomm, int* array_of_errcodes, int* ierr); +void mpi_comm_get_parent_ ( int*parent, int* ierr); + /********** Tracing **********/ /* from smpi_instr.c */ void TRACE_internal_smpi_set_category (const char *category); diff --git a/src/smpi/smpi_base.c b/src/smpi/smpi_base.c index 88e93074d0..f114a57aa1 100644 --- a/src/smpi/smpi_base.c +++ b/src/smpi/smpi_base.c @@ -676,6 +676,8 @@ int smpi_mpi_testall(int count, MPI_Request requests[], if(requests[i]!= MPI_REQUEST_NULL){ if (smpi_mpi_test(&requests[i], pstat)!=1){ flag=0; + }else{ + requests[i]=MPI_REQUEST_NULL; } }else{ smpi_empty_status(pstat); @@ -752,7 +754,7 @@ void smpi_mpi_wait(MPI_Request * request, MPI_Status * status) simcall_comm_wait((*request)->action, -1.0); } finish_wait(request, status); - + request=MPI_REQUEST_NULL; // FIXME for a detached send, finish_wait is not called: } @@ -881,7 +883,7 @@ int smpi_mpi_testsome(int incount, MPI_Request requests[], int *indices, for(i = 0; i < incount; i++) { if((requests[i] != MPI_REQUEST_NULL)) { if(smpi_mpi_test(&requests[i], pstat)) { - indices[count] = i; + indices[i] = 1; count++; if(status != MPI_STATUSES_IGNORE) { status[i] = *pstat; diff --git a/src/smpi/smpi_f77.c b/src/smpi/smpi_f77.c index 56fefc8e99..dbd1895a8e 100644 --- a/src/smpi/smpi_f77.c +++ b/src/smpi/smpi_f77.c @@ -13,100 +13,152 @@ extern int xargc; extern char** xargv; -static xbt_dynar_t comm_lookup = NULL; -static xbt_dynar_t group_lookup = NULL; +static xbt_dict_t comm_lookup = NULL; +static xbt_dict_t group_lookup = NULL; static xbt_dict_t request_lookup = NULL; -static xbt_dynar_t datatype_lookup = NULL; -static xbt_dynar_t op_lookup = NULL; +static xbt_dict_t datatype_lookup = NULL; +static xbt_dict_t op_lookup = NULL; +static int running_processes = 0; + + + +/* Convert between Fortran and C MPI_BOTTOM */ +#define F2C_BOTTOM(addr) ((addr!=MPI_IN_PLACE && *(int*)addr == MPI_FORTRAN_BOTTOM) ? MPI_BOTTOM : (addr)) +#define F2C_IN_PLACE(addr) ((addr!=MPI_BOTTOM &&*(int*)addr == MPI_FORTRAN_IN_PLACE) ? MPI_IN_PLACE : (addr)) #define KEY_SIZE (sizeof(int) * 2 + 1) + +static char* get_key(char* key, int id) { + snprintf(key, KEY_SIZE, "%x",id); + return key; +} +static char* get_key_id(char* key, int id) { + snprintf(key, KEY_SIZE, "%x_%d",id, smpi_process_index()); + return key; +} + static int new_comm(MPI_Comm comm) { - xbt_dynar_push(comm_lookup, &comm); - return (int)xbt_dynar_length(comm_lookup) - 1; + static int comm_id = 0; + char key[KEY_SIZE]; + xbt_dict_set(comm_lookup, comm==MPI_COMM_WORLD? get_key(key, comm_id) : get_key_id(key, comm_id), comm, NULL); + comm_id++; + return comm_id-1; } static void free_comm(int comm) { - xbt_dynar_remove_at(comm_lookup, comm, NULL); + char key[KEY_SIZE]; + xbt_dict_remove(comm_lookup, comm==0? get_key(key, comm) : get_key_id(key, comm)); } static MPI_Comm get_comm(int comm) { if(comm == -2) { return MPI_COMM_SELF; - } else if(comm_lookup && comm >= 0 && comm < (int)xbt_dynar_length(comm_lookup)) { - return *(MPI_Comm*)xbt_dynar_get_ptr(comm_lookup, comm); + }else if(comm==0){ + return MPI_COMM_WORLD; + } else if(comm_lookup && comm >= 0) { + + char key[KEY_SIZE]; + MPI_Comm tmp = (MPI_Comm)xbt_dict_get_or_null(comm_lookup,get_key_id(key, comm)); + return tmp != NULL ? tmp : MPI_COMM_NULL ; } return MPI_COMM_NULL; } static int new_group(MPI_Group group) { - xbt_dynar_push(group_lookup, &group); - return (int)xbt_dynar_length(group_lookup) - 1; + static int group_id = 0; + char key[KEY_SIZE]; + xbt_dict_set(group_lookup, get_key(key, group_id), group, NULL); + group_id++; + return group_id-1; } static MPI_Group get_group(int group) { if(group == -2) { return MPI_GROUP_EMPTY; - } else if(group_lookup && group >= 0 && group < (int)xbt_dynar_length(group_lookup)) { - return *(MPI_Group*)xbt_dynar_get_ptr(group_lookup, group); + } else if(group_lookup && group >= 0) { + char key[KEY_SIZE]; + return (MPI_Group)xbt_dict_get_or_null(group_lookup, get_key(key, group)); } - return MPI_COMM_NULL; + return MPI_GROUP_NULL; } -static char* get_key(char* key, int id) { - snprintf(key, KEY_SIZE, "%x", id); - return key; +static void free_group(int group) { + char key[KEY_SIZE]; + xbt_dict_remove(group_lookup, get_key(key, group)); } + + static int new_request(MPI_Request req) { static int request_id = INT_MIN; char key[KEY_SIZE]; - - xbt_dict_set(request_lookup, get_key(key, request_id), req, NULL); - return request_id++; + xbt_dict_set(request_lookup, get_key_id(key, request_id), req, NULL); + request_id++; + return request_id-1; } static MPI_Request find_request(int req) { char key[KEY_SIZE]; - - return (MPI_Request)xbt_dict_get(request_lookup, get_key(key, req)); + if(req==MPI_FORTRAN_REQUEST_NULL)return MPI_REQUEST_NULL; + return (MPI_Request)xbt_dict_get(request_lookup, get_key_id(key, req)); +} + +static void free_request(int request) { + char key[KEY_SIZE]; + if(request!=MPI_FORTRAN_REQUEST_NULL) + xbt_dict_remove(request_lookup, get_key_id(key, request)); } static int new_datatype(MPI_Datatype datatype) { - xbt_dynar_push(datatype_lookup, &datatype); - return (int)xbt_dynar_length(datatype_lookup) - 1; + static int datatype_id = 0; + char key[KEY_SIZE]; + xbt_dict_set(datatype_lookup, get_key(key, datatype_id), datatype, NULL); + datatype_id++; + return datatype_id-1; } static MPI_Datatype get_datatype(int datatype) { + char key[KEY_SIZE]; return datatype >= 0 - ? *(MPI_Datatype*)xbt_dynar_get_ptr(datatype_lookup, datatype) + ? (MPI_Datatype)xbt_dict_get_or_null(datatype_lookup, get_key(key, datatype)) : MPI_DATATYPE_NULL; } static void free_datatype(int datatype) { - xbt_dynar_remove_at(datatype_lookup, datatype, NULL); + char key[KEY_SIZE]; + xbt_dict_remove(datatype_lookup, get_key(key, datatype)); } static int new_op(MPI_Op op) { - xbt_dynar_push(op_lookup, &op); - return (int)xbt_dynar_length(op_lookup) - 1; + static int op_id = 0; + char key[KEY_SIZE]; + xbt_dict_set(op_lookup, get_key(key, op_id), op, NULL); + op_id++; + return op_id-1; } static MPI_Op get_op(int op) { + char key[KEY_SIZE]; return op >= 0 - ? *(MPI_Op*)xbt_dynar_get_ptr(op_lookup, op) + ? (MPI_Op)xbt_dict_get_or_null(op_lookup, get_key(key, op)) : MPI_OP_NULL; } +static void free_op(int op) { + char key[KEY_SIZE]; + xbt_dict_remove(op_lookup, get_key(key, op)); +} + void mpi_init_(int* ierr) { if(!comm_lookup){ - comm_lookup = xbt_dynar_new(sizeof(MPI_Comm), NULL); + comm_lookup = xbt_dict_new_homogeneous(NULL); new_comm(MPI_COMM_WORLD); - group_lookup = xbt_dynar_new(sizeof(MPI_Group), NULL); + group_lookup = xbt_dict_new_homogeneous(NULL); request_lookup = xbt_dict_new_homogeneous(NULL); - datatype_lookup = xbt_dynar_new(sizeof(MPI_Datatype), NULL); + datatype_lookup = xbt_dict_new_homogeneous(NULL); new_datatype(MPI_BYTE); new_datatype(MPI_CHAR); new_datatype(MPI_INT); @@ -128,9 +180,14 @@ void mpi_init_(int* ierr) { new_datatype(MPI_UINT64_T); new_datatype(MPI_2FLOAT); new_datatype(MPI_2DOUBLE); - - - op_lookup = xbt_dynar_new(sizeof(MPI_Op), NULL); + new_datatype(MPI_DOUBLE); + new_datatype(MPI_DOUBLE); + new_datatype(MPI_INT); + new_datatype(MPI_DATATYPE_NULL); + new_datatype(MPI_DATATYPE_NULL); + new_datatype(MPI_DATATYPE_NULL); + new_datatype(MPI_DATATYPE_NULL); + op_lookup = xbt_dict_new_homogeneous(NULL); new_op(MPI_MAX); new_op(MPI_MIN); new_op(MPI_MAXLOC); @@ -146,18 +203,22 @@ void mpi_init_(int* ierr) { } /* smpif2c is responsible for generating a call with the final arguments */ *ierr = MPI_Init(NULL, NULL); + running_processes++; } void mpi_finalize_(int* ierr) { *ierr = MPI_Finalize(); - xbt_dynar_free(&op_lookup); - op_lookup = NULL; - xbt_dynar_free(&datatype_lookup); - datatype_lookup = NULL; - xbt_dict_free(&request_lookup); - request_lookup = NULL; - xbt_dynar_free(&comm_lookup); - comm_lookup = NULL; + running_processes--; + if(running_processes==0){ + xbt_dict_free(&op_lookup); + op_lookup = NULL; + xbt_dict_free(&datatype_lookup); + datatype_lookup = NULL; + xbt_dict_free(&request_lookup); + request_lookup = NULL; + xbt_dict_free(&comm_lookup); + comm_lookup = NULL; + } } void mpi_abort_(int* comm, int* errorcode, int* ierr) { @@ -255,7 +316,7 @@ void mpi_send_init_(void *buf, int* count, int* datatype, int* dst, int* tag, void mpi_isend_(void *buf, int* count, int* datatype, int* dst, int* tag, int* comm, int* request, int* ierr) { MPI_Request req; - + buf = (char *) F2C_BOTTOM(buf); *ierr = MPI_Isend(buf, *count, get_datatype(*datatype), *dst, *tag, get_comm(*comm), &req); if(*ierr == MPI_SUCCESS) { @@ -266,7 +327,7 @@ void mpi_isend_(void *buf, int* count, int* datatype, int* dst, void mpi_irsend_(void *buf, int* count, int* datatype, int* dst, int* tag, int* comm, int* request, int* ierr) { MPI_Request req; - + buf = (char *) F2C_BOTTOM(buf); *ierr = MPI_Irsend(buf, *count, get_datatype(*datatype), *dst, *tag, get_comm(*comm), &req); if(*ierr == MPI_SUCCESS) { @@ -309,7 +370,7 @@ void mpi_recv_init_(void *buf, int* count, int* datatype, int* src, int* tag, void mpi_irecv_(void *buf, int* count, int* datatype, int* src, int* tag, int* comm, int* request, int* ierr) { MPI_Request req; - + buf = (char *) F2C_BOTTOM(buf); *ierr = MPI_Irecv(buf, *count, get_datatype(*datatype), *src, *tag, get_comm(*comm), &req); if(*ierr == MPI_SUCCESS) { @@ -345,6 +406,10 @@ void mpi_wait_(int* request, MPI_Status* status, int* ierr) { MPI_Request req = find_request(*request); *ierr = MPI_Wait(&req, status); + if(req==MPI_REQUEST_NULL){ + free_request(*request); + *request=MPI_FORTRAN_REQUEST_NULL; + } } void mpi_waitany_(int* count, int* requests, int* index, MPI_Status* status, int* ierr) { @@ -356,6 +421,10 @@ void mpi_waitany_(int* count, int* requests, int* index, MPI_Status* status, int reqs[i] = find_request(requests[i]); } *ierr = MPI_Waitany(*count, reqs, index, status); + if(reqs[*index]==MPI_REQUEST_NULL){ + free_request(requests[*index]); + requests[*index]=MPI_FORTRAN_REQUEST_NULL; + } free(reqs); } @@ -368,6 +437,13 @@ void mpi_waitall_(int* count, int* requests, MPI_Status* status, int* ierr) { reqs[i] = find_request(requests[i]); } *ierr = MPI_Waitall(*count, reqs, status); + for(i = 0; i < *count; i++) { + if(reqs[i]==MPI_REQUEST_NULL){ + free_request(requests[i]); + requests[i]=MPI_FORTRAN_REQUEST_NULL; + } + } + free(reqs); } @@ -381,18 +457,23 @@ void mpi_bcast_(void *buf, int* count, int* datatype, int* root, int* comm, int* void mpi_reduce_(void* sendbuf, void* recvbuf, int* count, int* datatype, int* op, int* root, int* comm, int* ierr) { + sendbuf = (char *) F2C_IN_PLACE(sendbuf); + sendbuf = (char *) F2C_BOTTOM(sendbuf); + recvbuf = (char *) F2C_BOTTOM(recvbuf); *ierr = MPI_Reduce(sendbuf, recvbuf, *count, get_datatype(*datatype), get_op(*op), *root, get_comm(*comm)); } void mpi_allreduce_(void* sendbuf, void* recvbuf, int* count, int* datatype, int* op, int* comm, int* ierr) { + sendbuf = (char *) F2C_IN_PLACE(sendbuf); *ierr = MPI_Allreduce(sendbuf, recvbuf, *count, get_datatype(*datatype), get_op(*op), get_comm(*comm)); } void mpi_reduce_scatter_(void* sendbuf, void* recvbuf, int* recvcounts, int* datatype, int* op, int* comm, int* ierr) { + sendbuf = (char *) F2C_IN_PLACE(sendbuf); *ierr = MPI_Reduce_scatter(sendbuf, recvbuf, recvcounts, get_datatype(*datatype), get_op(*op), get_comm(*comm)); } @@ -400,6 +481,7 @@ void mpi_reduce_scatter_(void* sendbuf, void* recvbuf, int* recvcounts, int* dat void mpi_scatter_(void* sendbuf, int* sendcount, int* sendtype, void* recvbuf, int* recvcount, int* recvtype, int* root, int* comm, int* ierr) { + recvbuf = (char *) F2C_IN_PLACE(recvbuf); *ierr = MPI_Scatter(sendbuf, *sendcount, get_datatype(*sendtype), recvbuf, *recvcount, get_datatype(*recvtype), *root, get_comm(*comm)); } @@ -408,6 +490,7 @@ void mpi_scatter_(void* sendbuf, int* sendcount, int* sendtype, void mpi_scatterv_(void* sendbuf, int* sendcounts, int* displs, int* sendtype, void* recvbuf, int* recvcount, int* recvtype, int* root, int* comm, int* ierr) { + recvbuf = (char *) F2C_IN_PLACE(recvbuf); *ierr = MPI_Scatterv(sendbuf, sendcounts, displs, get_datatype(*sendtype), recvbuf, *recvcount, get_datatype(*recvtype), *root, get_comm(*comm)); } @@ -415,6 +498,9 @@ void mpi_scatterv_(void* sendbuf, int* sendcounts, int* displs, int* sendtype, void mpi_gather_(void* sendbuf, int* sendcount, int* sendtype, void* recvbuf, int* recvcount, int* recvtype, int* root, int* comm, int* ierr) { + sendbuf = (char *) F2C_IN_PLACE(sendbuf); + sendbuf = (char *) F2C_BOTTOM(sendbuf); + recvbuf = (char *) F2C_BOTTOM(recvbuf); *ierr = MPI_Gather(sendbuf, *sendcount, get_datatype(*sendtype), recvbuf, *recvcount, get_datatype(*recvtype), *root, get_comm(*comm)); } @@ -422,6 +508,9 @@ void mpi_gather_(void* sendbuf, int* sendcount, int* sendtype, void mpi_gatherv_(void* sendbuf, int* sendcount, int* sendtype, void* recvbuf, int* recvcounts, int* displs, int* recvtype, int* root, int* comm, int* ierr) { + sendbuf = (char *) F2C_IN_PLACE(sendbuf); + sendbuf = (char *) F2C_BOTTOM(sendbuf); + recvbuf = (char *) F2C_BOTTOM(recvbuf); *ierr = MPI_Gatherv(sendbuf, *sendcount, get_datatype(*sendtype), recvbuf, recvcounts, displs, get_datatype(*recvtype), *root, get_comm(*comm)); } @@ -429,6 +518,7 @@ void mpi_gatherv_(void* sendbuf, int* sendcount, int* sendtype, void mpi_allgather_(void* sendbuf, int* sendcount, int* sendtype, void* recvbuf, int* recvcount, int* recvtype, int* comm, int* ierr) { + sendbuf = (char *) F2C_IN_PLACE(sendbuf); *ierr = MPI_Allgather(sendbuf, *sendcount, get_datatype(*sendtype), recvbuf, *recvcount, get_datatype(*recvtype), get_comm(*comm)); } @@ -436,6 +526,7 @@ void mpi_allgather_(void* sendbuf, int* sendcount, int* sendtype, void mpi_allgatherv_(void* sendbuf, int* sendcount, int* sendtype, void* recvbuf, int* recvcounts,int* displs, int* recvtype, int* comm, int* ierr) { + sendbuf = (char *) F2C_IN_PLACE(sendbuf); *ierr = MPI_Allgatherv(sendbuf, *sendcount, get_datatype(*sendtype), recvbuf, recvcounts, displs, get_datatype(*recvtype), get_comm(*comm)); } @@ -461,6 +552,10 @@ void mpi_alltoallv_(void* sendbuf, int* sendcounts, int* senddisps, int* sendtyp void mpi_test_ (int * request, int *flag, MPI_Status * status, int* ierr){ MPI_Request req = find_request(*request); *ierr= MPI_Test(&req, flag, status); + if(req==MPI_REQUEST_NULL){ + free_request(*request); + *request=MPI_FORTRAN_REQUEST_NULL; + } } @@ -472,6 +567,12 @@ void mpi_testall_ (int* count, int * requests, int *flag, MPI_Status * statuses reqs[i] = find_request(requests[i]); } *ierr= MPI_Testall(*count, reqs, flag, statuses); + for(i = 0; i < *count; i++) { + if(reqs[i]==MPI_REQUEST_NULL){ + free_request(requests[i]); + requests[i]=MPI_FORTRAN_REQUEST_NULL; + } + } } @@ -582,3 +683,902 @@ void mpi_get_( int *origin_addr, int* origin_count, int* origin_datatype, int *t *ierr = MPI_Get( (void*)origin_addr,*origin_count, get_datatype(*origin_datatype),*target_rank, *target_disp, *target_count,get_datatype(*target_datatype), *(MPI_Win *)win); } + + +//following are automatically generated, and have to be checked +void mpi_finalized_ (int * flag, int* ierr){ + + *ierr = MPI_Finalized(flag); +} + +void mpi_init_thread_ (int* required, int *provided, int* ierr){ + if(!comm_lookup){ + comm_lookup = xbt_dict_new_homogeneous(NULL); + new_comm(MPI_COMM_WORLD); + group_lookup = xbt_dict_new_homogeneous(NULL); + + request_lookup = xbt_dict_new_homogeneous(NULL); + + datatype_lookup = xbt_dict_new_homogeneous(NULL); + new_datatype(MPI_BYTE); + new_datatype(MPI_CHAR); + new_datatype(MPI_INT); + new_datatype(MPI_INT); + new_datatype(MPI_INT8_T); + new_datatype(MPI_INT16_T); + new_datatype(MPI_INT32_T); + new_datatype(MPI_INT64_T); + new_datatype(MPI_FLOAT); + new_datatype(MPI_FLOAT); + new_datatype(MPI_DOUBLE); + new_datatype(MPI_DOUBLE); + new_datatype(MPI_C_FLOAT_COMPLEX); + new_datatype(MPI_C_DOUBLE_COMPLEX); + new_datatype(MPI_2INT); + new_datatype(MPI_UINT8_T); + new_datatype(MPI_UINT16_T); + new_datatype(MPI_UINT32_T); + new_datatype(MPI_UINT64_T); + new_datatype(MPI_2FLOAT); + new_datatype(MPI_2DOUBLE); + + op_lookup = xbt_dict_new_homogeneous( NULL); + new_op(MPI_MAX); + new_op(MPI_MIN); + new_op(MPI_MAXLOC); + new_op(MPI_MINLOC); + new_op(MPI_SUM); + new_op(MPI_PROD); + new_op(MPI_LAND); + new_op(MPI_LOR); + new_op(MPI_LXOR); + new_op(MPI_BAND); + new_op(MPI_BOR); + new_op(MPI_BXOR); + } + /* smpif2c is responsible for generating a call with the final arguments */ + *ierr = MPI_Init_thread(NULL, NULL,*required, provided); +} + +void mpi_query_thread_ (int *provided, int* ierr){ + + *ierr = MPI_Query_thread(provided); +} + +void mpi_is_thread_main_ (int *flag, int* ierr){ + + *ierr = MPI_Is_thread_main(flag); +} + +void mpi_address_ (void *location, MPI_Aint * address, int* ierr){ + + *ierr = MPI_Address(location, address); +} + +void mpi_get_address_ (void *location, MPI_Aint * address, int* ierr){ + + *ierr = MPI_Get_address(location, address); +} + +void mpi_type_dup_ (int* datatype, int* newdatatype, int* ierr){ + MPI_Datatype tmp; + *ierr = MPI_Type_dup(get_datatype(*datatype), &tmp); + if(*ierr == MPI_SUCCESS) { + *newdatatype = new_datatype(tmp); + } +} + +void mpi_type_set_name_ (int* datatype, char * name, int* ierr){ + + *ierr = MPI_Type_set_name(get_datatype(*datatype), name); +} + +void mpi_type_get_name_ (int* datatype, char * name, int* len, int* ierr){ + + *ierr = MPI_Type_get_name(get_datatype(*datatype),name,len); +} + +void mpi_type_get_attr_ (int* type, int* type_keyval, void *attribute_val, int* flag, int* ierr){ + + *ierr = MPI_Type_get_attr ( get_datatype(*type), *type_keyval, attribute_val,flag); +} + +void mpi_type_set_attr_ (int* type, int* type_keyval, void *attribute_val, int* ierr){ + + *ierr = MPI_Type_set_attr ( get_datatype(*type), *type_keyval, attribute_val); +} + +void mpi_type_delete_attr_ (int* type, int* type_keyval, int* ierr){ + + *ierr = MPI_Type_delete_attr ( get_datatype(*type), *type_keyval); +} + +void mpi_type_create_keyval_ (void* copy_fn, void* delete_fn, int* keyval, void* extra_state, int* ierr){ + + *ierr = MPI_Type_create_keyval((MPI_Type_copy_attr_function*)copy_fn, (MPI_Type_delete_attr_function*) delete_fn, keyval, extra_state) ; +} + +void mpi_type_free_keyval_ (int* keyval, int* ierr) { + *ierr = MPI_Type_free_keyval( keyval); +} + +void mpi_pcontrol_ (int* level , int* ierr){ + *ierr = MPI_Pcontrol(*(const int*)level); +} + +void mpi_type_get_extent_ (int* datatype, MPI_Aint * lb, MPI_Aint * extent, int* ierr){ + + *ierr = MPI_Type_get_extent(get_datatype(*datatype), lb, extent); +} + +void mpi_type_get_true_extent_ (int* datatype, MPI_Aint * lb, MPI_Aint * extent, int* ierr){ + + *ierr = MPI_Type_get_true_extent(get_datatype(*datatype), lb, extent); +} + +void mpi_op_create_ (void * function, int* commute, int* op, int* ierr){ + MPI_Op tmp; + *ierr = MPI_Op_create((MPI_User_function*)function,* commute, &tmp); + if(*ierr == MPI_SUCCESS) { + *op = new_op(tmp); + } +} + +void mpi_op_free_ (int* op, int* ierr){ + MPI_Op tmp=get_op(*op); + *ierr = MPI_Op_free(& tmp); + if(*ierr == MPI_SUCCESS) { + free_op(*op); + } +} + +void mpi_group_free_ (int* group, int* ierr){ + MPI_Group tmp=get_group(*group); + *ierr = MPI_Group_free(&tmp); + if(*ierr == MPI_SUCCESS) { + free_group(*group); + } +} + +void mpi_group_size_ (int* group, int *size, int* ierr){ + + *ierr = MPI_Group_size(get_group(*group), size); +} + +void mpi_group_rank_ (int* group, int *rank, int* ierr){ + + *ierr = MPI_Group_rank(get_group(*group), rank); +} + +void mpi_group_translate_ranks_ (int* group1, int* n, int *ranks1, int* group2, int *ranks2, int* ierr) +{ + + *ierr = MPI_Group_translate_ranks(get_group(*group1), *n, ranks1, get_group(*group2), ranks2); +} + +void mpi_group_compare_ (int* group1, int* group2, int *result, int* ierr){ + + *ierr = MPI_Group_compare(get_group(*group1), get_group(*group2), result); +} + +void mpi_group_union_ (int* group1, int* group2, int* newgroup, int* ierr){ + MPI_Group tmp; + *ierr = MPI_Group_union(get_group(*group1), get_group(*group2), &tmp); + if(*ierr == MPI_SUCCESS) { + *newgroup = new_group(tmp); + } +} + +void mpi_group_intersection_ (int* group1, int* group2, int* newgroup, int* ierr){ + MPI_Group tmp; + *ierr = MPI_Group_intersection(get_group(*group1), get_group(*group2), &tmp); + if(*ierr == MPI_SUCCESS) { + *newgroup = new_group(tmp); + } +} + +void mpi_group_difference_ (int* group1, int* group2, int* newgroup, int* ierr){ + MPI_Group tmp; + *ierr = MPI_Group_difference(get_group(*group1), get_group(*group2), &tmp); + if(*ierr == MPI_SUCCESS) { + *newgroup = new_group(tmp); + } +} + +void mpi_group_excl_ (int* group, int* n, int *ranks, int* newgroup, int* ierr){ + MPI_Group tmp; + *ierr = MPI_Group_excl(get_group(*group), *n, ranks, &tmp); + if(*ierr == MPI_SUCCESS) { + *newgroup = new_group(tmp); + } +} + +void mpi_group_range_incl_ (int* group, int* n, int ranges[][3], int* newgroup, int* ierr) +{ + MPI_Group tmp; + *ierr = MPI_Group_range_incl(get_group(*group), *n, ranges, &tmp); + if(*ierr == MPI_SUCCESS) { + *newgroup = new_group(tmp); + } +} + +void mpi_group_range_excl_ (int* group, int* n, int ranges[][3], int* newgroup, int* ierr) +{ + MPI_Group tmp; + *ierr = MPI_Group_range_excl(get_group(*group), *n, ranges, &tmp); + if(*ierr == MPI_SUCCESS) { + *newgroup = new_group(tmp); + } +} + +void mpi_comm_get_attr_ (int* comm, int* comm_keyval, void *attribute_val, int *flag, int* ierr){ + + *ierr = MPI_Comm_get_attr (get_comm(*comm), *comm_keyval, attribute_val, flag); +} + +void mpi_comm_set_attr_ (int* comm, int* comm_keyval, void *attribute_val, int* ierr){ + + *ierr = MPI_Comm_set_attr ( get_comm(*comm), *comm_keyval, attribute_val); +} + +void mpi_comm_delete_attr_ (int* comm, int* comm_keyval, int* ierr){ + + *ierr = MPI_Comm_delete_attr (get_comm(*comm), *comm_keyval); +} + +void mpi_comm_create_keyval_ (void* copy_fn, void* delete_fn, int* keyval, void* extra_state, int* ierr){ + + *ierr = MPI_Comm_create_keyval((MPI_Comm_copy_attr_function*)copy_fn, (MPI_Comm_delete_attr_function*)delete_fn, keyval, extra_state) ; +} + +void mpi_comm_free_keyval_ (int* keyval, int* ierr) { + *ierr = MPI_Comm_free_keyval( keyval); +} + +void mpi_comm_get_name_ (int* comm, char* name, int* len, int* ierr){ + + *ierr = MPI_Comm_get_name(get_comm(*comm), name, len); +} + +void mpi_comm_compare_ (int* comm1, int* comm2, int *result, int* ierr){ + + *ierr = MPI_Comm_compare(get_comm(*comm1), get_comm(*comm2), result); +} + +void mpi_comm_disconnect_ (int* comm, int* ierr){ + MPI_Comm tmp=get_comm(*comm); + *ierr = MPI_Comm_disconnect(&tmp); + if(*ierr == MPI_SUCCESS) { + free_comm(*comm); + } +} + +void mpi_request_free_ (int* request, int* ierr){ + MPI_Request tmp=find_request(*request); + *ierr = MPI_Request_free(&tmp); + if(*ierr == MPI_SUCCESS) { + free_request(*request); + } +} + +void mpi_sendrecv_replace_ (void *buf, int* count, int* datatype, int* dst, int* sendtag, int* src, int* recvtag, + int* comm, MPI_Status* status, int* ierr) +{ + + *ierr = MPI_Sendrecv_replace(buf, *count, get_datatype(*datatype), *dst, *sendtag, *src, + *recvtag, get_comm(*comm), status); +} + +void mpi_testany_ (int* count, int* requests, int *index, int *flag, MPI_Status* status, int* ierr) +{ + MPI_Request* reqs; + int i; + + reqs = xbt_new(MPI_Request, *count); + for(i = 0; i < *count; i++) { + reqs[i] = find_request(requests[i]); + } + *ierr = MPI_Testany(*count, reqs, index, flag, status); + if(*index!=MPI_UNDEFINED) + if(reqs[*index]==MPI_REQUEST_NULL){ + free_request(requests[*index]); + requests[*index]=MPI_FORTRAN_REQUEST_NULL; + } + free(reqs); +} + +void mpi_waitsome_ (int* incount, int* requests, int *outcount, int *indices, MPI_Status* status, int* ierr) +{ + MPI_Request* reqs; + int i; + + reqs = xbt_new(MPI_Request, *incount); + for(i = 0; i < *incount; i++) { + reqs[i] = find_request(requests[i]); + } + *ierr = MPI_Waitsome(*incount, reqs, outcount, indices, status); + for(i=0;i<*outcount;i++){ + if(reqs[indices[i]]==MPI_REQUEST_NULL){ + free_request(requests[indices[i]]); + requests[indices[i]]=MPI_FORTRAN_REQUEST_NULL; + } + } + free(reqs); +} + +void mpi_reduce_local_ (void *inbuf, void *inoutbuf, int* count, int* datatype, int* op, int* ierr){ + + *ierr = MPI_Reduce_local(inbuf, inoutbuf, *count, get_datatype(*datatype), get_op(*op)); +} + +void mpi_reduce_scatter_block_ (void *sendbuf, void *recvbuf, int* recvcount, int* datatype, int* op, int* comm, int* ierr) +{ + sendbuf = (char *) F2C_IN_PLACE(sendbuf); + *ierr = MPI_Reduce_scatter_block(sendbuf, recvbuf, *recvcount, get_datatype(*datatype), get_op(*op), get_comm(*comm)); +} + +void mpi_pack_size_ (int* incount, int* datatype, int* comm, int* size, int* ierr) { + *ierr = MPI_Pack_size(*incount, get_datatype(*datatype), get_comm(*comm), size); +} + +void mpi_cart_coords_ (int* comm, int* rank, int* maxdims, int* coords, int* ierr) { + *ierr = MPI_Cart_coords(get_comm(*comm), *rank, *maxdims, coords); +} + +void mpi_cart_create_ (int* comm_old, int* ndims, int* dims, int* periods, int* reorder, int* comm_cart, int* ierr) { + MPI_Comm tmp; + *ierr = MPI_Cart_create(get_comm(*comm_old), *ndims, dims, periods, *reorder, &tmp); + if(*ierr == MPI_SUCCESS) { + *comm_cart = new_comm(tmp); + } +} + +void mpi_cart_get_ (int* comm, int* maxdims, int* dims, int* periods, int* coords, int* ierr) { + *ierr = MPI_Cart_get(get_comm(*comm), *maxdims, dims, periods, coords); +} + +void mpi_cart_map_ (int* comm_old, int* ndims, int* dims, int* periods, int* newrank, int* ierr) { + *ierr = MPI_Cart_map(get_comm(*comm_old), *ndims, dims, periods, newrank); +} + +void mpi_cart_rank_ (int* comm, int* coords, int* rank, int* ierr) { + *ierr = MPI_Cart_rank(get_comm(*comm), coords, rank); +} + +void mpi_cart_shift_ (int* comm, int* direction, int* displ, int* source, int* dest, int* ierr) { + *ierr = MPI_Cart_shift(get_comm(*comm), *direction, *displ, source, dest); +} + +void mpi_cart_sub_ (int* comm, int* remain_dims, int* comm_new, int* ierr) { + MPI_Comm tmp; + *ierr = MPI_Cart_sub(get_comm(*comm), remain_dims, &tmp); + if(*ierr == MPI_SUCCESS) { + *comm_new = new_comm(tmp); + } +} + +void mpi_cartdim_get_ (int* comm, int* ndims, int* ierr) { + *ierr = MPI_Cartdim_get(get_comm(*comm), ndims); +} + +void mpi_graph_create_ (int* comm_old, int* nnodes, int* index, int* edges, int* reorder, int* comm_graph, int* ierr) { + MPI_Comm tmp; + *ierr = MPI_Graph_create(get_comm(*comm_old), *nnodes, index, edges, *reorder, &tmp); + if(*ierr == MPI_SUCCESS) { + *comm_graph = new_comm(tmp); + } +} + +void mpi_graph_get_ (int* comm, int* maxindex, int* maxedges, int* index, int* edges, int* ierr) { + *ierr = MPI_Graph_get(get_comm(*comm), *maxindex, *maxedges, index, edges); +} + +void mpi_graph_map_ (int* comm_old, int* nnodes, int* index, int* edges, int* newrank, int* ierr) { + *ierr = MPI_Graph_map(get_comm(*comm_old), *nnodes, index, edges, newrank); +} + +void mpi_graph_neighbors_ (int* comm, int* rank, int* maxneighbors, int* neighbors, int* ierr) { + *ierr = MPI_Graph_neighbors(get_comm(*comm), *rank, *maxneighbors, neighbors); +} + +void mpi_graph_neighbors_count_ (int* comm, int* rank, int* nneighbors, int* ierr) { + *ierr = MPI_Graph_neighbors_count(get_comm(*comm), *rank, nneighbors); +} + +void mpi_graphdims_get_ (int* comm, int* nnodes, int* nedges, int* ierr) { + *ierr = MPI_Graphdims_get(get_comm(*comm), nnodes, nedges); +} + +void mpi_topo_test_ (int* comm, int* top_type, int* ierr) { + *ierr = MPI_Topo_test(get_comm(*comm), top_type); +} + +void mpi_error_class_ (int* errorcode, int* errorclass, int* ierr) { + *ierr = MPI_Error_class(*errorcode, errorclass); +} + +void mpi_errhandler_create_ (void* function, void* errhandler, int* ierr) { + *ierr = MPI_Errhandler_create((MPI_Handler_function*)function, (MPI_Errhandler*)errhandler); +} + +void mpi_errhandler_free_ (void* errhandler, int* ierr) { + *ierr = MPI_Errhandler_free((MPI_Errhandler*)errhandler); +} + +void mpi_errhandler_get_ (int* comm, void* errhandler, int* ierr) { + *ierr = MPI_Errhandler_get(get_comm(*comm), (MPI_Errhandler*) errhandler); +} + +void mpi_errhandler_set_ (int* comm, void* errhandler, int* ierr) { + *ierr = MPI_Errhandler_set(get_comm(*comm), *(MPI_Errhandler*)errhandler); +} + +void mpi_comm_set_errhandler_ (int* comm, void* errhandler, int* ierr) { + *ierr = MPI_Errhandler_set(get_comm(*comm), *(MPI_Errhandler*)errhandler); +} + +void mpi_type_contiguous_ (int* count, int* old_type, int* newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_contiguous(*count, get_datatype(*old_type), &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_cancel_ (int* request, int* ierr) { + MPI_Request tmp=find_request(*request); + *ierr = MPI_Cancel(&tmp); + if(*ierr == MPI_SUCCESS) { + free_request(*request); + } +} + +void mpi_buffer_attach_ (void* buffer, int* size, int* ierr) { + *ierr = MPI_Buffer_attach(buffer, *size); +} + +void mpi_buffer_detach_ (void* buffer, int* size, int* ierr) { + *ierr = MPI_Buffer_detach(buffer, size); +} + +void mpi_testsome_ (int* incount, int* requests, int* outcount, int* indices, MPI_Status* statuses, int* ierr) { + MPI_Request* reqs; + int i; + + reqs = xbt_new(MPI_Request, *incount); + for(i = 0; i < *incount; i++) { + reqs[i] = find_request(requests[i]); + indices[i]=0; + } + *ierr = MPI_Testsome(*incount, reqs, outcount, indices, statuses); + for(i=0;i<*incount;i++){ + if(indices[i]){ + if(reqs[indices[i]]==MPI_REQUEST_NULL){ + free_request(requests[indices[i]]); + requests[indices[i]]=MPI_FORTRAN_REQUEST_NULL; + } + } + } + free(reqs); +} + +void mpi_comm_test_inter_ (int* comm, int* flag, int* ierr) { + *ierr = MPI_Comm_test_inter(get_comm(*comm), flag); +} + +void mpi_unpack_ (void* inbuf, int* insize, int* position, void* outbuf, int* outcount, int* type, int* comm, int* ierr) { + *ierr = MPI_Unpack(inbuf, *insize, position, outbuf, *outcount, get_datatype(*type), get_comm(*comm)); +} + +void mpi_pack_external_size_ (char *datarep, int* incount, int* datatype, MPI_Aint *size, int* ierr){ + *ierr = MPI_Pack_external_size(datarep, *incount, get_datatype(*datatype), size); +} + +void mpi_pack_external_ (char *datarep, void *inbuf, int* incount, int* datatype, void *outbuf, MPI_Aint* outcount, MPI_Aint *position, int* ierr){ + *ierr = MPI_Pack_external(datarep, inbuf, *incount, get_datatype(*datatype), outbuf, *outcount, position); +} + +void mpi_unpack_external_ ( char *datarep, void *inbuf, MPI_Aint* insize, MPI_Aint *position, void *outbuf, int* outcount, int* datatype, int* ierr){ + *ierr = MPI_Unpack_external( datarep, inbuf, *insize, position, outbuf, *outcount, get_datatype(*datatype)); +} + +void mpi_type_hindexed_ (int* count, int* blocklens, MPI_Aint* indices, int* old_type, int* newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_hindexed(*count, blocklens, indices, get_datatype(*old_type), &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_create_hindexed_ (int* count, int* blocklens, MPI_Aint* indices, int* old_type, int* newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_create_hindexed(*count, blocklens, indices, get_datatype(*old_type), &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_create_hindexed_block_ (int* count, int* blocklength, MPI_Aint* indices, int* old_type, int* newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_create_hindexed_block(*count, *blocklength, indices, get_datatype(*old_type), &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_indexed_ (int* count, int* blocklens, int* indices, int* old_type, int* newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_indexed(*count, blocklens, indices, get_datatype(*old_type), &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_create_indexed_block_ (int* count, int* blocklength, int* indices, int* old_type, int*newtype, int* ierr){ + MPI_Datatype tmp; + *ierr = MPI_Type_create_indexed_block(*count, *blocklength, indices, get_datatype(*old_type), &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_struct_ (int* count, int* blocklens, MPI_Aint* indices, int* old_types, int* newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_struct(*count, blocklens, indices, (MPI_Datatype*)old_types, &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_create_struct_ (int* count, int* blocklens, MPI_Aint* indices, int* old_types, int* newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_create_struct(*count, blocklens, indices, (MPI_Datatype*)old_types, &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_ssend_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* ierr) { + *ierr = MPI_Ssend(buf, *count, get_datatype(*datatype), *dest, *tag, get_comm(*comm)); +} + +void mpi_ssend_init_ (void* buf, int* count, int* datatype, int* dest, int* tag, int* comm, int* request, int* ierr) { + MPI_Request tmp; + *ierr = MPI_Ssend_init(buf, *count, get_datatype(*datatype), *dest, *tag, get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *request = new_request(tmp); + } +} + +void mpi_intercomm_create_ (int* local_comm, int *local_leader, int* peer_comm, int* remote_leader, int* tag, int* comm_out, int* ierr) { + MPI_Comm tmp; + *ierr = MPI_Intercomm_create(get_comm(*local_comm), *local_leader,get_comm(*peer_comm), *remote_leader, *tag, &tmp); + if(*ierr == MPI_SUCCESS) { + *comm_out = new_comm(tmp); + } +} + +void mpi_intercomm_merge_ (int* comm, int* high, int* comm_out, int* ierr) { + MPI_Comm tmp; + *ierr = MPI_Intercomm_merge(get_comm(*comm), *high, &tmp); + if(*ierr == MPI_SUCCESS) { + *comm_out = new_comm(tmp); + } +} + +void mpi_bsend_ (void* buf, int* count, int* datatype, int *dest, int* tag, int* comm, int* ierr) { + *ierr = MPI_Bsend(buf, *count, get_datatype(*datatype), *dest, *tag, get_comm(*comm)); +} + +void mpi_bsend_init_ (void* buf, int* count, int* datatype, int *dest, int* tag, int* comm, int* request, int* ierr) { + MPI_Request tmp; + *ierr = MPI_Bsend_init(buf, *count, get_datatype(*datatype), *dest, *tag, get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *request = new_request(tmp); + } +} + +void mpi_ibsend_ (void* buf, int* count, int* datatype, int *dest, int* tag, int* comm, int* request, int* ierr) { + MPI_Request tmp; + *ierr = MPI_Ibsend(buf, *count, get_datatype(*datatype), *dest, *tag, get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *request = new_request(tmp); + } +} + +void mpi_comm_remote_group_ (int* comm, int* group, int* ierr) { + MPI_Group tmp; + *ierr = MPI_Comm_remote_group(get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *group = new_group(tmp); + } +} + +void mpi_comm_remote_size_ (int* comm, int* size, int* ierr) { + *ierr = MPI_Comm_remote_size(get_comm(*comm), size); +} + +void mpi_issend_ (void* buf, int* count, int* datatype, int *dest, int* tag, int* comm, int* request, int* ierr) { + MPI_Request tmp; + *ierr = MPI_Issend(buf, *count, get_datatype(*datatype), *dest, *tag, get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *request = new_request(tmp); + } +} + +void mpi_probe_ (int* source, int* tag, int* comm, MPI_Status* status, int* ierr) { + *ierr = MPI_Probe(*source, *tag, get_comm(*comm), status); +} + +void mpi_attr_delete_ (int* comm, int* keyval, int* ierr) { + *ierr = MPI_Attr_delete(get_comm(*comm), *keyval); +} + +void mpi_attr_put_ (int* comm, int* keyval, void* attr_value, int* ierr) { + *ierr = MPI_Attr_put(get_comm(*comm), *keyval, attr_value); +} + +void mpi_rsend_init_ (void* buf, int* count, int* datatype, int *dest, int* tag, int* comm, int* request, int* ierr) { + MPI_Request tmp; + *ierr = MPI_Rsend_init(buf, *count, get_datatype(*datatype), *dest, *tag, get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *request = new_request(tmp); + } +} + +void mpi_keyval_create_ (void* copy_fn, void* delete_fn, int* keyval, void* extra_state, int* ierr) { + *ierr = MPI_Keyval_create((MPI_Copy_function*)copy_fn, (MPI_Delete_function*)delete_fn, keyval, extra_state); +} + +void mpi_keyval_free_ (int* keyval, int* ierr) { + *ierr = MPI_Keyval_free(keyval); +} + +void mpi_test_cancelled_ (MPI_Status* status, int* flag, int* ierr) { + *ierr = MPI_Test_cancelled(status, flag); +} + +void mpi_pack_ (void* inbuf, int* incount, int* type, void* outbuf, int* outcount, int* position, int* comm, int* ierr) { + *ierr = MPI_Pack(inbuf, *incount, get_datatype(*type), outbuf, *outcount, position, get_comm(*comm)); +} + +void mpi_get_elements_ (MPI_Status* status, int* datatype, int* elements, int* ierr) { + *ierr = MPI_Get_elements(status, get_datatype(*datatype), elements); +} + +void mpi_dims_create_ (int* nnodes, int* ndims, int* dims, int* ierr) { + *ierr = MPI_Dims_create(*nnodes, *ndims, dims); +} + +void mpi_iprobe_ (int* source, int* tag, int* comm, int* flag, MPI_Status* status, int* ierr) { + *ierr = MPI_Iprobe(*source, *tag, get_comm(*comm), flag, status); +} + +void mpi_type_get_envelope_ ( int* datatype, int *num_integers, int *num_addresses, int *num_datatypes, int *combiner, int* ierr){ + + *ierr = MPI_Type_get_envelope( get_datatype(*datatype), num_integers, + num_addresses, num_datatypes, combiner); +} + +void mpi_type_get_contents_ (int* datatype, int* max_integers, int* max_addresses, int* max_datatypes, int* array_of_integers, MPI_Aint* array_of_addresses, + int* array_of_datatypes, int* ierr){ + *ierr = MPI_Type_get_contents(get_datatype(*datatype), *max_integers, *max_addresses,*max_datatypes, array_of_integers, array_of_addresses, (MPI_Datatype*)array_of_datatypes); +} + +void mpi_type_create_darray_ (int* size, int* rank, int* ndims, int* array_of_gsizes, int* array_of_distribs, int* array_of_dargs, int* array_of_psizes, + int* order, int* oldtype, int*newtype, int* ierr) { + MPI_Datatype tmp; + *ierr = MPI_Type_create_darray(*size, *rank, *ndims, array_of_gsizes, + array_of_distribs, array_of_dargs, array_of_psizes, + *order, get_datatype(*oldtype), &tmp) ; + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_create_resized_ (int* oldtype,MPI_Aint* lb, MPI_Aint* extent, int*newtype, int* ierr){ + MPI_Datatype tmp; + *ierr = MPI_Type_create_resized(get_datatype(*oldtype),*lb, *extent, &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_create_subarray_ (int* ndims,int *array_of_sizes, int *array_of_subsizes, int *array_of_starts, int* order, int* oldtype, int*newtype, int* ierr){ + MPI_Datatype tmp; + *ierr = MPI_Type_create_subarray(*ndims,array_of_sizes, array_of_subsizes, array_of_starts, *order, get_datatype(*oldtype), &tmp); + if(*ierr == MPI_SUCCESS) { + *newtype = new_datatype(tmp); + } +} + +void mpi_type_match_size_ (int* typeclass,int* size,int* datatype, int* ierr){ + MPI_Datatype tmp; + *ierr = MPI_Type_match_size(*typeclass,*size,&tmp); + if(*ierr == MPI_SUCCESS) { + *datatype = new_datatype(tmp); + } +} + +void mpi_alltoallw_ ( void *sendbuf, int *sendcnts, int *sdispls, int* sendtypes, void *recvbuf, int *recvcnts, int *rdispls, int* recvtypes, + int* comm, int* ierr){ + *ierr = MPI_Alltoallw( sendbuf, sendcnts, sdispls, (MPI_Datatype*) sendtypes, recvbuf, recvcnts, rdispls, (MPI_Datatype*)recvtypes, get_comm(*comm)); +} + +void mpi_exscan_ (void *sendbuf, void *recvbuf, int* count, int* datatype, int* op, int* comm, int* ierr){ + *ierr = MPI_Exscan(sendbuf, recvbuf, *count, get_datatype(*datatype), get_op(*op), get_comm(*comm)); +} + +void mpi_comm_set_name_ (int* comm, char* name, int* ierr){ + *ierr = MPI_Comm_set_name (get_comm(*comm), name); +} + +void mpi_comm_dup_with_info_ (int* comm, int* info, int* newcomm, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_dup_with_info(get_comm(*comm),*(MPI_Info*)info,&tmp); + if(*ierr == MPI_SUCCESS) { + *newcomm = new_comm(tmp); + } +} + +void mpi_comm_split_type_ (int* comm, int* split_type, int* key, int* info, int* newcomm, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_split_type(get_comm(*comm), *split_type, *key, *(MPI_Info*)info, &tmp); + if(*ierr == MPI_SUCCESS) { + *newcomm = new_comm(tmp); + } +} + +void mpi_comm_set_info_ (int* comm, int* info, int* ierr){ + *ierr = MPI_Comm_set_info (get_comm(*comm), *(MPI_Info*)info); +} + +void mpi_comm_get_info_ (int* comm, int* info, int* ierr){ + *ierr = MPI_Comm_get_info (get_comm(*comm), (MPI_Info*)info); +} + +void mpi_info_get_ (int* info,char *key,int* valuelen, char *value, int *flag, int* ierr){ + *ierr = MPI_Info_get(*(MPI_Info*)info,key,*valuelen, value, flag); +} + +void mpi_comm_create_errhandler_ ( void *function, void *errhandler, int* ierr){ + *ierr = MPI_Comm_create_errhandler( (MPI_Comm_errhandler_fn*) function, (MPI_Errhandler*)errhandler); +} + +void mpi_add_error_class_ ( int *errorclass, int* ierr){ + *ierr = MPI_Add_error_class( errorclass); +} + +void mpi_add_error_code_ ( int* errorclass, int *errorcode, int* ierr){ + *ierr = MPI_Add_error_code(*errorclass, errorcode); +} + +void mpi_add_error_string_ ( int* errorcode, char *string, int* ierr){ + *ierr = MPI_Add_error_string(*errorcode, string); +} + +void mpi_comm_call_errhandler_ (int* comm,int* errorcode, int* ierr){ + *ierr = MPI_Comm_call_errhandler(get_comm(*comm), *errorcode); +} + +void mpi_info_dup_ (int* info, int* newinfo, int* ierr){ + *ierr = MPI_Info_dup(*(MPI_Info*)info, (MPI_Info*)newinfo); +} + +void mpi_info_get_valuelen_ ( int* info, char *key, int *valuelen, int *flag, int* ierr){ + *ierr = MPI_Info_get_valuelen( *(MPI_Info*)info, key, valuelen, flag); +} + +void mpi_info_delete_ (int* info, char *key, int* ierr){ + *ierr = MPI_Info_delete(*(MPI_Info*)info, key); +} + +void mpi_info_get_nkeys_ ( int* info, int *nkeys, int* ierr){ + *ierr = MPI_Info_get_nkeys( *(MPI_Info*)info, nkeys); +} + +void mpi_info_get_nthkey_ ( int* info, int* n, char *key, int* ierr){ + *ierr = MPI_Info_get_nthkey( *(MPI_Info*)info, *n, key); +} + +void mpi_get_version_ (int *version,int *subversion, int* ierr){ + *ierr = MPI_Get_version (version,subversion); +} + +void mpi_get_library_version_ (char *version,int *len, int* ierr){ + *ierr = MPI_Get_library_version (version,len); +} + +void mpi_request_get_status_ ( int* request, int *flag, MPI_Status* status, int* ierr){ + *ierr = MPI_Request_get_status( find_request(*request), flag, status); +} + +void mpi_grequest_start_ ( void *query_fn, void *free_fn, void *cancel_fn, void *extra_state, int*request, int* ierr){ + MPI_Request tmp; + *ierr = MPI_Grequest_start( (MPI_Grequest_query_function*)query_fn, (MPI_Grequest_free_function*)free_fn, (MPI_Grequest_cancel_function*)cancel_fn, extra_state, &tmp); + if(*ierr == MPI_SUCCESS) { + *request = new_request(tmp); + } +} + +void mpi_grequest_complete_ ( int* request, int* ierr){ + *ierr = MPI_Grequest_complete( find_request(*request)); +} + +void mpi_status_set_cancelled_ (MPI_Status* status,int* flag, int* ierr){ + *ierr = MPI_Status_set_cancelled(status,*flag); +} + +void mpi_status_set_elements_ ( MPI_Status* status, int* datatype, int* count, int* ierr){ + *ierr = MPI_Status_set_elements( status, get_datatype(*datatype), *count); +} + +void mpi_comm_connect_ ( char *port_name, int* info, int* root, int* comm, int*newcomm, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_connect( port_name, *(MPI_Info*)info, *root, get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *newcomm = new_comm(tmp); + } +} + +void mpi_publish_name_ ( char *service_name, int* info, char *port_name, int* ierr){ + *ierr = MPI_Publish_name( service_name, *(MPI_Info*)info, port_name); +} + +void mpi_unpublish_name_ ( char *service_name, int* info, char *port_name, int* ierr){ + *ierr = MPI_Unpublish_name( service_name, *(MPI_Info*)info, port_name); +} + +void mpi_lookup_name_ ( char *service_name, int* info, char *port_name, int* ierr){ + *ierr = MPI_Lookup_name( service_name, *(MPI_Info*)info, port_name); +} + +void mpi_comm_join_ ( int* fd, int* intercomm, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_join( *fd, &tmp); + if(*ierr == MPI_SUCCESS) { + *intercomm = new_comm(tmp); + } +} + +void mpi_open_port_ ( int* info, char *port_name, int* ierr){ + *ierr = MPI_Open_port( *(MPI_Info*)info,port_name); +} + +void mpi_close_port_ ( char *port_name, int* ierr){ + *ierr = MPI_Close_port( port_name); +} + +void mpi_comm_accept_ ( char *port_name, int* info, int* root, int* comm, int*newcomm, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_accept( port_name, *(MPI_Info*)info, *root, get_comm(*comm), &tmp); + if(*ierr == MPI_SUCCESS) { + *newcomm = new_comm(tmp); + } +} + +void mpi_comm_spawn_ ( char *command, char *argv, int* maxprocs, int* info, int* root, int* comm, int* intercomm, int* array_of_errcodes, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_spawn( command, NULL, *maxprocs, *(MPI_Info*)info, *root, get_comm(*comm), &tmp, array_of_errcodes); + if(*ierr == MPI_SUCCESS) { + *intercomm = new_comm(tmp); + } +} + +void mpi_comm_spawn_multiple_ ( int* count, char *array_of_commands, char** array_of_argv, int* array_of_maxprocs, int* array_of_info, int* root, + int* comm, int* intercomm, int* array_of_errcodes, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_spawn_multiple(* count, &array_of_commands, &array_of_argv, array_of_maxprocs, + (MPI_Info*)array_of_info, *root, get_comm(*comm), &tmp, array_of_errcodes); + if(*ierr == MPI_SUCCESS) { + *intercomm = new_comm(tmp); + } +} + +void mpi_comm_get_parent_ ( int* parent, int* ierr){ + MPI_Comm tmp; + *ierr = MPI_Comm_get_parent( &tmp); + if(*ierr == MPI_SUCCESS) { + *parent = new_comm(tmp); + } +} diff --git a/src/smpi/smpi_global.c b/src/smpi/smpi_global.c index 7cf9d544e4..27a53de486 100644 --- a/src/smpi/smpi_global.c +++ b/src/smpi/smpi_global.c @@ -29,6 +29,7 @@ typedef struct s_smpi_process_data { double simulated; MPI_Comm comm_self; void *data; /* user data */ + int initialized; } s_smpi_process_data_t; static smpi_process_data_t *process_data = NULL; @@ -104,6 +105,24 @@ int smpi_process_finalized() // If finalized, this value has been set to -100; } +/** + * @brief Check if a process is initialized + */ +int smpi_process_initialized(void) +{ + int index = smpi_process_index(); + return((index != -100) && (index!=MPI_UNDEFINED) && (process_data[index]->initialized)); +} + +/** + * @brief Mark a process as initialized (=MPI_Init called) + */ +void smpi_process_mark_as_initialized(void) +{ + int index = smpi_process_index(); + if(index != -100)process_data[index]->initialized=1; +} + #ifdef SMPI_F2C int smpi_process_argc(void) { @@ -264,6 +283,8 @@ void smpi_global_init(void) process_data[i]->timer = xbt_os_timer_new(); group = smpi_group_new(1); process_data[i]->comm_self = smpi_comm_new(group); + process_data[i]->initialized =0; + smpi_group_set_mapping(group, i, 0); } group = smpi_group_new(process_count); diff --git a/src/smpi/smpi_mpi.c b/src/smpi/smpi_mpi.c index f98336efd7..c3dd85ed92 100644 --- a/src/smpi/smpi_mpi.c +++ b/src/smpi/smpi_mpi.c @@ -90,7 +90,7 @@ int MPI_Type_get_name(MPI_Datatype datatype, char * name, int* len) int MPI_Type_get_attr (MPI_Datatype type, int type_keyval, void *attribute_val, int* flag) { - return PMPI_Type_set_attr ( type, type_keyval, attribute_val); + return PMPI_Type_get_attr ( type, type_keyval, attribute_val, flag); } int MPI_Type_set_attr (MPI_Datatype type, int type_keyval, void *attribute_val) @@ -663,6 +663,10 @@ int MPI_Type_hindexed(int count, int* blocklens, MPI_Aint* indices, MPI_Datatype return PMPI_Type_hindexed(count, blocklens, indices, old_type, newtype); } +int MPI_Type_create_hindexed(int count, int* blocklens, MPI_Aint* indices, MPI_Datatype old_type, MPI_Datatype* new_type) { + return PMPI_Type_create_hindexed(count, blocklens,indices,old_type,new_type); +} + int MPI_Type_create_hindexed_block(int count, int blocklength, MPI_Aint* indices, MPI_Datatype old_type, MPI_Datatype* newtype) { return PMPI_Type_create_hindexed_block(count, blocklength, indices, old_type, newtype); } @@ -675,6 +679,10 @@ int MPI_Type_indexed(int count, int* blocklens, int* indices, MPI_Datatype old_t return PMPI_Type_indexed(count, blocklens, indices, old_type, newtype); } +int MPI_Type_create_indexed(int count, int* blocklens, int* indices, MPI_Datatype old_type, MPI_Datatype* newtype) { + return PMPI_Type_create_indexed(count, blocklens, indices, old_type, newtype); +} + int MPI_Type_create_indexed_block(int count, int blocklength, int* indices, MPI_Datatype old_type, MPI_Datatype *newtype){ return PMPI_Type_create_indexed_block(count, blocklength, indices, old_type, newtype); } diff --git a/src/smpi/smpi_pmpi.c b/src/smpi/smpi_pmpi.c index 7859738e24..b753958433 100644 --- a/src/smpi/smpi_pmpi.c +++ b/src/smpi/smpi_pmpi.c @@ -27,6 +27,7 @@ void TRACE_smpi_set_category(const char *category) int PMPI_Init(int *argc, char ***argv) { smpi_process_init(argc, argv); + smpi_process_mark_as_initialized(); #ifdef HAVE_TRACING int rank = smpi_process_index(); TRACE_smpi_init(rank); @@ -1478,6 +1479,7 @@ int PMPI_Wait(MPI_Request * request, MPI_Status * status) int src_traced = (*request)->src; int dst_traced = (*request)->dst; + MPI_Comm comm = (*request)->comm; int is_wait_for_receive = (*request)->recv; TRACE_smpi_ptp_in(rank, src_traced, dst_traced, __FUNCTION__); #endif @@ -1486,8 +1488,13 @@ int PMPI_Wait(MPI_Request * request, MPI_Status * status) retval = MPI_SUCCESS; #ifdef HAVE_TRACING + //the src may not have been known at the beginning of the recv (MPI_ANY_SOURCE) TRACE_smpi_ptp_out(rank, src_traced, dst_traced, __FUNCTION__); if (is_wait_for_receive) { + if(src_traced==MPI_ANY_SOURCE) + src_traced = (status!=MPI_STATUS_IGNORE) ? + smpi_group_rank(smpi_comm_group(comm), status->MPI_SOURCE) : + src_traced; TRACE_smpi_recv(rank, src_traced, dst_traced); } TRACE_smpi_computing_in(rank); @@ -1510,12 +1517,15 @@ int PMPI_Waitany(int count, MPI_Request requests[], int *index, MPI_Status * sta int *srcs = xbt_new(int, count); int *dsts = xbt_new(int, count); int *recvs = xbt_new(int, count); + MPI_Comm *comms = xbt_new(MPI_Comm, count); + for (i = 0; i < count; i++) { MPI_Request req = requests[i]; //already received requests are no longer valid if (req) { srcs[i] = req->src; dsts[i] = req->dst; recvs[i] = req->recv; + comms[i] = req->comm; } } int rank_traced = smpi_process_index(); @@ -1533,15 +1543,22 @@ int PMPI_Waitany(int count, MPI_Request requests[], int *index, MPI_Status * sta #ifdef HAVE_TRACING if(*index!=MPI_UNDEFINED){ int src_traced = srcs[*index]; + //the src may not have been known at the beginning of the recv (MPI_ANY_SOURCE) int dst_traced = dsts[*index]; int is_wait_for_receive = recvs[*index]; if (is_wait_for_receive) { + if(srcs[*index]==MPI_ANY_SOURCE) + src_traced = (status!=MPI_STATUSES_IGNORE) ? + smpi_group_rank(smpi_comm_group(comms[*index]), status[*index].MPI_SOURCE) : + srcs[*index]; TRACE_smpi_recv(rank_traced, src_traced, dst_traced); } TRACE_smpi_ptp_out(rank_traced, src_traced, dst_traced, __FUNCTION__); xbt_free(srcs); xbt_free(dsts); xbt_free(recvs); + xbt_free(comms); + } TRACE_smpi_computing_in(rank_traced); #endif @@ -1559,14 +1576,20 @@ int PMPI_Waitall(int count, MPI_Request requests[], MPI_Status status[]) int *srcs = xbt_new(int, count); int *dsts = xbt_new(int, count); int *recvs = xbt_new(int, count); - int valid_count = 0; + int *valid = xbt_new(int, count); + MPI_Comm *comms = xbt_new(MPI_Comm, count); + + //int valid_count = 0; for (i = 0; i < count; i++) { MPI_Request req = requests[i]; if(req!=MPI_REQUEST_NULL){ - srcs[valid_count] = req->src; - dsts[valid_count] = req->dst; - recvs[valid_count] = req->recv; - valid_count++; + srcs[i] = req->src; + dsts[i] = req->dst; + recvs[i] = req->recv; + comms[i] = req->comm; + valid[i]=1;; + }else{ + valid[i]=0; } } int rank_traced = smpi_process_index(); @@ -1576,18 +1599,29 @@ int PMPI_Waitall(int count, MPI_Request requests[], MPI_Status status[]) #endif int retval = smpi_mpi_waitall(count, requests, status); #ifdef HAVE_TRACING - for (i = 0; i < valid_count; i++) { - int src_traced = srcs[i]; - int dst_traced = dsts[i]; - int is_wait_for_receive = recvs[i]; - if (is_wait_for_receive) { - TRACE_smpi_recv(rank_traced, src_traced, dst_traced); + for (i = 0; i < count; i++) { + if(valid[i]){ + //int src_traced = srcs[*index]; + //the src may not have been known at the beginning of the recv (MPI_ANY_SOURCE) + int src_traced = srcs[i]; + int dst_traced = dsts[i]; + int is_wait_for_receive = recvs[i]; + if (is_wait_for_receive) { + if(src_traced==MPI_ANY_SOURCE) + src_traced = (status!=MPI_STATUSES_IGNORE) ? + smpi_group_rank(smpi_comm_group(comms[i]), status[i].MPI_SOURCE) : + srcs[i]; + TRACE_smpi_recv(rank_traced, src_traced, dst_traced); + } } } TRACE_smpi_ptp_out(rank_traced, -1, -1, __FUNCTION__); xbt_free(srcs); xbt_free(dsts); xbt_free(recvs); + xbt_free(valid); + xbt_free(comms); + TRACE_smpi_computing_in(rank_traced); #endif smpi_bench_begin(); @@ -2316,6 +2350,21 @@ int PMPI_Type_indexed(int count, int* blocklens, int* indices, MPI_Datatype old_ return retval; } +int PMPI_Type_create_indexed(int count, int* blocklens, int* indices, MPI_Datatype old_type, MPI_Datatype* new_type) { + int retval; + + smpi_bench_end(); + if (old_type == MPI_DATATYPE_NULL) { + retval = MPI_ERR_TYPE; + } else if (count<0){ + retval = MPI_ERR_COUNT; + } else { + retval = smpi_datatype_indexed(count, blocklens, indices, old_type, new_type); + } + smpi_bench_begin(); + return retval; +} + int PMPI_Type_create_indexed_block(int count, int blocklength, int* indices, MPI_Datatype old_type, MPI_Datatype* new_type) { int retval,i; @@ -2350,6 +2399,10 @@ int PMPI_Type_hindexed(int count, int* blocklens, MPI_Aint* indices, MPI_Datatyp return retval; } +int PMPI_Type_create_hindexed(int count, int* blocklens, MPI_Aint* indices, MPI_Datatype old_type, MPI_Datatype* new_type) { + return PMPI_Type_hindexed(count, blocklens,indices,old_type,new_type); +} + int PMPI_Type_create_hindexed_block(int count, int blocklength, MPI_Aint* indices, MPI_Datatype old_type, MPI_Datatype* new_type) { int retval,i; @@ -2395,7 +2448,7 @@ int PMPI_Error_class(int errorcode, int* errorclass) { int PMPI_Initialized(int* flag) { - *flag=(smpi_process_data()!=NULL); + *flag=smpi_process_initialized(); return MPI_SUCCESS; } diff --git a/src/smpi/smpiff.in b/src/smpi/smpiff.in index b86184bd96..7fd89c8a6c 100644 --- a/src/smpi/smpiff.in +++ b/src/smpi/smpiff.in @@ -30,9 +30,11 @@ if [ -n "${SRCFILES}" ] then for SRCFILE in "${SRCFILES}" do - CFILE="${SRCFILE%.f}.c" + TMPFILE=$(mktemp -p .).f + cp ${SRCFILE} ${TMPFILE} + CFILE="${TMPFILE%.f}.c" #echo "$prefix/bin/smpif2c ${SRCFILE} && $prefix/bin/smpicc ${ARGS} ${CFILE} && rm ${CFILE}" - $prefix/bin/smpif2c ${SRCFILE} && $prefix/bin/smpicc ${ARGS} ${CFILE} && rm ${CFILE} + $prefix/bin/smpif2c ${TMPFILE} && $prefix/bin/smpicc ${ARGS} ${CFILE} && rm ${CFILE} && rm ${TMPFILE} done else #echo "$prefix/bin/smpicc ${ARGS}" diff --git a/teshsuite/smpi/mpich3-test/CMakeLists.txt b/teshsuite/smpi/mpich3-test/CMakeLists.txt index 802e555a6a..82b588bc1c 100644 --- a/teshsuite/smpi/mpich3-test/CMakeLists.txt +++ b/teshsuite/smpi/mpich3-test/CMakeLists.txt @@ -40,6 +40,7 @@ set(txt_files ${CMAKE_CURRENT_SOURCE_DIR}/hostfile ${CMAKE_CURRENT_SOURCE_DIR}/checktests ${CMAKE_CURRENT_SOURCE_DIR}/util/mtest.c + ${CMAKE_CURRENT_SOURCE_DIR}/f77/testlist ${CMAKE_CURRENT_SOURCE_DIR}/include/mpitestconf.h ${CMAKE_CURRENT_SOURCE_DIR}/include/mpitest.h PARENT_SCOPE) diff --git a/teshsuite/smpi/mpich3-test/f77/attr/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/attr/CMakeLists.txt new file mode 100644 index 0000000000..50752bb57e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/CMakeLists.txt @@ -0,0 +1,79 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../../include/") + + add_executable(attrmpi1f attrmpi1f.f ../util/mtestf.f) + add_executable(baseattr2f baseattr2f.f ../util/mtestf.f) + add_executable(baseattrf baseattrf.f ../util/mtestf.f) + add_executable(commattr2f commattr2f.f ../util/mtestf.f) + add_executable(commattr3f commattr3f.f ../util/mtestf.f) + add_executable(commattrf commattrf.f ../util/mtestf.f) + add_executable(typeattr2f typeattr2f.f ../util/mtestf.f) + add_executable(typeattr3f typeattr3f.f ../util/mtestf.f) + add_executable(typeattrf typeattrf.f ../util/mtestf.f) + + target_link_libraries(attrmpi1f simgrid) + target_link_libraries(baseattr2f simgrid) + target_link_libraries(baseattrf simgrid) + target_link_libraries(commattr2f simgrid) + target_link_libraries(commattr3f simgrid) + target_link_libraries(commattrf simgrid) + target_link_libraries(typeattr2f simgrid) + target_link_libraries(typeattr3f simgrid) + target_link_libraries(typeattrf simgrid) + + + set_target_properties(attrmpi1f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(baseattr2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(baseattrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commattr2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commattr3f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commattrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeattr2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeattr3f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeattrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/attraints.h + ${CMAKE_CURRENT_SOURCE_DIR}/attrmpi1f.f + ${CMAKE_CURRENT_SOURCE_DIR}/baseattr2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/baseattrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/commattr2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/commattr3f.f + ${CMAKE_CURRENT_SOURCE_DIR}/commattrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeattr2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeattr3f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeattrf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/attr/attraints.h b/teshsuite/smpi/mpich3-test/f77/attr/attraints.h new file mode 100644 index 0000000000..182b04567a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/attraints.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer extrastate, valin, valout, val diff --git a/teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.f b/teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.f new file mode 100644 index 0000000000..44e5b5e3e1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.f @@ -0,0 +1,62 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer value, wsize, wrank, extra, mykey + integer rvalue, svalue, ncomm + logical flag + integer ierr, errs +C + errs = 0 + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) +C +C Simple attribute put and get +C + call mpi_keyval_create( MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN, + $ mykey, extra,ierr ) + call mpi_attr_get( MPI_COMM_WORLD, mykey, value, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, + $ "Did not get flag==.false. for attribute that was not set" + endif +C + value = 1234567 + svalue = value + call mpi_attr_put( MPI_COMM_WORLD, mykey, value, ierr ) + value = -9876543 + call mpi_attr_get( MPI_COMM_WORLD, mykey, rvalue, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Did not find attribute after set" + else + if (rvalue .ne. svalue) then + errs = errs + 1 + print *, "Attribute value ", rvalue, " should be ", svalue + endif + endif + value = -123456 + svalue = value + call mpi_attr_put( MPI_COMM_WORLD, mykey, value, ierr ) + value = 987654 + call mpi_attr_get( MPI_COMM_WORLD, mykey, rvalue, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Did not find attribute after set (neg)" + else + if (rvalue .ne. svalue) then + errs = errs + 1 + print *, "Neg Attribute value ", rvalue," should be ",svalue + endif + endif +C + call mpi_keyval_free( mykey, ierr ) + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f b/teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f new file mode 100644 index 0000000000..59d69bc94c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f @@ -0,0 +1,113 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2001 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + logical flag + integer value, commsize, commrank + + errs = 0 + call mpi_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, commsize, 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" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_HOST, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get HOST" + else + if ((value .lt. 0 .or. value .ge. commsize) .and. value .ne. + $ MPI_PROC_NULL) then + errs = errs + 1 + print *, "Got invalid value ", value, " for HOST" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_IO, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Could not get IO" + else + if ((value .lt. 0 .or. value .ge. commsize) .and. value .ne. + $ MPI_ANY_SOURCE .and. value .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, "Got invalid value ", value, " for IO" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_WTIME_IS_GLOBAL, value, + $ flag, ierr ) + if (flag) then +C Wtime need not be set + if (value .lt. 0 .or. value .gt. 1) then + errs = errs + 1 + print *, "Invalid value for WTIME_IS_GLOBAL (got ", value, + $ ")" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_APPNUM, value, flag, ierr + $ ) +C appnum need not be set + if (flag) then + if (value .lt. 0) then + errs = errs + 1 + print *, "MPI_APPNUM is defined as ", value, + $ " but must be nonnegative" + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, value, + $ flag, ierr ) +C MPI_UNIVERSE_SIZE need not be set + if (flag) then + if (value .lt. commsize) then + errs = errs + 1 + print *, "MPI_UNIVERSE_SIZE = ", value, + $ ", 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 + if (flag) then + if (value .lt. MPI_ERR_LASTCODE) then + errs = errs + 1 + print *, "MPI_LASTUSEDCODE points to an integer (", + $ MPI_ERR_LASTCODE, ") smaller than MPI_ERR_LASTCODE (", + $ value, ")" + endif + else + errs = errs + 1 + print *, "MPI_LASTUSECODE is not defined" + endif + +C Check for errors + if (errs .eq. 0) then + print *, " No Errors" + else + print *, " Found ", errs, " errors" + endif + + call MPI_Finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/baseattrf.f b/teshsuite/smpi/mpich3-test/f77/attr/baseattrf.f new file mode 100644 index 0000000000..36f520d855 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/baseattrf.f @@ -0,0 +1,63 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer value, commsize + logical flag + integer ierr, errs + + errs = 0 + call mpi_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr ) + call mpi_attr_get( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, value, flag + $ , ierr) + ! MPI_UNIVERSE_SIZE need not be set + if (flag) then + if (value .lt. commsize) then + print *, "MPI_UNIVERSE_SIZE is ", value, " less than world " + $ , commsize + errs = errs + 1 + endif + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_LASTUSEDCODE, value, flag, + $ ierr ) + ! Last used code must be defined and >= MPI_ERR_LASTCODE + if (flag) then + if (value .lt. MPI_ERR_LASTCODE) then + errs = errs + 1 + print *, "MPI_LASTUSEDCODE points to an integer + $ (", value, ") smaller than MPI_ERR_LASTCODE (", + $ MPI_ERR_LASTCODE, ")" + endif + else + errs = errs + 1 + print *, "MPI_LASTUSECODE is not defined" + endif + + call mpi_attr_get( MPI_COMM_WORLD, MPI_APPNUM, value, flag, ierr ) + ! appnum need not be set + if (flag) then + if (value .lt. 0) then + errs = errs + 1 + print *, "MPI_APPNUM is defined as ", value, + $ " but must be nonnegative" + endif + endif + + ! Check for errors + if (errs .eq. 0) then + print *, " No Errors" + else + print *, " Found ", errs, " errors" + endif + + call MPI_Finalize( ierr ) + + end + diff --git a/teshsuite/smpi/mpich3-test/f77/attr/commattr2f.f b/teshsuite/smpi/mpich3-test/f77/attr/commattr2f.f new file mode 100644 index 0000000000..92d47f9343 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/commattr2f.f @@ -0,0 +1,103 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C This is a modified version of commattrf.f that uses two of the +C default functions +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm1, comm2 + integer keyval + logical flag +C +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 + errs = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr ) +C + extrastate = 1001 + 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 ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + + valin = 2001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + call mpi_comm_dup( comm1, comm2, ierr ) + flag = .false. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm ', valout + endif + flag = .false. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm2 ', valout + endif +C Test the delete function + call mpi_comm_free( comm2, ierr ) +C +C Test the attr delete function + call mpi_comm_dup( comm1, comm2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_comm_set_attr( comm2, keyval, valin, ierr ) + call mpi_comm_delete_attr( comm2, keyval, ierr ) + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_comm_free( comm2, ierr ) +C + ierr = -1 + call mpi_comm_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + call mpi_comm_free( comm1, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f b/teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f new file mode 100644 index 0000000000..cfa5ffb203 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f @@ -0,0 +1,84 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This tests the null copy function (returns flag false; thus the +C attribute should not be propagated to a dup'ed communicator +C This is must like the test in commattr2f +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm1, comm2 + integer keyval + logical flag +C +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 + errs = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr ) +C + extrastate = 1001 + 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 ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + +C Test the null copy function + 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 appear on the dup'ed communicator + flag = .false. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm ', valout + endif + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Attribute incorrectly present on dup communicator' + endif +C Test the delete function + call mpi_comm_free( comm2, ierr ) +C +C Test the attr delete function + call mpi_comm_dup( comm1, comm2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_comm_set_attr( comm2, keyval, valin, ierr ) + call mpi_comm_delete_attr( comm2, keyval, ierr ) + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_comm_free( comm2, ierr ) +C + ierr = -1 + call mpi_comm_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + call mpi_comm_free( comm1, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/commattrf.f b/teshsuite/smpi/mpich3-test/f77/attr/commattrf.f new file mode 100644 index 0000000000..491ec88098 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/commattrf.f @@ -0,0 +1,154 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm1, comm2 + integer curcount, keyval + logical flag + external mycopyfn, mydelfn + integer callcount, delcount + common /myattr/ callcount, delcount +C +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 + errs = 0 + callcount = 0 + delcount = 0 + call mtest_init( ierr ) + call mpi_comm_dup( MPI_COMM_WORLD, comm1, ierr ) +C + extrastate = 1001 + call mpi_comm_create_keyval( mycopyfn, mydelfn, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + + valin = 2001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_comm_set_attr( comm1, keyval, valin, ierr ) + call mpi_comm_dup( comm1, comm2, ierr ) + flag = .false. + call mpi_comm_get_attr( comm1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in comm ', valout + endif + flag = .false. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (valout .ne. 5003) then + errs = errs + 1 + print *, 'Unexpected output value in comm2 ', valout + endif +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 ', + & delcount, curcount + 1 + endif +C +C Test the attr delete function + call mpi_comm_dup( comm1, comm2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_comm_set_attr( comm2, keyval, valin, ierr ) + delcount = 0 + call mpi_comm_delete_attr( comm2, keyval, ierr ) + if (delcount .ne. 1) then + errs = errs + 1 + print *, ' Delete_attr did not call delete function' + endif + flag = .true. + call mpi_comm_get_attr( comm2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_comm_free( comm2, ierr ) +C + ierr = -1 + call mpi_comm_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + call mpi_comm_free( comm1, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end +C + subroutine mycopyfn( oldcomm, keyval, extrastate, valin, valout, + & flag, ierr ) + implicit none + include 'mpif.h' + integer oldcomm, keyval, ierr + include 'attraints.h' + logical flag + integer callcount, delcount + common /myattr/ callcount, delcount +C increment the attribute by 2 + valout = valin + 2 + callcount = callcount + 1 + if (extrastate .eq. 1001) then + flag = .true. + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + flag = .false. + ierr = MPI_ERR_OTHER + endif + end +C + subroutine mydelfn( comm, keyval, val, extrastate, ierr ) + implicit none + include 'mpif.h' + integer comm, keyval, ierr + include 'attraints.h' + integer callcount, delcount + common /myattr/ callcount, delcount + delcount = delcount + 1 + if (extrastate .eq. 1001) then + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + ierr = MPI_ERR_OTHER + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/testlist b/teshsuite/smpi/mpich3-test/f77/attr/testlist new file mode 100644 index 0000000000..27d9d59c21 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/testlist @@ -0,0 +1,9 @@ +attrmpi1f 1 +baseattrf 1 +baseattr2f 1 +commattrf 1 +commattr2f 1 +commattr3f 1 +typeattrf 1 +typeattr2f 1 +typeattr3f 1 diff --git a/teshsuite/smpi/mpich3-test/f77/attr/typeattr2f.f b/teshsuite/smpi/mpich3-test/f77/attr/typeattr2f.f new file mode 100644 index 0000000000..5fbbdbbf52 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/typeattr2f.f @@ -0,0 +1,102 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C This is a modified version of typeattrf.f that uses two of the +C default functions +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer type1, type2 + integer keyval + logical flag +C +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 + errs = 0 + call mtest_init( ierr ) + type1 = MPI_INTEGER +C + extrastate = 1001 + 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 ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + + valin = 2001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + call mpi_type_dup( type1, type2, ierr ) + flag = .false. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type ', valout + endif + flag = .false. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type2 ', valout + endif +C Test the delete function + call mpi_type_free( type2, ierr ) +C +C Test the attr delete function + call mpi_type_dup( type1, type2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_type_set_attr( type2, keyval, valin, ierr ) + call mpi_type_delete_attr( type2, keyval, ierr ) + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_type_free( type2, ierr ) +C + ierr = -1 + call mpi_type_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.f b/teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.f new file mode 100644 index 0000000000..5d30e70f61 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.f @@ -0,0 +1,83 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This tests the null copy function (returns flag false; thus the +C attribute should not be propagated to a dup'ed communicator +C This is much like the test in typeattr2f +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer type1, type2 + integer keyval + logical flag +C +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 + errs = 0 + call mtest_init( ierr ) + type1 = MPI_INTEGER +C + extrastate = 1001 + 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 ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + +C Test the null copy function + 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 appear on the dup'ed communicator + flag = .false. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type ', valout + endif + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Attribute incorrectly present on dup datatype' + endif +C Test the delete function + call mpi_type_free( type2, ierr ) +C +C Test the attr delete function + call mpi_type_dup( type1, type2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_type_set_attr( type2, keyval, valin, ierr ) + call mpi_type_delete_attr( type2, keyval, ierr ) + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_type_free( type2, ierr ) +C + ierr = -1 + call mpi_type_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/attr/typeattrf.f b/teshsuite/smpi/mpich3-test/f77/attr/typeattrf.f new file mode 100644 index 0000000000..78aaa35929 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/attr/typeattrf.f @@ -0,0 +1,155 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + include 'attraints.h' + integer comm + integer type1, type2 + integer curcount, keyval + logical flag + external mycopyfn, mydelfn + integer callcount, delcount + common /myattr/ callcount, delcount +C +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 + errs = 0 + callcount = 0 + delcount = 0 + call mtest_init( ierr ) +C +C Attach an attribute to a predefined object + type1 = MPI_INTEGER + extrastate = 1001 + call mpi_type_create_keyval( mycopyfn, mydelfn, keyval, + & extrastate, ierr ) + flag = .true. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' get attr returned true when no attr set' + endif + + valin = 2003 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + + valin = 2001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + flag = .false. + valout = -1 + 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, + & ' from attr' + endif + +C +C Test the copy function + valin = 5001 + call mpi_type_set_attr( type1, keyval, valin, ierr ) + call mpi_type_dup( type1, type2, ierr ) + flag = .false. + call mpi_type_get_attr( type1, keyval, valout, flag, ierr ) + if (valout .ne. 5001) then + errs = errs + 1 + print *, 'Unexpected output value in type ', valout + endif + flag = .false. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (valout .ne. 5003) then + errs = errs + 1 + print *, 'Unexpected output value in type2 ', valout + endif +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 ', + & delcount, curcount + 1 + endif +C +C Test the attr delete function + call mpi_type_dup( type1, type2, ierr ) + valin = 6001 + extrastate = 1001 + call mpi_type_set_attr( type2, keyval, valin, ierr ) + delcount = 0 + call mpi_type_delete_attr( type2, keyval, ierr ) + if (delcount .ne. 1) then + errs = errs + 1 + print *, ' Delete_attr did not call delete function' + endif + flag = .true. + call mpi_type_get_attr( type2, keyval, valout, flag, ierr ) + if (flag) then + errs = errs + 1 + print *, ' Delete_attr did not delete attribute' + endif + call mpi_type_free( type2, ierr ) + + ierr = -1 + call mpi_type_free_keyval( keyval, ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + call mtestprinterror( ierr ) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end +C + subroutine mycopyfn( oldtype, keyval, extrastate, valin, valout, + & flag, ierr ) + implicit none + include 'mpif.h' + integer oldtype, keyval, ierr + include 'attraints.h' + logical flag + integer callcount, delcount + common /myattr/ callcount, delcount +C increment the attribute by 2 + valout = valin + 2 + callcount = callcount + 1 + if (extrastate .eq. 1001) then + flag = .true. + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + flag = .false. + ierr = MPI_ERR_OTHER + endif + end +C + subroutine mydelfn( type, keyval, val, extrastate, ierr ) + implicit none + include 'mpif.h' + integer type, keyval, ierr + include 'attraints.h' + integer callcount, delcount + common /myattr/ callcount, delcount + delcount = delcount + 1 + if (extrastate .eq. 1001) then + ierr = MPI_SUCCESS + else + print *, ' Unexpected value of extrastate = ', extrastate + ierr = MPI_ERR_OTHER + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt new file mode 100644 index 0000000000..805f851a4d --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt @@ -0,0 +1,97 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../include/") + + add_executable(allredint8f allredint8f.f ../util/mtestf.f) + add_executable(allredopttf allredopttf.f ../util/mtestf.f) + add_executable(alltoallvf alltoallvf.f ../util/mtestf.f) + add_executable(alltoallwf alltoallwf.f ../util/mtestf.f) + add_executable(exscanf exscanf.f ../util/mtestf.f) + add_executable(inplacef inplacef.f ../util/mtestf.f) + # add_executable(nonblockingf nonblockingf.f ../util/mtestf.f) + # add_executable(nonblocking_inpf nonblocking_inpf.f ../util/mtestf.f) + add_executable(red_scat_blockf red_scat_blockf.f ../util/mtestf.f) + add_executable(redscatf redscatf.f ../util/mtestf.f) + add_executable(reducelocalf reducelocalf.f ../util/mtestf.f) + add_executable(split_typef split_typef.f ../util/mtestf.f) + add_executable(uallreducef uallreducef.f ../util/mtestf.f) + add_executable(vw_inplacef vw_inplacef.f ../util/mtestf.f) + + target_link_libraries(allredint8f simgrid) + target_link_libraries(allredopttf simgrid) + target_link_libraries(alltoallvf simgrid) + target_link_libraries(alltoallwf simgrid) + target_link_libraries(exscanf simgrid) + target_link_libraries(inplacef simgrid) + # target_link_libraries(nonblockingf simgrid) + # target_link_libraries(nonblocking_inpf simgrid) + target_link_libraries(red_scat_blockf simgrid) + target_link_libraries(redscatf simgrid) + target_link_libraries(reducelocalf simgrid) + target_link_libraries(split_typef simgrid) + target_link_libraries(uallreducef simgrid) + target_link_libraries(vw_inplacef simgrid) + + set_target_properties(allredint8f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(allredopttf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(alltoallvf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(alltoallwf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(exscanf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(inplacef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(nonblockingf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(nonblocking_inpf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(red_scat_blockf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(redscatf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(reducelocalf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(split_typef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(uallreducef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(vw_inplacef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/allredint8f.f + ${CMAKE_CURRENT_SOURCE_DIR}/allredopttf.f + ${CMAKE_CURRENT_SOURCE_DIR}/alltoallvf.f + ${CMAKE_CURRENT_SOURCE_DIR}/alltoallwf.f + ${CMAKE_CURRENT_SOURCE_DIR}/exscanf.f + ${CMAKE_CURRENT_SOURCE_DIR}/inplacef.f + ${CMAKE_CURRENT_SOURCE_DIR}/nonblockingf.f + ${CMAKE_CURRENT_SOURCE_DIR}/nonblocking_inpf.f + ${CMAKE_CURRENT_SOURCE_DIR}/red_scat_blockf.f + ${CMAKE_CURRENT_SOURCE_DIR}/redscatf.f + ${CMAKE_CURRENT_SOURCE_DIR}/reducelocalf.f + ${CMAKE_CURRENT_SOURCE_DIR}/split_typef.f + ${CMAKE_CURRENT_SOURCE_DIR}/uallreducef.f + ${CMAKE_CURRENT_SOURCE_DIR}/vw_inplacef.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/coll/allredint8f.f b/teshsuite/smpi/mpich3-test/f77/coll/allredint8f.f new file mode 100644 index 0000000000..10ece8700e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/allredint8f.f @@ -0,0 +1,23 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2006 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer*8 inbuf, outbuf + 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, + & MPI_COMM_WORLD, ierr) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/allredopttf.f b/teshsuite/smpi/mpich3-test/f77/coll/allredopttf.f new file mode 100644 index 0000000000..1b71c8d2a7 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/allredopttf.f @@ -0,0 +1,46 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2007 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer*8 inbuf, outbuf + double complex zinbuf, zoutbuf + integer wsize + integer errs, ierr + + errs = 0 + + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr ) +C +C A simple test of allreduce for the optional integer*8 type + + inbuf = 1 + outbuf = 0 + 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, + & " but should have ", wsize + endif + zinbuf = (1,1) + zoutbuf = (0,0) + 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 ", + & outbuf, " but should have ", wsize + endif + if (dimag(zoutbuf) .ne. wsize ) then + errs = errs + 1 + print *, "result wrong for sum with double complex = got ", + & outbuf, " but should have ", wsize + endif + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/alltoallvf.f b/teshsuite/smpi/mpich3-test/f77/coll/alltoallvf.f new file mode 100644 index 0000000000..0a2831a1f6 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/alltoallvf.f @@ -0,0 +1,146 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer i, ans, size, rank, color, comm, newcomm + integer maxSize, displ + parameter (maxSize=128) + integer scounts(maxSize), sdispls(maxSize), stypes(maxSize) + integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize) + integer sbuf(maxSize), rbuf(maxSize) + + errs = 0 + + call mtest_init( ierr ) + +C Get a comm + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + call mpi_comm_size( comm, size, ierr ) + if (size .gt. maxSize) then + call mpi_comm_rank( comm, rank, ierr ) + color = 1 + if (rank .lt. maxSize) color = 0 + call mpi_comm_split( comm, color, rank, newcomm, ierr ) + call mpi_comm_free( comm, ierr ) + comm = newcomm + call mpi_comm_size( comm, size, ierr ) + endif + call mpi_comm_rank( comm, rank, ierr ) +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 +C integers instead of bytes + do i=1, size + scounts(i) = 1 + sdispls(i) = (i-1) + stypes(i) = MPI_INTEGER + sbuf(i) = rank * size + i + rcounts(i) = 1 + rdispls(i) = (i-1) + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + call mpi_alltoallv( sbuf, scounts, sdispls, stypes, + & 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 + 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), + & ' expected ', ans + endif + enddo +C +C A halo-exchange example - mostly zero counts +C + do i=1, size + scounts(i) = 0 + sdispls(i) = 0 + stypes(i) = MPI_INTEGER + sbuf(i) = -1 + rcounts(i) = 0 + rdispls(i) = 0 + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + +C +C Note that the arrays are 1-origin + displ = 0 + if (rank .gt. 0) then + scounts(1+rank-1) = 1 + rcounts(1+rank-1) = 1 + sdispls(1+rank-1) = displ + rdispls(1+rank-1) = rank - 1 + sbuf(1+displ) = rank + displ = displ + 1 + endif + scounts(1+rank) = 1 + rcounts(1+rank) = 1 + sdispls(1+rank) = displ + rdispls(1+rank) = rank + sbuf(1+displ) = rank + displ = displ + 1 + if (rank .lt. size-1) then + scounts(1+rank+1) = 1 + rcounts(1+rank+1) = 1 + sdispls(1+rank+1) = displ + rdispls(1+rank+1) = rank+1 + sbuf(1+displ) = rank + displ = displ + 1 + endif + + call mpi_alltoallv( sbuf, scounts, sdispls, stypes, + & rbuf, rcounts, rdispls, rtypes, comm, ierr ) +C +C Check the neighbor values are correctly moved +C + if (rank .gt. 0) then + if (rbuf(1+rank-1) .ne. rank-1) then + errs = errs + 1 + print *, rank, ' rbuf(',1+rank-1, ') = ', rbuf(1+rank-1), + & 'expected ', rank-1 + endif + endif + if (rbuf(1+rank) .ne. rank) then + errs = errs + 1 + print *, rank, ' rbuf(', 1+rank, ') = ', rbuf(1+rank), + & 'expected ', rank + endif + if (rank .lt. size-1) then + if (rbuf(1+rank+1) .ne. rank+1) then + errs = errs + 1 + print *, rank, ' rbuf(', 1+rank+1, ') = ',rbuf(1+rank+1), + & 'expected ', rank+1 + endif + endif + do i=0,rank-2 + if (rbuf(1+i) .ne. -1) then + errs = errs + 1 + 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), + & 'expected -1' + endif + enddo + endif + call mpi_comm_free( comm, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.f b/teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.f new file mode 100644 index 0000000000..7ab0d60f57 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.f @@ -0,0 +1,67 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer i, intsize, ans, size, rank, color, comm, newcomm + integer maxSize + parameter (maxSize=32) + integer scounts(maxSize), sdispls(maxSize), stypes(maxSize) + 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 ) + +C Get a comm + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + call mpi_comm_size( comm, size, ierr ) + if (size .gt. maxSize) then + call mpi_comm_rank( comm, rank, ierr ) + color = 1 + if (rank .lt. maxSize) color = 0 + call mpi_comm_split( comm, color, rank, newcomm, ierr ) + call mpi_comm_free( comm, ierr ) + comm = newcomm + 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 + scounts(i) = 1 + sdispls(i) = (i-1)*intsize + stypes(i) = MPI_INTEGER + sbuf(i) = rank * size + i + rcounts(i) = 1 + rdispls(i) = (i-1)*intsize + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + call mpi_alltoallw( sbuf, scounts, sdispls, stypes, + & 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 + 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), + & ' expected ', ans + endif + enddo + endif + call mpi_comm_free( comm, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f77/coll/exscanf.f b/teshsuite/smpi/mpich3-test/f77/coll/exscanf.f new file mode 100644 index 0000000000..5e6f64e63e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/exscanf.f @@ -0,0 +1,107 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine uop( cin, cout, count, datatype ) + implicit none + include 'mpif.h' + integer cin(*), cout(*) + integer count, datatype + integer i + +! if (datatype .ne. MPI_INTEGER) then +! write(6,*) 'Invalid datatype passed to user_op()' +! return +! endif + + do i=1, count + cout(i) = cin(i) + cout(i) + enddo + end +C + program main + implicit none + include 'mpif.h' + integer inbuf(2), outbuf(2) + integer ans, rank, size, comm + integer errs, ierr + integer sumop + external uop + + errs = 0 + + call mtest_init( ierr ) +C +C A simple test of exscan + comm = MPI_COMM_WORLD + + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + + inbuf(1) = rank + inbuf(2) = -rank + 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 + ans = (rank * (rank - 1))/2 + if (rank .gt. 0) then + if (outbuf(1) .ne. ans) then + errs = errs + 1 + print *, rank, ' Expected ', ans, ' got ', outbuf(1) + endif + if (outbuf(2) .ne. -ans) then + errs = errs + 1 + print *, rank, ' Expected ', -ans, ' got ', outbuf(1) + endif + endif +C +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, + & ierr ) +C this process has the sum of i from 0 to rank-1, which is +C (rank)(rank-1)/2 and -i + ans = (rank * (rank - 1))/2 + if (rank .gt. 0) then + if (outbuf(1) .ne. ans) then + errs = errs + 1 + print *, rank, ' sumop: Expected ', ans, ' got ', outbuf(1) + endif + if (outbuf(2) .ne. -ans) then + errs = errs + 1 + print *, rank, ' sumop: Expected ', -ans, ' got ', outbuf(1) + 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, + & ierr ) +C this process has the sum of i from 0 to rank-1, which is +C (rank)(rank-1)/2 and -i + ans = (rank * (rank - 1))/2 + if (rank .gt. 0) then + if (outbuf(1) .ne. ans) then + errs = errs + 1 + print *, rank, ' sumop2: Expected ', ans, ' got ', outbuf(1) + endif + if (outbuf(2) .ne. -ans) then + errs = errs + 1 + print *, rank, ' sumop2: Expected ', -ans, ' got ',outbuf(1) + endif + endif + call mpi_op_free( sumop, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/inplacef.f b/teshsuite/smpi/mpich3-test/f77/coll/inplacef.f new file mode 100644 index 0000000000..230cccb37a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/inplacef.f @@ -0,0 +1,91 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2005 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This is a simple test that Fortran support the MPI_IN_PLACE value +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer comm, root + integer rank, size + integer i + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer rbuf(MAX_SIZE), rdispls(MAX_SIZE), rcount(MAX_SIZE), + $ sbuf(MAX_SIZE) + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + + root = 0 +C Gather with inplace + do i=1,size + rbuf(i) = - i + enddo + rbuf(1+root) = root + if (rank .eq. root) then + call mpi_gather( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, 1, + $ MPI_INTEGER, root, comm, ierr ) + do i=1,size + if (rbuf(i) .ne. i-1) then + errs = errs + 1 + 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 + +C Gatherv with inplace + do i=1,size + rbuf(i) = - i + rcount(i) = 1 + rdispls(i) = i-1 + enddo + rbuf(1+root) = root + if (rank .eq. root) then + call mpi_gatherv( MPI_IN_PLACE, 1, MPI_INTEGER, rbuf, rcount, + $ rdispls, MPI_INTEGER, root, comm, ierr ) + do i=1,size + if (rbuf(i) .ne. i-1) then + errs = errs + 1 + 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 + +C Scatter with inplace + do i=1,size + sbuf(i) = i + enddo + rbuf(1) = -1 + if (rank .eq. root) then + call mpi_scatter( sbuf, 1, MPI_INTEGER, MPI_IN_PLACE, 1, + $ MPI_INTEGER, root, comm, ierr ) + else + call mpi_scatter( sbuf, 1, MPI_INTEGER, rbuf, 1, + $ MPI_INTEGER, root, comm, ierr ) + if (rbuf(1) .ne. rank+1) then + errs = errs + 1 + print *, '[', rank, '] rbuf = ', rbuf(1), + $ ' in scatter' + endif + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/nonblocking_inpf.f b/teshsuite/smpi/mpich3-test/f77/coll/nonblocking_inpf.f new file mode 100644 index 0000000000..d2c3bbd015 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/nonblocking_inpf.f @@ -0,0 +1,124 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw]. +C + program main + implicit none + include 'mpif.h' + integer SIZEOFINT + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer rbuf(MAX_SIZE) + integer rdispls(MAX_SIZE), rcounts(MAX_SIZE), rtypes(MAX_SIZE) + integer comm, rank, size, req + integer sumval, ierr, errs + integer iexpected, igot + integer i, j + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + call mpi_type_size( MPI_INTEGER, SIZEOFINT, ierr ) + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rbuf(i) = (i-1) * size + rank + enddo + call mpi_ialltoall( MPI_IN_PLACE, -1, MPI_DATATYPE_NULL, + . rbuf, 1, MPI_INTEGER, comm, req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + do i=1,size + if (rbuf(i) .ne. (rank*size + i - 1)) then + errs = errs + 1 + print *, '[', rank, ']: IALLTOALL rbuf(', i, ') = ', + . rbuf(i), ', should be', rank * size + i - 1 + endif + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rcounts(i) = i-1 + rank + rdispls(i) = (i-1) * (2*size) + do j=0,rcounts(i)-1 + rbuf(rdispls(i)+j+1) = 100 * rank + 10 * (i-1) + j + enddo + enddo + call mpi_ialltoallv( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + . rbuf, rcounts, rdispls, MPI_INTEGER, + . comm, req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, ']: IALLTOALLV got ', igot, + . ',but expected ', iexpected, + . ' for block=', i-1, ' element=', j + endif + enddo + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rcounts(i) = i-1 + rank + rdispls(i) = (i-1) * (2*size) * SIZEOFINT + rtypes(i) = MPI_INTEGER + do j=0,rcounts(i)-1 + rbuf(rdispls(i)/SIZEOFINT+j+1) = 100 * rank + . + 10 * (i-1) + j + enddo + enddo + call mpi_ialltoallw( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + . rbuf, rcounts, rdispls, rtypes, + . comm, req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)/SIZEOFINT+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, ']: IALLTOALLW got ', igot, + . ',but expected ', iexpected, + . ' for block=', i-1, ' element=', j + endif + enddo + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i = 1, size + rbuf(i) = rank + (i-1) + enddo + call mpi_ireduce_scatter_block( MPI_IN_PLACE, rbuf, 1, + . MPI_INTEGER, MPI_SUM, comm, + . req, ierr ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + + sumval = size * rank + ((size-1) * size)/2 + if ( rbuf(1) .ne. sumval ) then + errs = errs + 1 + print *, 'Ireduce_scatter_block does not get expected value.' + print *, '[', rank, ']:', 'Got ', rbuf(1), ' but expected ', + . sumval, '.' + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/nonblockingf.f b/teshsuite/smpi/mpich3-test/f77/coll/nonblockingf.f new file mode 100644 index 0000000000..b912acd8f1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/nonblockingf.f @@ -0,0 +1,98 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer NUM_INTS + parameter (NUM_INTS=2) + integer maxSize + parameter (maxSize=128) + integer scounts(maxSize), sdispls(maxSize) + integer rcounts(maxSize), rdispls(maxSize) + integer types(maxSize) + integer sbuf(maxSize), rbuf(maxSize) + integer comm, size, rank, req + integer ierr, errs + integer ii, ans + + errs = 0 + + call mtest_init(ierr) + + comm = MPI_COMM_WORLD + call MPI_Comm_size(comm, size, ierr) + call MPI_Comm_rank(comm, rank, ierr) +C + do ii = 1, size + sbuf(2*ii-1) = ii + sbuf(2*ii) = ii + sbuf(2*ii-1) = ii + sbuf(2*ii) = ii + scounts(ii) = NUM_INTS + rcounts(ii) = NUM_INTS + sdispls(ii) = (ii-1) * NUM_INTS + rdispls(ii) = (ii-1) * NUM_INTS + types(ii) = MPI_INTEGER + enddo + + call MPI_Ibarrier(comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ibcast(sbuf, NUM_INTS, MPI_INTEGER, 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Igather(sbuf, NUM_INTS, MPI_INTEGER, + . rbuf, NUM_INTS, MPI_INTEGER, + . 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Igatherv(sbuf, NUM_INTS, MPI_INTEGER, + . rbuf, rcounts, rdispls, MPI_INTEGER, + . 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ialltoall(sbuf, NUM_INTS, MPI_INTEGER, + . rbuf, NUM_INTS, MPI_INTEGER, + . comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ialltoallv(sbuf, scounts, sdispls, MPI_INTEGER, + . rbuf, rcounts, rdispls, MPI_INTEGER, + . comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ialltoallw(sbuf, scounts, sdispls, types, + . rbuf, rcounts, rdispls, types, + . comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ireduce(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, 0, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Iallreduce(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ireduce_scatter(sbuf, rbuf, rcounts, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Ireduce_scatter_block(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Iscan(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call MPI_Iexscan(sbuf, rbuf, NUM_INTS, MPI_INTEGER, + . MPI_SUM, comm, req, ierr) + call MPI_Wait(req, MPI_STATUS_IGNORE, ierr) + + call mtest_finalize( errs ) + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f b/teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f new file mode 100644 index 0000000000..831f2fc7a4 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f @@ -0,0 +1,56 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C A simple test for Fortran support of Reduce_scatter_block +C with or withoutMPI_IN_PLACE. +C + program main + implicit none + include 'mpif.h' + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer sbuf(MAX_SIZE), rbuf(MAX_SIZE) + integer comm, rank, size + integer sumval, ierr, errs, i + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + + do i = 1, size + sbuf(i) = rank + (i-1) + enddo + + call MPI_Reduce_scatter_block(sbuf, rbuf, 1, MPI_INTEGER, + . MPI_SUM, comm, ierr) + + sumval = size * rank + ((size-1) * size)/2 + if ( rbuf(1) .ne. sumval ) then + errs = errs + 1 + print *, 'Reduce_scatter_block does not get expected value.' + print *, '[', rank, ']', 'Got ', rbuf(1), ' but expected ', + . sumval, '.' + endif + +C Try MPI_IN_PLACE + do i = 1, size + rbuf(i) = rank + (i-1) + enddo + call MPI_Reduce_scatter_block(MPI_IN_PLACE, rbuf, 1, MPI_INTEGER, + . MPI_SUM, comm, ierr) + if ( rbuf(1) .ne. sumval ) then + errs = errs + 1 + print *, 'Reduce_scatter_block does not get expected value.' + print *, '[', rank, ']', 'Got ', rbuf(1), ' but expected ', + . sumval, '.' + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f b/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f new file mode 100644 index 0000000000..b19b1e7903 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f @@ -0,0 +1,85 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine uop( cin, cout, count, datatype ) + implicit none + include 'mpif.h' + integer cin(*), cout(*) + integer count, datatype + integer i + +! if (datatype .ne. MPI_INTEGER) then +! write(6,*) 'Invalid datatype ',datatype,' passed to user_op()' +! return +! endif + + do i=1, count + cout(i) = cin(i) + cout(i) + enddo + end +C +C Test of reduce scatter. +C +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. +C + + program main + implicit none + include 'mpif.h' + integer errs, ierr, toterr + integer maxsize + parameter (maxsize=1024) + integer sendbuf(maxsize), recvbuf, recvcounts(maxsize) + integer size, rank, i, sumval + integer comm, sumop + external uop + + errs = 0 + + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + + call mpi_comm_size( comm, size, ierr ) + call mpi_comm_rank( comm, rank, ierr ) + + if (size .gt. maxsize) then + endif + do i=1, size + sendbuf(i) = rank + i - 1 + recvcounts(i) = 1 + enddo + + 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) + if (recvbuf .ne. sumval) then + errs = errs + 1 + print *, "Did not get expected value for reduce scatter" + print *, rank, " Got ", recvbuf, " expected ", sumval + endif + + call mpi_op_create( uop, .true., sumop, ierr ) + 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) + if (recvbuf .ne. sumval) then + errs = errs + 1 + print *, "sumop: Did not get expected value for reduce scatter" + print *, rank, " Got ", recvbuf, " expected ", sumval + endif + call mpi_op_free( sumop, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f b/teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f new file mode 100644 index 0000000000..6037308f0d --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f @@ -0,0 +1,97 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2009 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C +C Test Fortran MPI_Reduce_local with MPI_OP_SUM and with user-defined operation. +C + subroutine user_op( invec, outvec, count, datatype ) + implicit none + include 'mpif.h' + integer invec(*), outvec(*) + integer count, datatype + integer ii + + if (datatype .ne. MPI_INTEGER) then + write(6,*) 'Invalid datatype passed to user_op()' + return + endif + + do ii=1, count + outvec(ii) = invec(ii) * 2 + outvec(ii) + enddo + + end + + program main + implicit none + include 'mpif.h' + integer max_buf_size + parameter (max_buf_size=65000) + integer vin(max_buf_size), vout(max_buf_size) + external user_op + integer ierr, errs + integer count, myop + integer ii + + errs = 0 + + call mtest_init(ierr) + + count = 0 + do while (count .le. max_buf_size ) + do ii = 1,count + vin(ii) = ii + vout(ii) = ii + enddo + call mpi_reduce_local( vin, vout, count, + & MPI_INTEGER, MPI_SUM, ierr ) +C Check if the result is correct + do ii = 1,count + if ( vin(ii) .ne. ii ) then + errs = errs + 1 + endif + if ( vout(ii) .ne. 2*ii ) then + errs = errs + 1 + endif + enddo + if ( count .gt. 0 ) then + count = count + count + else + count = 1 + endif + enddo + + call mpi_op_create( user_op, .false., myop, ierr ) + + count = 0 + do while (count .le. max_buf_size) + do ii = 1, count + vin(ii) = ii + vout(ii) = ii + enddo + call mpi_reduce_local( vin, vout, count, + & MPI_INTEGER, myop, ierr ) +C Check if the result is correct + do ii = 1, count + if ( vin(ii) .ne. ii ) then + errs = errs + 1 + endif + if ( vout(ii) .ne. 3*ii ) then + errs = errs + 1 + endif + enddo + if ( count .gt. 0 ) then + count = count + count + else + count = 1 + endif + enddo + + call mpi_op_free( myop, ierr ) + + call mtest_finalize(errs) + call mpi_finalize(ierr) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/split_typef.f b/teshsuite/smpi/mpich3-test/f77/coll/split_typef.f new file mode 100644 index 0000000000..3f3aa3e21e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/split_typef.f @@ -0,0 +1,46 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer i, ans, size, rank, color, comm, newcomm + integer maxSize, displ + parameter (maxSize=128) + integer scounts(maxSize), sdispls(maxSize), stypes(maxSize) + integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize) + integer sbuf(maxSize), rbuf(maxSize) + + errs = 0 + + call mtest_init( ierr ) + + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + + call mpi_comm_split_type( comm, MPI_COMM_TYPE_SHARED, rank, + & MPI_INFO_NULL, newcomm, ierr ) + call mpi_comm_rank( newcomm, rank, ierr ) + call mpi_comm_size( newcomm, size, ierr ) + + do i=1, size + scounts(i) = 1 + sdispls(i) = (i-1) + stypes(i) = MPI_INTEGER + sbuf(i) = rank * size + i + rcounts(i) = 1 + rdispls(i) = (i-1) + rtypes(i) = MPI_INTEGER + rbuf(i) = -1 + enddo + call mpi_alltoallv( sbuf, scounts, sdispls, stypes, + & rbuf, rcounts, rdispls, rtypes, newcomm, ierr ) + + call mpi_comm_free( newcomm, ierr ) + call mpi_comm_free( comm, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/testlist b/teshsuite/smpi/mpich3-test/f77/coll/testlist new file mode 100644 index 0000000000..dd711632c0 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/testlist @@ -0,0 +1,12 @@ +uallreducef 4 +exscanf 5 +#alltoallwf 7 +alltoallvf 7 +inplacef 4 +reducelocalf 2 mpiversion=2.2 +redscatf 4 +split_typef 4 mpiversion=3.0 +nonblockingf 4 mpiversion=3.0 +vw_inplacef 4 mpiversion=2.2 +red_scat_blockf 4 mpiversion=2.2 +nonblocking_inpf 4 mpiversion=3.0 diff --git a/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f b/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f new file mode 100644 index 0000000000..566d294b92 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f @@ -0,0 +1,63 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C +C Test user-defined operations. This tests a simple commutative operation +C + subroutine uop( cin, cout, count, datatype ) + implicit none + include 'mpif.h' + 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 +C endif + + do i=1, count + cout(i) = cin(i) + cout(i) + enddo + end + + program main + implicit none + include 'mpif.h' + external uop + integer ierr, errs + integer count, sumop, vin(65000), vout(65000), i, size + integer comm + + errs = 0 + + call mtest_init(ierr) + call mpi_op_create( uop, .true., sumop, ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_size( comm, size, ierr ) + count = 1 + 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, + * comm, ierr ) +C Check that all results are correct + do i=1, count + if (vout(i) .ne. i * size) then + errs = errs + 1 + if (errs .lt. 10) print *, "vout(",i,") = ", vout(i) + endif + enddo + count = count + count + enddo + + call mpi_op_free( sumop, ierr ) + + call mtest_finalize(errs) + call mpi_finalize(ierr) + end diff --git a/teshsuite/smpi/mpich3-test/f77/coll/vw_inplacef.f b/teshsuite/smpi/mpich3-test/f77/coll/vw_inplacef.f new file mode 100644 index 0000000000..4ad1d4ac36 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/coll/vw_inplacef.f @@ -0,0 +1,109 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw]. +C + program main + implicit none + include 'mpif.h' + integer SIZEOFINT + integer MAX_SIZE + parameter (MAX_SIZE=1024) + integer rbuf(MAX_SIZE) + integer rdispls(MAX_SIZE), rcounts(MAX_SIZE), rtypes(MAX_SIZE) + integer ierr, errs + integer comm, root + integer rank, size + integer iexpected, igot + integer i, j + + errs = 0 + call mtest_init( ierr ) + + comm = MPI_COMM_WORLD + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + call mpi_type_size( MPI_INTEGER, SIZEOFINT, ierr ) + + if (size .gt. MAX_SIZE) then + print *, ' At most ', MAX_SIZE, ' processes allowed' + call mpi_abort( MPI_COMM_WORLD, 1, ierr ) + endif +C + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rbuf(i) = (i-1) * size + rank + enddo + call mpi_alltoall( MPI_IN_PLACE, -1, MPI_DATATYPE_NULL, + $ rbuf, 1, MPI_INTEGER, comm, ierr ) + do i=1,size + if (rbuf(i) .ne. (rank*size + i - 1)) then + errs = errs + 1 + print *, '[', rank, '] rbuf(', i, ') = ', rbuf(i), + $ ', should be', rank * size + i - 1 + endif + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo + do i=1,size + rcounts(i) = (i-1) + rank + rdispls(i) = (i-1) * (2*size) + do j=0,rcounts(i)-1 + rbuf(rdispls(i)+j+1) = 100 * rank + 10 * (i-1) + j + enddo + enddo + call mpi_alltoallv( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + $ rbuf, rcounts, rdispls, MPI_INTEGER, + $ comm, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, '] ALLTOALLV got ', igot, + $ ',but expected ', iexpected, + $ ' for block=', i-1, ' element=', j + endif + enddo + enddo + + do i=1,MAX_SIZE + rbuf(i) = -1 + enddo +C Alltoallw's displs[] are in bytes not in type extents. + do i=1,size + rcounts(i) = (i-1) + rank + rdispls(i) = (i-1) * (2*size) * SIZEOFINT + rtypes(i) = MPI_INTEGER + do j=0,rcounts(i)-1 + rbuf(rdispls(i)/SIZEOFINT+j+1) = 100 * rank + $ + 10 * (i-1) + j + enddo + enddo + call mpi_alltoallw( MPI_IN_PLACE, 0, 0, MPI_DATATYPE_NULL, + $ rbuf, rcounts, rdispls, rtypes, + $ comm, ierr ) + do i=1,size + do j=0,rcounts(i)-1 + iexpected = 100 * (i-1) + 10 * rank + j + igot = rbuf(rdispls(i)/SIZEOFINT+j+1) + if ( igot .ne. iexpected ) then + errs = errs + 1 + print *, '[', rank, '] ALLTOALLW got ', igot, + $ ',but expected ', iexpected, + $ ' for block=', i-1, ' element=', j + endif + enddo + enddo + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt new file mode 100644 index 0000000000..acd9a3debe --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt @@ -0,0 +1,50 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../include/") + + + # add_executable(commerrf commerrf.f ../util/mtestf.f) + add_executable(commnamef commnamef.f ../util/mtestf.f) + + # target_link_libraries(commerrf simgrid) + target_link_libraries(commnamef simgrid) + +# set_target_properties(commerrf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(commnamef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/commerrf.f + ${CMAKE_CURRENT_SOURCE_DIR}/commnamef.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/comm/commerrf.f b/teshsuite/smpi/mpich3-test/f77/comm/commerrf.f new file mode 100644 index 0000000000..e58337f29f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/commerrf.f @@ -0,0 +1,131 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, code(2), newerrclass, eclass + character*(MPI_MAX_ERROR_STRING) errstring + integer comm, rlen + external myerrhanfunc +CF90 INTERFACE +CF90 SUBROUTINE myerrhanfunc(vv0,vv1) +CF90 INTEGER vv0,vv1 +CF90 END SUBROUTINE +CF90 END INTERFACE + integer myerrhan, qerr + integer callcount, codesSeen(3) + common /myerrhan/ callcount, codesSeen + + errs = 0 + callcount = 0 + call mtest_init( ierr ) +C +C Setup some new codes and classes + call mpi_add_error_class( newerrclass, ierr ) + call mpi_add_error_code( newerrclass, code(1), ierr ) + call mpi_add_error_code( newerrclass, code(2), ierr ) + call mpi_add_error_string( newerrclass, "New Class", ierr ) + call mpi_add_error_string( code(1), "First new code", ierr ) + call mpi_add_error_string( code(2), "Second new code", ierr ) +C +C + call mpi_comm_create_errhandler( myerrhanfunc, myerrhan, ierr ) +C +C Create a new communicator so that we can leave the default errors-abort +C on MPI_COMM_WORLD + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) +C + call mpi_comm_set_errhandler( comm, myerrhan, ierr ) + + call mpi_comm_get_errhandler( comm, qerr, ierr ) + if (qerr .ne. myerrhan) then + errs = errs + 1 + print *, ' Did not get expected error handler' + endif + call mpi_errhandler_free( qerr, ierr ) +C We can free our error handler now + call mpi_errhandler_free( myerrhan, ierr ) + + 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 ', + & callcount + else + if (codesSeen(1) .ne. newerrclass) then + errs = errs + 1 + print *, 'Expected class ', newerrclass, ' got ', + & codesSeen(1) + endif + if (codesSeen(2) .ne. code(1)) then + errs = errs + 1 + print *, 'Expected code ', code(1), ' got ', + & codesSeen(2) + endif + if (codesSeen(3) .ne. code(2)) then + errs = errs + 1 + print *, 'Expected code ', code(2), ' got ', + & codesSeen(3) + endif + endif + + call mpi_comm_free( comm, ierr ) +C +C Check error strings while here... + call mpi_error_string( newerrclass, errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "New Class") then + errs = errs + 1 + print *, ' Wrong string for error class: ', errstring(1:rlen) + endif + call mpi_error_class( code(1), eclass, ierr ) + if (eclass .ne. newerrclass) then + errs = errs + 1 + print *, ' Class for new code is not correct' + endif + call mpi_error_string( code(1), errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "First new code") then + errs = errs + 1 + print *, ' Wrong string for error code: ', errstring(1:rlen) + endif + call mpi_error_class( code(2), eclass, ierr ) + if (eclass .ne. newerrclass) then + errs = errs + 1 + print *, ' Class for new code is not correct' + endif + call mpi_error_string( code(2), errstring, rlen, ierr ) + if (errstring(1:rlen) .ne. "Second new code") then + errs = errs + 1 + print *, ' Wrong string for error code: ', errstring(1:rlen) + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end +C + subroutine myerrhanfunc( comm, errcode ) + implicit none + include 'mpif.h' + integer comm, errcode + integer rlen, ierr + integer callcount, codesSeen(3) + character*(MPI_MAX_ERROR_STRING) errstring + common /myerrhan/ callcount, codesSeen + + callcount = callcount + 1 +C Remember the code we've seen + if (callcount .le. 3) then + codesSeen(callcount) = errcode + endif + call mpi_error_string( errcode, errstring, rlen, ierr ) + if (ierr .ne. MPI_SUCCESS) then + print *, ' Panic! could not get error string' + call mpi_abort( MPI_COMM_WORLD, 1, ierr ) + endif + end diff --git a/teshsuite/smpi/mpich3-test/f77/comm/commnamef.f b/teshsuite/smpi/mpich3-test/f77/comm/commnamef.f new file mode 100644 index 0000000000..4ff5caf6de --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/commnamef.f @@ -0,0 +1,82 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + integer comm(4), i, rlen, ln + integer ncomm + character*(MPI_MAX_OBJECT_NAME) inname(4), cname + logical MTestGetIntracomm + + errs = 0 + call mtest_init( ierr ) + +C Test the predefined communicators + do ln=1,MPI_MAX_OBJECT_NAME + cname(ln:ln) = 'X' + enddo + call mpi_comm_get_name( MPI_COMM_WORLD, cname, rlen, ierr ) + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + if (ln .ne. rlen) then + errs = errs + 1 + print *, 'result len ', rlen,' not equal to actual len ', + & ln + endif + goto 110 + endif + enddo + if (cname(1:rlen) .ne. 'MPI_COMM_WORLD') then + errs = errs + 1 + print *, 'Did not get MPI_COMM_WORLD for world' + endif + 110 continue +C + do ln=1,MPI_MAX_OBJECT_NAME + cname(ln:ln) = 'X' + enddo + call mpi_comm_get_name( MPI_COMM_SELF, cname, rlen, ierr ) + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + if (ln .ne. rlen) then + errs = errs + 1 + print *, 'result len ', rlen,' not equal to actual len ', + & ln + endif + goto 120 + endif + enddo + if (cname(1:rlen) .ne. 'MPI_COMM_SELF') then + errs = errs + 1 + print *, 'Did not get MPI_COMM_SELF for world' + endif + 120 continue +C + do i = 1, 4 + if (MTestGetIntracomm( comm(i), 1, .true. )) then + ncomm = i + write( inname(i), '(a,i1)') 'myname',i + call mpi_comm_set_name( comm(i), inname(i), ierr ) + else + goto 130 + endif + enddo + 130 continue +C +C Now test them all + do i=1, ncomm + call mpi_comm_get_name( comm(i), cname, rlen, ierr ) + if (inname(i) .ne. cname) then + errs = errs + 1 + print *, ' Expected ', inname(i), ' got ', cname + endif + call MTestFreeComm( comm(i) ) + enddo +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/comm/testlist b/teshsuite/smpi/mpich3-test/f77/comm/testlist new file mode 100644 index 0000000000..6523065976 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/comm/testlist @@ -0,0 +1,2 @@ +#commnamef 2 +#commerrf 2 diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt new file mode 100644 index 0000000000..91212fbd18 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt @@ -0,0 +1,90 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../include/") + + add_executable(allctypesf allctypesf.f ../util/mtestf.f) + add_executable(gaddressf gaddressf.f ../util/mtestf.f) + add_executable(hindex1f hindex1f.f ../util/mtestf.f) + add_executable(hindexed_blockf hindexed_blockf.f ../util/mtestf.f) + add_executable(packef packef.f ../util/mtestf.f) + add_executable(typeaints typeaints.h ../util/mtestf.f) + add_executable(typecntsf typecntsf.f ../util/mtestf.f) + add_executable(typem2f typem2f.f ../util/mtestf.f) + add_executable(typename3f typename3f.f ../util/mtestf.f) + add_executable(typenamef typenamef.f ../util/mtestf.f) + add_executable(typesnamef typesnamef.f ../util/mtestf.f) + add_executable(typesubf typesubf.f ../util/mtestf.f) + + target_link_libraries(allctypesf simgrid) + target_link_libraries(gaddressf simgrid) + target_link_libraries(hindex1f simgrid) + target_link_libraries(hindexed_blockf simgrid) + target_link_libraries(packef simgrid) + target_link_libraries(typeaints simgrid) + target_link_libraries(typecntsf simgrid) + target_link_libraries(typem2f simgrid) + target_link_libraries(typename3f simgrid) + target_link_libraries(typenamef simgrid) + target_link_libraries(typesnamef simgrid) + target_link_libraries(typesubf simgrid) + + set_target_properties(allctypesf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(gaddressf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(hindex1f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(hindexed_blockf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(packef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typeaints PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typecntsf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typem2f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typename3f PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typenamef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typesnamef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(typesubf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/allctypesf.f + ${CMAKE_CURRENT_SOURCE_DIR}/gaddressf.f + ${CMAKE_CURRENT_SOURCE_DIR}/hindex1f.f + ${CMAKE_CURRENT_SOURCE_DIR}/hindexed_blockf.f + ${CMAKE_CURRENT_SOURCE_DIR}/packef.f + ${CMAKE_CURRENT_SOURCE_DIR}/typeaints.h + ${CMAKE_CURRENT_SOURCE_DIR}/typecntsf.f + ${CMAKE_CURRENT_SOURCE_DIR}/typem2f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typename3f.f + ${CMAKE_CURRENT_SOURCE_DIR}/typenamef.f + ${CMAKE_CURRENT_SOURCE_DIR}/typesnamef.f + ${CMAKE_CURRENT_SOURCE_DIR}/typesubf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + ${CMAKE_CURRENT_SOURCE_DIR}/../util/mtestf.f + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f b/teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f new file mode 100644 index 0000000000..f4c5e3f2d5 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f @@ -0,0 +1,138 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + include 'mpif.h' + integer atype, ierr +C + call mtest_init(ierr) + 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) +C + call checkdtype( MPI_CHAR, "MPI_CHAR", ierr ) + call checkdtype( MPI_SIGNED_CHAR, "MPI_SIGNED_CHAR", ierr ) + call checkdtype( MPI_UNSIGNED_CHAR, "MPI_UNSIGNED_CHAR", ierr ) + call checkdtype( MPI_BYTE, "MPI_BYTE", ierr ) + call checkdtype( MPI_WCHAR, "MPI_WCHAR", ierr ) + call checkdtype( MPI_SHORT, "MPI_SHORT", ierr ) + call checkdtype( MPI_UNSIGNED_SHORT, "MPI_UNSIGNED_SHORT", ierr ) + call checkdtype( MPI_INT, "MPI_INT", ierr ) + call checkdtype( MPI_UNSIGNED, "MPI_UNSIGNED", ierr ) + call checkdtype( MPI_LONG, "MPI_LONG", ierr ) + call checkdtype( MPI_UNSIGNED_LONG, "MPI_UNSIGNED_LONG", ierr ) + call checkdtype( MPI_FLOAT, "MPI_FLOAT", ierr ) + call checkdtype( MPI_DOUBLE, "MPI_DOUBLE", ierr ) + if (MPI_LONG_DOUBLE .ne. MPI_DATATYPE_NULL) then + 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", + * "MPI_LONG_LONG", ierr ) + endif + if (MPI_UNSIGNED_LONG_LONG .ne. MPI_DATATYPE_NULL) then + 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", + * "MPI_LONG_LONG_INT", ierr ) + endif + call checkdtype( MPI_PACKED, "MPI_PACKED", ierr ) + call checkdtype( MPI_LB, "MPI_LB", ierr ) + call checkdtype( MPI_UB, "MPI_UB", ierr ) + call checkdtype( MPI_FLOAT_INT, "MPI_FLOAT_INT", ierr ) + call checkdtype( MPI_DOUBLE_INT, "MPI_DOUBLE_INT", ierr ) + call checkdtype( MPI_LONG_INT, "MPI_LONG_INT", ierr ) + call checkdtype( MPI_SHORT_INT, "MPI_SHORT_INT", ierr ) + call checkdtype( MPI_2INT, "MPI_2INT", ierr ) + if (MPI_LONG_DOUBLE_INT .ne. MPI_DATATYPE_NULL) then + call checkdtype( MPI_LONG_DOUBLE_INT, "MPI_LONG_DOUBLE_INT", + * ierr) + endif +C +C Check that all Ctypes are available in Fortran (MPI 2.2) +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. + * 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_INT32_T, "MPI_INT32_T", ierr ) + call checkdtype( MPI_INT64_T, "MPI_INT64_T", ierr ) + call checkdtype( MPI_UINT8_T, "MPI_UINT8_T", ierr ) + call checkdtype( MPI_UINT16_T, "MPI_UINT16_T", ierr ) + call checkdtype( MPI_UINT32_T, "MPI_UINT32_T", ierr ) + call checkdtype( MPI_UINT64_T, "MPI_UINT64_T", ierr ) +C other C99 types + 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", + * "MPI_C_FLOAT_COMPLEX", ierr ) + 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, + * "MPI_C_LONG_DOUBLE_COMPLEX", ierr ) + endif +C address/offset types + call checkdtype( MPI_AINT, "MPI_AINT", ierr ) + call checkdtype( MPI_OFFSET, "MPI_OFFSET", ierr ) + endif +C + call mtest_finalize( ierr ) + call MPI_Finalize( ierr ) + end +C +C Check name of datatype + subroutine CheckDtype( intype, name, ierr ) + include 'mpif.h' + integer intype, ierr + character *(*) name + integer ir, rlen + character *(MPI_MAX_OBJECT_NAME) outname +C + outname = "" + call MPI_TYPE_GET_NAME( intype, outname, rlen, ir ) + if (ir .ne. MPI_SUCCESS) then + print *, " Datatype ", name, " not available in Fortran" + ierr = ierr + 1 + else + if (outname .ne. name) then + print *, " For datatype ", name, " found name ", + * outname(1:rlen) + ierr = ierr + 1 + endif + endif + + return + end +C +C Check name of datatype (allows alias) + subroutine CheckDtype2( intype, name, name2, ierr ) + include 'mpif.h' + integer intype, ierr + character *(*) name, name2 + integer ir, rlen + character *(MPI_MAX_OBJECT_NAME) outname +C + outname = "" + call MPI_TYPE_GET_NAME( intype, outname, rlen, ir ) + if (ir .ne. MPI_SUCCESS) then + print *, " Datatype ", name, " not available in Fortran" + ierr = ierr + 1 + else + if (outname .ne. name .and. outname .ne. name2) then + print *, " For datatype ", name, " found name ", + * outname(1:rlen) + ierr = ierr + 1 + endif + endif + + return + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/gaddressf.f b/teshsuite/smpi/mpich3-test/f77/datatype/gaddressf.f new file mode 100644 index 0000000000..4dba0f2a04 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/gaddressf.f @@ -0,0 +1,38 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer max_asizev + parameter (max_asizev=2) + include 'typeaints.h' + integer iarray(200), gap, intsize + integer ierr, errs + + errs = 0 + + call MPI_Init(ierr) + + call MPI_Get_address( iarray(1), aintv(1), ierr ) + call MPI_Get_address( iarray(200), aintv(2), ierr ) + gap = aintv(2) - aintv(1) + + call MPI_Type_size( MPI_INTEGER, intsize, ierr ) + + if (gap .ne. 199 * intsize) then + errs = errs + 1 + print *, ' Using get_address, computed a gap of ', gap + print *, ' Expected a gap of ', 199 * intsize + endif + if (errs .gt. 0) then + print *, ' Found ', errs, ' errors' + else + print *, ' No Errors' + endif + + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/hindex1f.f b/teshsuite/smpi/mpich3-test/f77/datatype/hindex1f.f new file mode 100644 index 0000000000..1a689ed629 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/hindex1f.f @@ -0,0 +1,61 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2011 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, intsize + integer i, displs(10), counts(10), dtype + integer bufsize + parameter (bufsize=100) + integer inbuf(bufsize), outbuf(bufsize), packbuf(bufsize) + integer position, len, psize +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 ) + call mpi_type_commit( dtype, ierr ) +C + call mpi_pack_size( 1, dtype, MPI_COMM_WORLD, psize, ierr ) + if (psize .gt. bufsize*intsize) then + errs = errs + 1 + else + do i=1,10 + inbuf(i) = i + outbuf(i) = -i + enddo + position = 0 + call mpi_pack( inbuf, 1, dtype, packbuf, psize, position, + $ MPI_COMM_WORLD, ierr ) +C + len = position + position = 0 + call mpi_unpack( packbuf, len, position, outbuf, 10, + $ MPI_INTEGER, MPI_COMM_WORLD, ierr ) +C + do i=1, 10 + if (outbuf(i) .ne. 11-i) then + errs = errs + 1 + print *, 'outbuf(',i,')=',outbuf(i),', expected ', 10-i + endif + enddo + endif +C + call mpi_type_free( dtype, ierr ) +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/hindexed_blockf.f b/teshsuite/smpi/mpich3-test/f77/datatype/hindexed_blockf.f new file mode 100644 index 0000000000..8dc00a8e85 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/hindexed_blockf.f @@ -0,0 +1,178 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, i, intsize + integer type1, type2, type3, type4, type5 + integer max_asizev + parameter (max_asizev = 10) + include 'typeaints.h' + integer blocklens(max_asizev), dtypes(max_asizev) + integer displs(max_asizev) + integer recvbuf(6*max_asizev) + integer sendbuf(max_asizev), status(MPI_STATUS_SIZE) + integer rank, size + + errs = 0 + + call mtest_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) +C + call mpi_type_size( MPI_INTEGER, intsize, ierr ) +C + aintv(1) = 0 + aintv(2) = 3 * intsize + call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), + & type1, ierr ) + call mpi_type_commit( type1, ierr ) + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected lb' + endif + if (aintv(2) .ne. 3*intsize) then + errs = errs + 1 + print *, 'Did not get expected extent' + endif + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected true lb' + endif + if (aintv(2) .ne. intsize) then + errs = errs + 1 + print *, 'Did not get expected true extent (', aintv(2), ') ', + & ' expected ', intsize + endif +C + do i=1,10 + blocklens(i) = 1 + aintv(i) = (i-1) * 3 * intsize + enddo + 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, + & ierr ) + call mpi_type_commit( type3, ierr ) +C + do i=1,10 + blocklens(i) = 1 + dtypes(i) = MPI_INTEGER + aintv(i) = (i-1) * 3 * intsize + enddo + call mpi_type_create_struct( 10, blocklens, aintv, dtypes, + & type4, ierr ) + call mpi_type_commit( type4, ierr ) + + call mpi_type_get_extent(MPI_INTEGER, aintv(1), aint, ierr) + do i=1,10 + aintv(i) = (i-1) * 3 * aint + enddo + call mpi_type_create_hindexed_block( 10, 1, aintv, + & MPI_INTEGER, type5, ierr ) + call mpi_type_commit( type5, ierr ) +C +C Using each time, send and receive using these types + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + 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, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + call mpi_type_free( type1, ierr ) + call mpi_type_free( type2, ierr ) + call mpi_type_free( type3, ierr ) + call mpi_type_free( type4, ierr ) + call mpi_type_free( type5, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/packef.f b/teshsuite/smpi/mpich3-test/f77/datatype/packef.f new file mode 100644 index 0000000000..f91e91f7a9 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/packef.f @@ -0,0 +1,187 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, errs + integer inbuf(10), ioutbuf(10), inbuf2(10), ioutbuf2(10) + integer i, insize, rsize, csize, insize2 + character*(16) cbuf, coutbuf + double precision rbuf(10), routbuf(10) + integer packbuf(1000), pbufsize, intsize + integer max_asizev + parameter (max_asizev = 3) + include 'typeaints.h' + + errs = 0 + call mtest_init( ierr ) + + call mpi_type_size( MPI_INTEGER, intsize, ierr ) + pbufsize = 1000 * intsize + + 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 ) + 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 ) + 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 + errs = errs + 1 + print *, 'Expected 6 for size of 3 external32 INTEGER*2', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 3, MPI_INTEGER4, + & aint, ierr ) + if (aint .ne. 3 * 4) then + errs = errs + 1 + print *, 'Expected 12 for size of 3 external32 INTEGER*4', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 3, MPI_REAL4, + & aint, ierr ) + if (aint .ne. 3 * 4) then + errs = errs + 1 + print *, 'Expected 12 for size of 3 external32 REAL*4', + & ', got ', aint + endif + call mpi_pack_external_size( 'external32', 3, MPI_REAL8, + & aint, ierr ) + if (aint .ne. 3 * 8) then + errs = errs + 1 + print *, 'Expected 24 for size of 3 external32 REAL*8', + & ', got ', aint + endif + if (MPI_INTEGER1 .ne. MPI_DATATYPE_NULL) then + call mpi_pack_external_size( 'external32', 3, MPI_INTEGER1, + & aint, ierr ) + if (aint .ne. 3 * 1) then + errs = errs + 1 + print *, 'Expected 3 for size of 3 external32 INTEGER*1', + & ', got ', aint + endif + endif + if (MPI_INTEGER8 .ne. MPI_DATATYPE_NULL) then + call mpi_pack_external_size( 'external32', 3, MPI_INTEGER8, + & aint, ierr ) + if (aint .ne. 3 * 8) then + errs = errs + 1 + print *, 'Expected 24 for size of 3 external32 INTEGER*8', + & ', got ', aint + endif + endif + +C +C Initialize values +C + insize = 10 + do i=1, insize + inbuf(i) = i + enddo + rsize = 3 + do i=1, rsize + rbuf(i) = 1000.0 * i + enddo + cbuf = 'This is a string' + csize = 16 + insize2 = 7 + do i=1, insize2 + inbuf2(i) = 5000-i + enddo +C + aintv(1) = pbufsize + aintv(2) = 0 + aintv(3) = 0 +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, + & packbuf, aintv(1), aintv(2), ierr ) + if (aintv(2) .le. aintv(3)) then + 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), + & 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), + & 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, + & MPI_INTEGER, + & packbuf, aintv(1), aintv(2), ierr ) + if (aintv(2) .le. aintv(3)) then + print *, ' Position decreased after pack of integer (2nd)!' + endif + aintv(3) = aintv(2) +C +C We could try sending this with MPI_BYTE... + aintv(2) = 0 + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), ioutbuf, insize, MPI_INTEGER, ierr ) + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), routbuf, rsize, MPI_DOUBLE_PRECISION, ierr ) + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), coutbuf, csize, MPI_CHARACTER, ierr ) + call mpi_unpack_external( 'external32', packbuf, aintv(1), + & aintv(2), ioutbuf2, insize2, MPI_INTEGER, ierr ) +C +C Now, test the values +C + do i=1, insize + if (ioutbuf(i) .ne. i) then + errs = errs + 1 + print *, 'ioutbuf(',i,') = ', ioutbuf(i), ' expected ', i + endif + enddo + do i=1, rsize + if (routbuf(i) .ne. 1000.0 * i) then + errs = errs + 1 + print *, 'routbuf(',i,') = ', routbuf(i), ' expected ', & + & 1000.0 * i + endif + enddo + if (coutbuf(1:csize) .ne. 'This is a string') then + errs = errs + 1 + print *, 'coutbuf = ', coutbuf(1:csize), ' expected ', & + & 'This is a string' + endif + do i=1, insize2 + if (ioutbuf2(i) .ne. 5000-i) then + errs = errs + 1 + print *, 'ioutbuf2(',i,') = ', ioutbuf2(i), ' expected ', & + & 5000-i + endif + enddo +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/testlist b/teshsuite/smpi/mpich3-test/f77/datatype/testlist new file mode 100644 index 0000000000..5da0524bf3 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/testlist @@ -0,0 +1,11 @@ +#typenamef 1 +#typename3f 1 mpiversion=3.0 +#typesnamef 1 +#typecntsf 1 +#typem2f 1 +#typesubf 1 +#packef 1 +gaddressf 1 +#allctypesf 1 +#hindex1f 1 +#hindexed_blockf 1 mpiversion=3.0 diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typeaints.h b/teshsuite/smpi/mpich3-test/f77/datatype/typeaints.h new file mode 100644 index 0000000000..ded63b03fc --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typeaints.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer aint, aintv(max_asizev) diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.f b/teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.f new file mode 100644 index 0000000000..2bd194c9e4 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.f @@ -0,0 +1,91 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + 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 MPI-2 datatype routines (which use address-sized integers) +C + + errs = 0 + call mtest_init( ierr ) + + 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, + & 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 ) + end +C + subroutine explore( dtype, mycomb, errs ) + implicit none + include 'mpif.h' + integer dtype, mycomb, errs + integer ierr + integer nints, nadds, ntype, combiner + integer max_nints, max_dtypes, max_asizev + parameter (max_nints = 10, max_dtypes = 10, max_asizev=10) + integer intv(max_nints), dtypesv(max_dtypes) + include 'typeaints.h' +C + call mpi_type_get_envelope( dtype, nints, nadds, ntype, + & combiner, ierr ) +C + if (combiner .ne. MPI_COMBINER_NAMED) then + call mpi_type_get_contents( dtype, + & max_nints, max_asizev, max_dtypes, + & intv, aintv, dtypesv, ierr ) +C +C dtypesv of constructed types must be free'd now +C + if (combiner .eq. MPI_COMBINER_DUP) then + call mpi_type_free( dtypesv(1), ierr ) + endif + endif + if (combiner .ne. mycomb) then + errs = errs + 1 + print *, ' Expected combiner ', mycomb, ' but got ', + & combiner + endif +C +C List all combiner types to check that they are defined in mpif.h + if (combiner .eq. MPI_COMBINER_NAMED) then + else if (combiner .eq. MPI_COMBINER_DUP) then + else if (combiner .eq. MPI_COMBINER_CONTIGUOUS) then + else if (combiner .eq. MPI_COMBINER_VECTOR) then + else if (combiner .eq. MPI_COMBINER_HVECTOR_INTEGER) then + else if (combiner .eq. MPI_COMBINER_HVECTOR) then + else if (combiner .eq. MPI_COMBINER_INDEXED) then + else if (combiner .eq. MPI_COMBINER_HINDEXED_INTEGER) then + else if (combiner .eq. MPI_COMBINER_HINDEXED) then + else if (combiner .eq. MPI_COMBINER_INDEXED_BLOCK) then + else if (combiner .eq. MPI_COMBINER_STRUCT_INTEGER) then + else if (combiner .eq. MPI_COMBINER_STRUCT) then + else if (combiner .eq. MPI_COMBINER_SUBARRAY) then + else if (combiner .eq. MPI_COMBINER_DARRAY) then + else if (combiner .eq. MPI_COMBINER_F90_REAL) then + else if (combiner .eq. MPI_COMBINER_F90_COMPLEX) then + else if (combiner .eq. MPI_COMBINER_F90_INTEGER) then + else if (combiner .eq. MPI_COMBINER_RESIZED) then + else + errs = errs + 1 + print *, ' Unknown combiner ', combiner + endif + + return + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f b/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f new file mode 100644 index 0000000000..32e9af4330 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f @@ -0,0 +1,177 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr, i, intsize + integer type1, type2, type3, type4, type5 + integer max_asizev + parameter (max_asizev = 10) + include 'typeaints.h' + integer blocklens(max_asizev), dtypes(max_asizev) + integer displs(max_asizev) + integer recvbuf(6*max_asizev) + integer sendbuf(max_asizev), status(MPI_STATUS_SIZE) + integer rank, size + + errs = 0 + + call mtest_init( ierr ) + + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) +C + call mpi_type_size( MPI_INTEGER, intsize, ierr ) +C + aintv(1) = 0 + aintv(2) = 3 * intsize + call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), + & type1, ierr ) + call mpi_type_commit( type1, ierr ) + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected lb' + endif + if (aintv(2) .ne. 3*intsize) then + errs = errs + 1 + print *, 'Did not get expected extent' + endif + aintv(1) = -1 + aintv(2) = -1 + call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr ) + if (aintv(1) .ne. 0) then + errs = errs + 1 + print *, 'Did not get expected true lb' + endif + if (aintv(2) .ne. intsize) then + errs = errs + 1 + print *, 'Did not get expected true extent (', aintv(2), ') ', + & ' expected ', intsize + endif +C + do i=1,10 + blocklens(i) = 1 + aintv(i) = (i-1) * 3 * intsize + enddo + 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, + & ierr ) + call mpi_type_commit( type3, ierr ) +C + do i=1,10 + blocklens(i) = 1 + dtypes(i) = MPI_INTEGER + aintv(i) = (i-1) * 3 * intsize + enddo + call mpi_type_create_struct( 10, blocklens, aintv, dtypes, + & type4, ierr ) + call mpi_type_commit( type4, ierr ) + + do i=1,10 + displs(i) = (i-1) * 3 + enddo + call mpi_type_create_indexed_block( 10, 1, displs, + & MPI_INTEGER, type5, ierr ) + call mpi_type_commit( type5, ierr ) +C +C Using each time, send and receive using these types + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + 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, + & MPI_COMM_WORLD, status, ierr ) + do i=1, max_asizev + if (recvbuf(1+(i-1)*3) .ne. i ) then + errs = errs + 1 + print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + do i=1, max_asizev*3 + recvbuf(i) = -1 + enddo + do i=1, max_asizev + sendbuf(i) = i + enddo + 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 + errs = errs + 1 + print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3) + endif + enddo +C + call mpi_type_free( type1, ierr ) + call mpi_type_free( type2, ierr ) + call mpi_type_free( type3, ierr ) + call mpi_type_free( type4, ierr ) + call mpi_type_free( type5, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typename3f.f b/teshsuite/smpi/mpich3-test/f77/datatype/typename3f.f new file mode 100644 index 0000000000..17414d0e41 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typename3f.f @@ -0,0 +1,41 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + character*(MPI_MAX_OBJECT_NAME) name + integer namelen + integer ierr, errs + + errs = 0 + + call mtest_init( ierr ) +C +C Check each Fortran datatype, including the size-specific ones +C See the C version (typename.c) for the relevant MPI sections + + call MPI_Type_get_name( MPI_AINT, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_AINT") then + errs = errs + 1 + print *, "Expected MPI_AINT but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_OFFSET, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_OFFSET") then + errs = errs + 1 + print *, "Expected MPI_OFFSET but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_COUNT, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COUNT") then + errs = errs + 1 + print *, "Expected MPI_COUNT but got "//name(1:namelen) + endif + + call mtest_finalize( errs ) + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typenamef.f b/teshsuite/smpi/mpich3-test/f77/datatype/typenamef.f new file mode 100644 index 0000000000..611fbcfda1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typenamef.f @@ -0,0 +1,205 @@ +C -*- Mode: Fortran; -*- +C +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + character*(MPI_MAX_OBJECT_NAME) name + integer namelen + integer ierr, errs + + errs = 0 + + call mtest_init( ierr ) +C +C Check each Fortran datatype, including the size-specific ones +C See the C version (typename.c) for the relevant MPI sections + + call MPI_Type_get_name( MPI_COMPLEX, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_DOUBLE_COMPLEX, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_DOUBLE_COMPLEX") then + errs = errs + 1 + print *, "Expected MPI_DOUBLE_COMPLEX but got "// + & name(1:namelen) + endif + + call MPI_Type_get_name( MPI_LOGICAL, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_LOGICAL") then + errs = errs + 1 + print *, "Expected MPI_LOGICAL but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_REAL, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL") then + errs = errs + 1 + print *, "Expected MPI_REAL but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_DOUBLE_PRECISION, name, namelen, ierr) + if (name(1:namelen) .ne. "MPI_DOUBLE_PRECISION") then + errs = errs + 1 + print *, "Expected MPI_DOUBLE_PRECISION but got "// + & name(1:namelen) + endif + + call MPI_Type_get_name( MPI_INTEGER, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER") then + errs = errs + 1 + print *, "Expected MPI_INTEGER but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_2INTEGER, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_2INTEGER") then + errs = errs + 1 + print *, "Expected MPI_2INTEGER but got "//name(1:namelen) + endif + +C 2COMPLEX was present only in MPI 1.0 +C call MPI_Type_get_name( MPI_2COMPLEX, name, namelen, ierr ) +C if (name(1:namelen) .ne. "MPI_2COMPLEX") then +C errs = errs + 1 +C print *, "Expected MPI_2COMPLEX but got "//name(1:namelen) +C endif +C + call MPI_Type_get_name(MPI_2DOUBLE_PRECISION, name, namelen, ierr) + if (name(1:namelen) .ne. "MPI_2DOUBLE_PRECISION") then + errs = errs + 1 + print *, "Expected MPI_2DOUBLE_PRECISION but got "// + & name(1:namelen) + endif + + call MPI_Type_get_name( MPI_2REAL, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_2REAL") then + errs = errs + 1 + print *, "Expected MPI_2REAL but got "//name(1:namelen) + endif + +C 2DOUBLE_COMPLEX isn't in MPI 2.1 +C call MPI_Type_get_name( MPI_2DOUBLE_COMPLEX, name, namelen, ierr ) +C if (name(1:namelen) .ne. "MPI_2DOUBLE_COMPLEX") then +C errs = errs + 1 +C print *, "Expected MPI_2DOUBLE_COMPLEX but got "// +C & name(1:namelen) +C endif + + call MPI_Type_get_name( MPI_CHARACTER, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_CHARACTER") then + errs = errs + 1 + print *, "Expected MPI_CHARACTER but got "//name(1:namelen) + endif + + call MPI_Type_get_name( MPI_BYTE, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_BYTE") then + errs = errs + 1 + print *, "Expected MPI_BYTE but got "//name(1:namelen) + endif + + if (MPI_REAL4 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_REAL4, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL4") then + errs = errs + 1 + print *, "Expected MPI_REAL4 but got "//name(1:namelen) + endif + endif + + if (MPI_REAL8 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_REAL8, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL8") then + errs = errs + 1 + print *, "Expected MPI_REAL8 but got "//name(1:namelen) + endif + endif + + if (MPI_REAL16 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_REAL16, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_REAL16") then + errs = errs + 1 + print *, "Expected MPI_REAL16 but got "//name(1:namelen) + endif + endif + + if (MPI_COMPLEX8 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_COMPLEX8, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX8") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX8 but got "// + & name(1:namelen) + endif + endif + + if (MPI_COMPLEX16 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_COMPLEX16, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX16") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX16 but got "// + & name(1:namelen) + endif + endif + + if (MPI_COMPLEX32 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_COMPLEX32, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_COMPLEX32") then + errs = errs + 1 + print *, "Expected MPI_COMPLEX32 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER1 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER1, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER1") then + errs = errs + 1 + print *, "Expected MPI_INTEGER1 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER2 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER2, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER2") then + errs = errs + 1 + print *, "Expected MPI_INTEGER2 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER4 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER4, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER4") then + errs = errs + 1 + print *, "Expected MPI_INTEGER4 but got "// + & name(1:namelen) + endif + endif + + if (MPI_INTEGER8 .ne. MPI_DATATYPE_NULL) then + call MPI_Type_get_name( MPI_INTEGER8, name, namelen, ierr ) + if (name(1:namelen) .ne. "MPI_INTEGER8") then + errs = errs + 1 + print *, "Expected MPI_INTEGER8 but got "// + & name(1:namelen) + endif + endif + +C MPI_INTEGER16 is in MPI 2.1, but it is missing from most tables +C Some MPI implementations may not provide it +C if (MPI_INTEGER16 .ne. MPI_DATATYPE_NULL) then +C call MPI_Type_get_name( MPI_INTEGER16, name, namelen, ierr ) +C if (name(1:namelen) .ne. "MPI_INTEGER16") then +C errs = errs + 1 +C print *, "Expected MPI_INTEGER16 but got "// +C & name(1:namelen) +C endif +C endif + + call mtest_finalize( errs ) + call MPI_Finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typesnamef.f b/teshsuite/smpi/mpich3-test/f77/datatype/typesnamef.f new file mode 100644 index 0000000000..b958c4998e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typesnamef.f @@ -0,0 +1,67 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + character*(MPI_MAX_OBJECT_NAME) cname + integer rlen, ln + integer ntype1, ntype2, errs, ierr + + errs = 0 + + call MTest_Init( ierr ) + + call mpi_type_vector( 10, 1, 100, MPI_INTEGER, ntype1, ierr ) + rlen = -1 + cname = 'XXXXXX' + call mpi_type_get_name( ntype1, cname, rlen, ierr ) + if (rlen .ne. 0) then + errs = errs + 1 + print *, ' Expected length 0, got ', rlen + endif + rlen = 0 + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + rlen = ln + goto 100 + endif + enddo + 100 continue + if (rlen .ne. 0) then + errs = errs + 1 + print *, 'Datatype name is not all blank' + endif +C +C now add a name, then dup + call mpi_type_set_name( ntype1, 'a vector type', ierr ) + call mpi_type_dup( ntype1, ntype2, ierr ) + rlen = -1 + cname = 'XXXXXX' + call mpi_type_get_name( ntype2, cname, rlen, ierr ) + if (rlen .ne. 0) then + errs = errs + 1 + print *, ' (type2) Expected length 0, got ', rlen + endif + rlen = 0 + do ln=MPI_MAX_OBJECT_NAME,1,-1 + if (cname(ln:ln) .ne. ' ') then + rlen = ln + goto 110 + endif + enddo + 110 continue + if (rlen .ne. 0) then + 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 ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f b/teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f new file mode 100644 index 0000000000..f175149231 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f @@ -0,0 +1,73 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + integer maxn, maxm + parameter (maxn=10,maxm=15) + integer fullsizes(2), subsizes(2), starts(2) + integer fullarr(maxn,maxm),subarr(maxn-3,maxm-4) + integer i,j, ssize + integer newtype, size, rank, ans + + errs = 0 + call mtest_init( ierr ) + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) +C +C Create a Fortran-style subarray + fullsizes(1) = maxn + fullsizes(2) = maxm + subsizes(1) = maxn - 3 + subsizes(2) = maxm - 4 +C starts are from zero, even in Fortran + starts(1) = 1 + starts(2) = 2 +C In Fortran 90 notation, the original array is +C integer a(maxn,maxm) +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, + & MPI_ORDER_FORTRAN, MPI_INTEGER, newtype, ierr ) + call mpi_type_commit( newtype, ierr ) +C +C Prefill the array + do j=1, maxm + do i=1, maxn + fullarr(i,j) = (i-1) + (j-1) * maxn + enddo + enddo + do j=1, subsizes(2) + do i=1, subsizes(1) + subarr(i,j) = -1 + enddo + enddo + ssize = subsizes(1)*subsizes(2) + 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 + do j=1, subsizes(2) + do i=1, subsizes(1) + ans = (i+starts(1)-1) + (j+starts(2)-1) * maxn + if (subarr(i,j) .ne. ans) then + errs = errs + 1 + if (errs .le. 10) then + print *, rank, 'subarr(',i,',',j,') = ', subarr(i,j) + endif + endif + enddo + enddo + + call mpi_type_free( newtype, ierr ) + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt new file mode 100644 index 0000000000..ade7a6a298 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt @@ -0,0 +1,60 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../include/") + + + add_executable(add1size add1size.h ../util/mtestf.f) +# add_executable(allocmemf allocmemf.f ../util/mtestf.f) +# add_executable(c2f2cf c2f2cf.f c2f2c.c ../util/mtestf.f) +# add_executable(ctypesinf ctypesinf.f ctypesfromc.c ../util/mtestf.f) + + target_link_libraries(add1size simgrid) +# target_link_libraries(allocmemf simgrid) +# target_link_libraries(c2f2cf simgrid) +# target_link_libraries(ctypesinf simgrid) + + set_target_properties(add1size PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(allocmemf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(c2f2cf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") +# set_target_properties(ctypesinf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/add1size.h + ${CMAKE_CURRENT_SOURCE_DIR}/allocmemf.f + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2cf.f + ${CMAKE_CURRENT_SOURCE_DIR}/c2f2c.c + ${CMAKE_CURRENT_SOURCE_DIR}/ctypesinf.f + ${CMAKE_CURRENT_SOURCE_DIR}/ctypesfromc.c + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/ext/add1size.h b/teshsuite/smpi/mpich3-test/f77/ext/add1size.h new file mode 100644 index 0000000000..940a4c315a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/add1size.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer asize diff --git a/teshsuite/smpi/mpich3-test/f77/ext/allocmemf.f b/teshsuite/smpi/mpich3-test/f77/ext/allocmemf.f new file mode 100644 index 0000000000..cc8792d672 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/allocmemf.f @@ -0,0 +1,41 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2004 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' +C +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. +C To run it, build (with a suitable compiler) and run with +C mpiexec -n 1 ./allocmemf +C + real a + pointer (p,a(100,100)) + include 'add1size.h' + integer ierr, sizeofreal, errs + integer i,j +C + errs = 0 + call mtest_init(ierr) + call mpi_type_size( MPI_REAL, sizeofreal, ierr ) +C Make sure we pass in an integer of the correct type + asize = sizeofreal * 100 * 100 + call mpi_alloc_mem( asize,MPI_INFO_NULL,p,ierr ) + + do i=1,100 + do j=1,100 + a(i,j) = -1 + enddo + enddo + a(3,5) = 10.0 + + call mpi_free_mem( a, ierr ) + call mtest_finalize(errs) + call mpi_finalize(ierr) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/ext/c2f2c.c b/teshsuite/smpi/mpich3-test/f77/ext/c2f2c.c new file mode 100644 index 0000000000..4e048b272f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/c2f2c.c @@ -0,0 +1,263 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * + * (C) 2001 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ +/* + * This file contains the C routines used in testing the c2f and f2c + * handle conversion functions, except for MPI_File and MPI_Win (to + * allow working with MPI implementations that do not include those + * features). + * + * The tests follow this pattern: + * + * Fortran main program + * calls c routine with each handle type, with a prepared + * and valid handle (often requires constructing an object) + * + * C routine uses xxx_f2c routine to get C handle, checks some + * properties (i.e., size and rank of communicator, contents of datatype) + * + * Then the Fortran main program calls a C routine that provides + * a handle, and the Fortran program performs similar checks. + * + * We also assume that a C int is a Fortran integer. If this is not the + * case, these tests must be modified. + */ + +/* style: allow:fprintf:10 sig:0 */ +#include +#include "mpi.h" +#include "../../include/mpitestconf.h" +#include + +/* + Name mapping. All routines are created with names that are lower case + with a single trailing underscore. This matches many compilers. + We use #define to change the name for Fortran compilers that do + not use the lowercase/underscore pattern +*/ + +#ifdef F77_NAME_UPPER +#define c2fcomm_ C2FCOMM +#define c2fgroup_ C2FGROUP +#define c2ftype_ C2FTYPE +#define c2finfo_ C2FINFO +#define c2frequest_ C2FREQUEST +#define c2fop_ C2FOP +#define c2ferrhandler_ C2FERRHANDLER + +#define f2ccomm_ F2CCOMM +#define f2cgroup_ F2CGROUP +#define f2ctype_ F2CTYPE +#define f2cinfo_ F2CINFO +#define f2crequest_ F2CREQUEST +#define f2cop_ F2COP +#define f2cerrhandler_ F2CERRHANDLER + +#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED) +/* Mixed is ok because we use lowercase in all uses */ +#define c2fcomm_ c2fcomm +#define c2fgroup_ c2fgroup +#define c2ftype_ c2ftype +#define c2finfo_ c2finfo +#define c2frequest_ c2frequest +#define c2fop_ c2fop +#define c2ferrhandler_ c2ferrhandler + +#define f2ccomm_ f2ccomm +#define f2cgroup_ f2cgroup +#define f2ctype_ f2ctype +#define f2cinfo_ f2cinfo +#define f2crequest_ f2crequest +#define f2cop_ f2cop +#define f2cerrhandler_ f2cerrhandler + +#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \ + defined(F77_NAME_MIXED_USCORE) +/* Else leave name alone (routines have no underscore, so both + of these map to a lowercase, single underscore) */ +#else +#error 'Unrecognized Fortran name mapping' +#endif + +/* Prototypes to keep compilers happy */ +MPI_Fint c2fcomm_( MPI_Fint * ); +MPI_Fint c2fgroup_( MPI_Fint * ); +MPI_Fint c2finfo_( MPI_Fint * ); +MPI_Fint c2frequest_( MPI_Fint * ); +MPI_Fint c2ftype_( MPI_Fint * ); +MPI_Fint c2fop_( MPI_Fint * ); +MPI_Fint c2ferrhandler_( MPI_Fint * ); + +void f2ccomm_( MPI_Fint * ); +void f2cgroup_( MPI_Fint * ); +void f2cinfo_( MPI_Fint * ); +void f2crequest_( MPI_Fint * ); +void f2ctype_( MPI_Fint * ); +void f2cop_( MPI_Fint * ); +void f2cerrhandler_( MPI_Fint * ); + + +MPI_Fint c2fcomm_ (MPI_Fint *comm) +{ + MPI_Comm cComm = MPI_Comm_f2c(*comm); + int cSize, wSize, cRank, wRank; + + MPI_Comm_size( MPI_COMM_WORLD, &wSize ); + MPI_Comm_rank( MPI_COMM_WORLD, &wRank ); + MPI_Comm_size( cComm, &cSize ); + MPI_Comm_rank( cComm, &cRank ); + + if (wSize != cSize || wRank != cRank) { + fprintf( stderr, "Comm: Did not get expected size,rank (got %d,%d)", + cSize, cRank ); + return 1; + } + return 0; +} + +MPI_Fint c2fgroup_ (MPI_Fint *group) +{ + MPI_Group cGroup = MPI_Group_f2c(*group); + int cSize, wSize, cRank, wRank; + + /* We pass in the group of comm world */ + MPI_Comm_size( MPI_COMM_WORLD, &wSize ); + MPI_Comm_rank( MPI_COMM_WORLD, &wRank ); + MPI_Group_size( cGroup, &cSize ); + MPI_Group_rank( cGroup, &cRank ); + + if (wSize != cSize || wRank != cRank) { + fprintf( stderr, "Group: Did not get expected size,rank (got %d,%d)", + cSize, cRank ); + return 1; + } + return 0; +} + +MPI_Fint c2ftype_ ( MPI_Fint *type ) +{ + MPI_Datatype dtype = MPI_Type_f2c( *type ); + + if (dtype != MPI_INTEGER) { + fprintf( stderr, "Type: Did not get expected type\n" ); + return 1; + } + return 0; +} + +MPI_Fint c2finfo_ ( MPI_Fint *info ) +{ + MPI_Info cInfo = MPI_Info_f2c( *info ); + int flag; + char value[100]; + MPI_Fint errs = 0; + + MPI_Info_get( cInfo, (char*)"host", sizeof(value), value, &flag ); + if (!flag || strcmp(value,"myname") != 0) { + fprintf( stderr, "Info: Wrong value or no value for host\n" ); + errs++; + } + MPI_Info_get( cInfo, (char*)"wdir", sizeof(value), value, &flag ); + if (!flag || strcmp( value, "/rdir/foo" ) != 0) { + fprintf( stderr, "Info: Wrong value of no value for wdir\n" ); + errs++; + } + + return errs; +} + +MPI_Fint c2frequest_ ( MPI_Fint *request ) +{ + MPI_Request req = MPI_Request_f2c( *request ); + MPI_Status status; + int flag; + MPI_Test( &req, &flag, &status ); + MPI_Test_cancelled( &status, &flag ); + if (!flag) { + fprintf( stderr, "Request: Wrong value for flag\n" ); + return 1; + } + else { + *request = MPI_Request_c2f( req ); + } + return 0; +} + +MPI_Fint c2fop_ ( MPI_Fint *op ) +{ + MPI_Op cOp = MPI_Op_f2c( *op ); + + if (cOp != MPI_SUM) { + fprintf( stderr, "Op: did not get sum\n" ); + return 1; + } + return 0; +} + +MPI_Fint c2ferrhandler_ ( MPI_Fint *errh ) +{ + MPI_Errhandler errhand = MPI_Errhandler_f2c( *errh ); + + if (errhand != MPI_ERRORS_RETURN) { + fprintf( stderr, "Errhandler: did not get errors return\n" ); + return 1; + } + + return 0; +} + +/* + * The following routines provide handles to the calling Fortran program + */ +void f2ccomm_( MPI_Fint * comm ) +{ + *comm = MPI_Comm_c2f( MPI_COMM_WORLD ); +} + +void f2cgroup_( MPI_Fint * group ) +{ + MPI_Group wgroup; + MPI_Comm_group( MPI_COMM_WORLD, &wgroup ); + *group = MPI_Group_c2f( wgroup ); +} + +void f2ctype_( MPI_Fint * type ) +{ + *type = MPI_Type_c2f( MPI_INTEGER ); +} + +void f2cinfo_( MPI_Fint * info ) +{ + MPI_Info cinfo; + + MPI_Info_create( &cinfo ); + MPI_Info_set( cinfo, (char*)"host", (char*)"myname" ); + MPI_Info_set( cinfo, (char*)"wdir", (char*)"/rdir/foo" ); + + *info = MPI_Info_c2f( cinfo ); +} + +void f2crequest_( MPI_Fint * req ) +{ + MPI_Request cReq; + + MPI_Irecv( NULL, 0, MPI_INT, MPI_ANY_SOURCE, MPI_ANY_TAG, + MPI_COMM_WORLD, &cReq ); + MPI_Cancel( &cReq ); + *req = MPI_Request_c2f( cReq ); + +} + +void f2cop_( MPI_Fint * op ) +{ + *op = MPI_Op_c2f( MPI_SUM ); +} + +void f2cerrhandler_( MPI_Fint *errh ) +{ + *errh = MPI_Errhandler_c2f( MPI_ERRORS_RETURN ); +} + diff --git a/teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f b/teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f new file mode 100644 index 0000000000..175592572d --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f @@ -0,0 +1,121 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer errs, toterrs, ierr + integer wrank, wsize + integer wgroup, info, req + integer fsize, frank + integer comm, group, type, op, errh, result + integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest, + $ c2ferrhandler, c2fop + character value*100 + logical flag + errs = 0 + + call mpi_init( ierr ) + +C +C Test passing a Fortran MPI object to C + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) + errs = errs + c2fcomm( MPI_COMM_WORLD ) + call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr ) + errs = errs + c2fgroup( wgroup ) + call mpi_group_free( wgroup, ierr ) + + call mpi_info_create( info, ierr ) + call mpi_info_set( info, "host", "myname", ierr ) + call mpi_info_set( info, "wdir", "/rdir/foo", ierr ) + errs = errs + c2finfo( info ) + call mpi_info_free( info, ierr ) + + errs = errs + c2ftype( MPI_INTEGER ) + + call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG, + $ MPI_COMM_WORLD, req, ierr ) + call mpi_cancel( req, ierr ) + errs = errs + c2frequest( req ) + call mpi_wait( req, MPI_STATUS_IGNORE, ierr ) + + errs = errs + c2ferrhandler( MPI_ERRORS_RETURN ) + + errs = errs + c2fop( MPI_SUM ) + +C +C Test using a C routine to provide the Fortran handle + call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) + + call f2ccomm( comm ) + call mpi_comm_size( comm, fsize, ierr ) + call mpi_comm_rank( comm, frank, ierr ) + if (fsize.ne.wsize .or. frank.ne.wrank) then + errs = errs + 1 + print *, "Comm(fortran) has wrong size or rank" + endif + + call f2cgroup( group ) + call mpi_group_size( group, fsize, ierr ) + call mpi_group_rank( group, frank, ierr ) + if (fsize.ne.wsize .or. frank.ne.wrank) then + errs = errs + 1 + print *, "Group(fortran) has wrong size or rank" + endif + call mpi_group_free( group, ierr ) + + call f2ctype( type ) + if (type .ne. MPI_INTEGER) then + errs = errs + 1 + print *, "Datatype(fortran) is not MPI_INT" + endif + + call f2cinfo( info ) + call mpi_info_get( info, "host", 100, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Info test for host returned false" + else if (value .ne. "myname") then + errs = errs + 1 + print *, "Info test for host returned ", value + endif + call mpi_info_get( info, "wdir", 100, value, flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, "Info test for wdir returned false" + else if (value .ne. "/rdir/foo") then + errs = errs + 1 + print *, "Info test for wdir returned ", value + endif + call mpi_info_free( info, ierr ) + + call f2cop( op ) + if (op .ne. MPI_SUM) then + errs = errs + 1 + print *, "Fortran MPI_SUM not MPI_SUM in C" + endif + + call f2cerrhandler( errh ) + if (errh .ne. MPI_ERRORS_RETURN) then + errs = errs + 1 + print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C" + endif +C +C Summarize the errors +C + call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, + $ MPI_COMM_WORLD, ierr ) + if (wrank .eq. 0) then + if (toterrs .eq. 0) then + print *, ' No Errors' + else + print *, ' Found ', toterrs, ' errors' + endif + endif + + call mpi_finalize( ierr ) + end + diff --git a/teshsuite/smpi/mpich3-test/f77/ext/c2fmult.c b/teshsuite/smpi/mpich3-test/f77/ext/c2fmult.c new file mode 100644 index 0000000000..07c21d6e36 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/c2fmult.c @@ -0,0 +1,60 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * (C) 2001 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ + +/* + Check that MPI_xxxx_c2f, applied to the same object several times, + yields the same handle. We do this because when MPI handles in + C are a different length than those in Fortran, care needs to + be exercised to ensure that the mapping from one to another is unique. + (Test added to test a potential problem in ROMIO for handling MPI_File + on 64-bit systems) +*/ +#include "mpi.h" +#include +#include "mpitest.h" + +int main( int argc, char *argv[] ) +{ + MPI_Fint handleA, handleB; + int rc; + int errs = 0; + int buf[1]; + MPI_Request cRequest; + MPI_Status st; + int tFlag; + + MTest_Init( &argc, &argv ); + + /* Request */ + rc = MPI_Irecv( buf, 1, MPI_INT, 0, 0, MPI_COMM_WORLD, &cRequest ); + if (rc) { + errs++; + printf( "Unable to create request\n" ); + } + else { + handleA = MPI_Request_c2f( cRequest ); + handleB = MPI_Request_c2f( cRequest ); + if (handleA != handleB) { + errs++; + printf( "MPI_Request_c2f does not give the same handle twice on the same MPI_Request\n" ); + } + } + MPI_Cancel( &cRequest ); + MPI_Test( &cRequest, &tFlag, &st ); + MPI_Test_cancelled( &st, &tFlag ); + if (!tFlag) { + errs++; + printf( "Unable to cancel MPI_Irecv request\n" ); + } + /* Using MPI_Request_free should be ok, but some MPI implementations + object to it imediately after the cancel and that isn't essential to + this test */ + + MTest_Finalize( errs ); + MPI_Finalize(); + + return 0; +} diff --git a/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c b/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c new file mode 100644 index 0000000000..51015da908 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c @@ -0,0 +1,118 @@ +/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */ +/* + * + * (C) 2008 by Argonne National Laboratory. + * See COPYRIGHT in top-level directory. + */ +/* + * This file contains the C routines used in testing that all C datatypes + * are available in Fortran and have the correct values. + * + * The tests follow this pattern: + * + * Fortran main program + * calls the c routine f2ctype with each of the C types and the name of + * the type. That c routine using MPI_Type_f2c to convert the + * Fortran handle to a C handle, and then compares it to the corresponding + * C type, which is found by looking up the C handle by name + * + * C routine uses xxx_f2c routine to get C handle, checks some + * properties (i.e., size and rank of communicator, contents of datatype) + * + * Then the Fortran main program calls a C routine that provides + * a handle, and the Fortran program performs similar checks. + * + * We also assume that a C int is a Fortran integer. If this is not the + * case, these tests must be modified. + */ + +/* style: allow:fprintf:10 sig:0 */ +#include +#include "mpi.h" +#include "../../include/mpitestconf.h" +#include + +/* Create an array with all of the MPI names in it */ +/* This is extracted from the test in test/mpi/types/typename.c ; only the + C types are included. */ + +typedef struct mpi_names_t { MPI_Datatype dtype; const char *name; } mpi_names_t; + +/* The MPI standard specifies that the names must be the MPI names, + not the related language names (e.g., MPI_CHAR, not char) */ + +static mpi_names_t mpi_names[] = { + { MPI_CHAR, "MPI_CHAR" }, + { MPI_SIGNED_CHAR, "MPI_SIGNED_CHAR" }, + { MPI_UNSIGNED_CHAR, "MPI_UNSIGNED_CHAR" }, + { MPI_WCHAR, "MPI_WCHAR" }, + { MPI_SHORT, "MPI_SHORT" }, + { MPI_UNSIGNED_SHORT, "MPI_UNSIGNED_SHORT" }, + { MPI_INT, "MPI_INT" }, + { MPI_UNSIGNED, "MPI_UNSIGNED" }, + { MPI_LONG, "MPI_LONG" }, + { MPI_UNSIGNED_LONG, "MPI_UNSIGNED_LONG" }, + { MPI_FLOAT, "MPI_FLOAT" }, + { MPI_DOUBLE, "MPI_DOUBLE" }, + { MPI_FLOAT_INT, "MPI_FLOAT_INT" }, + { MPI_DOUBLE_INT, "MPI_DOUBLE_INT" }, + { MPI_LONG_INT, "MPI_LONG_INT" }, + { MPI_SHORT_INT, "MPI_SHORT_INT" }, + { MPI_2INT, "MPI_2INT" }, + { MPI_LONG_DOUBLE, "MPI_LONG_DOUBLE" }, + { MPI_LONG_LONG_INT, "MPI_LONG_LONG_INT" }, + { MPI_LONG_LONG, "MPI_LONG_LONG" }, + { MPI_UNSIGNED_LONG_LONG, "MPI_UNSIGNED_LONG_LONG" }, + { MPI_LONG_DOUBLE_INT, "MPI_LONG_DOUBLE_INT" }, + { 0, (char *)0 }, /* Sentinal used to indicate the last element */ +}; + +/* + Name mapping. All routines are created with names that are lower case + with a single trailing underscore. This matches many compilers. + We use #define to change the name for Fortran compilers that do + not use the lowercase/underscore pattern +*/ + +#ifdef F77_NAME_UPPER +#define f2ctype_ F2CTYPE + +#elif defined(F77_NAME_LOWER) || defined(F77_NAME_MIXED) +/* Mixed is ok because we use lowercase in all uses */ +#define f2ctype_ f2ctype + +#elif defined(F77_NAME_LOWER_2USCORE) || defined(F77_NAME_LOWER_USCORE) || \ + defined(F77_NAME_MIXED_USCORE) +/* Else leave name alone (routines have no underscore, so both + of these map to a lowercase, single underscore) */ +#else +#error 'Unrecognized Fortran name mapping' +#endif + +/* Prototypes to keep compilers happy */ +int f2ctype_( MPI_Fint *, MPI_Fint * ); + +/* */ +int f2ctype_( MPI_Fint *fhandle, MPI_Fint *typeidx ) +{ + int errs = 0; + MPI_Datatype ctype; + + /* printf( "Testing %s\n", mpi_names[*typeidx].name ); */ + ctype = MPI_Type_f2c( *fhandle ); + if (ctype != mpi_names[*typeidx].dtype) { + char mytypename[MPI_MAX_OBJECT_NAME]; + int mytypenamelen; + /* An implementation is not *required* to deliver the + corresponding C version of the MPI Datatype bit-for-bit. But + if *must* act like it - e.g., the datatype name must be the same */ + MPI_Type_get_name( ctype, mytypename, &mytypenamelen ); + if (strcmp( mytypename, mpi_names[*typeidx].name ) != 0) { + errs++; + printf( "C and Fortran types for %s (c name is %s) do not match f=%d, ctof=%d.\n", + mpi_names[*typeidx].name, mytypename, *fhandle, MPI_Type_c2f( ctype ) ); + } + } + + return errs; +} diff --git a/teshsuite/smpi/mpich3-test/f77/ext/ctypesinf.f b/teshsuite/smpi/mpich3-test/f77/ext/ctypesinf.f new file mode 100644 index 0000000000..4693bc87c1 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/ctypesinf.f @@ -0,0 +1,49 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2010 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + include 'mpif.h' + integer ierr + integer errs, wrank + integer f2ctype +C + call mtest_init( ierr ) + call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr ) +C + errs = 0 +C + errs = errs + f2ctype( MPI_CHAR, 0 ) + errs = errs + f2ctype( MPI_SIGNED_CHAR, 1 ) + errs = errs + f2ctype( MPI_UNSIGNED_CHAR, 2 ) + errs = errs + f2ctype( MPI_WCHAR, 3 ) + errs = errs + f2ctype( MPI_SHORT, 4 ) + errs = errs + f2ctype( MPI_UNSIGNED_SHORT, 5 ) + errs = errs + f2ctype( MPI_INT, 6 ) + errs = errs + f2ctype( MPI_UNSIGNED, 7 ) + errs = errs + f2ctype( MPI_LONG, 8 ) + errs = errs + f2ctype( MPI_UNSIGNED_LONG, 9 ) + errs = errs + f2ctype( MPI_FLOAT, 10 ) + errs = errs + f2ctype( MPI_DOUBLE, 11 ) + errs = errs + f2ctype( MPI_FLOAT_INT, 12 ) + errs = errs + f2ctype( MPI_DOUBLE_INT, 13 ) + errs = errs + f2ctype( MPI_LONG_INT, 14 ) + errs = errs + f2ctype( MPI_SHORT_INT, 15 ) + errs = errs + f2ctype( MPI_2INT, 16 ) + if (MPI_LONG_DOUBLE .ne. MPI_TYPE_NULL) then + errs = errs + f2ctype( MPI_LONG_DOUBLE, 17 ) + errs = errs + f2ctype( MPI_LONG_DOUBLE_INT, 21 ) + endif + if (MPI_LONG_LONG .ne. MPI_TYPE_NULL) then + errs = errs + f2ctype( MPI_LONG_LONG_INT, 18 ) + errs = errs + f2ctype( MPI_LONG_LONG, 19 ) + errs = errs + f2ctype( MPI_UNSIGNED_LONG_LONG, 20 ) + endif +C +C Summarize the errors +C + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + + end diff --git a/teshsuite/smpi/mpich3-test/f77/ext/testlist b/teshsuite/smpi/mpich3-test/f77/ext/testlist new file mode 100644 index 0000000000..745768e0cb --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/ext/testlist @@ -0,0 +1,4 @@ +#c2f2cf 1 +#c2fmult 1 +#ctypesinf 1 + diff --git a/teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt new file mode 100644 index 0000000000..363d9ffb7e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt @@ -0,0 +1,43 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../include/") + + add_executable(baseenvf baseenvf.f ../util/mtestf.f) + target_link_libraries(baseenvf simgrid) + set_target_properties(baseenvf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/baseenvf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/init/baseenvf.f b/teshsuite/smpi/mpich3-test/f77/init/baseenvf.f new file mode 100644 index 0000000000..b8b1f6ca0f --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/baseenvf.f @@ -0,0 +1,90 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer ierr, provided, errs, rank, size + integer iv, isubv, qprovided + logical flag + + errs = 0 + flag = .true. + call mpi_finalized( flag, ierr ) + if (flag) then + errs = errs + 1 + print *, 'Returned true for finalized before init' + endif + flag = .true. + call mpi_initialized( flag, ierr ) + if (flag) then + errs = errs + 1 + print *, 'Return true for initialized before init' + endif + + provided = -1 + call mpi_init_thread( MPI_THREAD_MULTIPLE, provided, ierr ) + + if (provided .ne. MPI_THREAD_MULTIPLE .and. + & provided .ne. MPI_THREAD_SERIALIZED .and. + & provided .ne. MPI_THREAD_FUNNELED .and. + & provided .ne. MPI_THREAD_SINGLE) then + errs = errs + 1 + print *, ' Unrecognized value for provided = ', provided + endif + + iv = -1 + isubv = -1 + call mpi_get_version( iv, isubv, ierr ) + if (iv .ne. MPI_VERSION .or. isubv .ne. MPI_SUBVERSION) then + errs = errs + 1 + print *, 'Version in mpif.h and get_version do not agree' + print *, 'Version in mpif.h is ', MPI_VERSION, '.', + & MPI_SUBVERSION + print *, 'Version in get_version is ', iv, '.', isubv + endif + if (iv .lt. 1 .or. iv .gt. 3) then + errs = errs + 1 + print *, 'Version of MPI is invalid (=', iv, ')' + endif + if (isubv.lt.0 .or. isubv.gt.2) then + errs = errs + 1 + print *, 'Subversion of MPI is invalid (=', isubv, ')' + endif + + call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr ) + call mpi_comm_size( MPI_COMM_WORLD, size, ierr ) + + flag = .false. + call mpi_is_thread_main( flag, ierr ) + if (.not.flag) then + errs = errs + 1 + print *, 'is_thread_main returned false for main thread' + endif + + call mpi_query_thread( qprovided, ierr ) + if (qprovided .ne. provided) then + errs = errs + 1 + print *,'query thread and init thread disagree on'// + & ' thread level' + endif + + call mpi_finalize( ierr ) + flag = .false. + call mpi_finalized( flag, ierr ) + if (.not. flag) then + errs = errs + 1 + print *, 'finalized returned false after finalize' + endif + + if (rank .eq. 0) then + if (errs .eq. 0) then + print *, ' No Errors' + else + print *, ' Found ', errs, ' errors' + endif + endif + + end diff --git a/teshsuite/smpi/mpich3-test/f77/init/checksizes.c b/teshsuite/smpi/mpich3-test/f77/init/checksizes.c new file mode 100644 index 0000000000..e91dc8d7d6 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/checksizes.c @@ -0,0 +1,23 @@ +#include "mpi.h" +#include +int main( int argc, char **argv ) +{ + int fsizeof_aint = ; + int fsizeof_offset = ; + int err = 0, rc = 0; + + MPI_Init( &argc, &argv ); + if (sizeof(MPI_Aint) != fsizeof_aint) { + printf( "Sizeof MPI_Aint is %d but Fortran thinks it is %d\n", + (int)sizeof(MPI_Aint), fsizeof_aint ); + err++; + } + if (sizeof(MPI_Offset) != fsizeof_offset) { + printf( "Sizeof MPI_Offset is %d but Fortran thinks it is %d\n", + (int)sizeof(MPI_Offset), fsizeof_offset ); + err++; + } + MPI_Finalize( ); + if (err > 0) rc = 1; + return rc; +} diff --git a/teshsuite/smpi/mpich3-test/f77/init/testlist b/teshsuite/smpi/mpich3-test/f77/init/testlist new file mode 100644 index 0000000000..0b0b623fd2 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/init/testlist @@ -0,0 +1 @@ +baseenvf 1 diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt b/teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt new file mode 100644 index 0000000000..2d99d0695e --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt @@ -0,0 +1,60 @@ +cmake_minimum_required(VERSION 2.6) + +if(enable_smpi) + if(WIN32) + set(CMAKE_C_FLAGS "-include ${CMAKE_HOME_DIRECTORY}/include/smpi/smpi_main.h") + else() + set(CMAKE_C_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpicc") + set(CMAKE_Fortran_COMPILER "${CMAKE_BINARY_DIR}/smpi_script/bin/smpiff") + endif() + + set(EXECUTABLE_OUTPUT_PATH "${CMAKE_CURRENT_BINARY_DIR}") + set(MPICH_FLAGS "-DHAVE_STDLIB_H=1 -DHAVE_UNISTD_H=1 -DHAVE_STRING_H=1 -DUSE_STDARG=1 -DHAVE_LONG_DOUBLE=1 -DHAVE_PROTOTYPES=1 -DHAVE_SIGNAL_H=1 -DHAVE_SIGACTION=1 -DHAVE_SLEEP=1 -DHAVE_SYSCONF=1 -Wno-error=unused-variable -Wno-implicit") + include_directories("${CMAKE_HOME_DIRECTORY}/include/smpi") + include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../include/") + + + add_executable(allpairf allpairf.f ../util/mtestf.f) + add_executable(greqf greqf.f dummyf.f ../util/mtestf.f) + #add_executable(mprobef mprobef.f ../util/mtestf.f) + add_executable(statusesf statusesf.f ../util/mtestf.f) + + target_link_libraries(allpairf simgrid) + target_link_libraries(greqf simgrid) + #target_link_libraries(mprobef simgrid) + target_link_libraries(statusesf simgrid) + + set_target_properties(allpairf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(greqf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + #set_target_properties(mprobef PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + set_target_properties(statusesf PROPERTIES COMPILE_FLAGS "${MPICH_FLAGS}") + +endif() + +set(tesh_files + ${tesh_files} + PARENT_SCOPE + ) +set(xml_files + ${xml_files} + PARENT_SCOPE + ) +set(examples_src + ${examples_src} + ${CMAKE_CURRENT_SOURCE_DIR}/allpairf.f + ${CMAKE_CURRENT_SOURCE_DIR}/attr1aints.h + ${CMAKE_CURRENT_SOURCE_DIR}/dummyf.f + ${CMAKE_CURRENT_SOURCE_DIR}/greqf.f + ${CMAKE_CURRENT_SOURCE_DIR}/mprobef.f + ${CMAKE_CURRENT_SOURCE_DIR}/statusesf.f + PARENT_SCOPE + ) +set(bin_files + ${bin_files} + PARENT_SCOPE + ) +set(txt_files + ${txt_files} + ${CMAKE_CURRENT_SOURCE_DIR}/testlist + PARENT_SCOPE + ) diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f new file mode 100644 index 0000000000..750c56816c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f @@ -0,0 +1,1029 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C +C This program is based on the allpair.f test from the MPICH-1 test +C (test/pt2pt/allpair.f), which in turn was inspired by a bug report from +C fsset@corelli.lerc.nasa.gov (Scott Townsend) + + program allpair + implicit none + include 'mpif.h' + integer ierr, errs, comm + logical mtestGetIntraComm + logical verbose + common /flags/ verbose + + errs = 0 + verbose = .false. +C verbose = .true. + call MTest_Init( ierr ) + + do while ( mtestGetIntraComm( comm, 2, .false. ) ) + call test_pair_send( comm, errs ) + call test_pair_ssend( comm, errs ) + !call test_pair_rsend( comm, errs ) + call test_pair_isend( comm, errs ) + !call test_pair_irsend( comm, errs ) + call test_pair_issend( comm, errs ) + !call test_pair_psend( comm, errs ) + !call test_pair_prsend( comm, errs ) + call test_pair_pssend( comm, errs ) + call test_pair_sendrecv( comm, errs ) + call test_pair_sendrecvrepl( comm, errs ) + call mtestFreeComm( comm ) + enddo +C + call MTest_Finalize( errs ) + call MPI_Finalize(ierr) +C + end +C + subroutine test_pair_send( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Send and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 1123 + count = TEST_SIZE / 5 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Send(send_buf, count, MPI_REAL, next, tag, + . comm, ierr) +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr) +C + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'send and recv', errs ) + else if (prev .eq. 0) then + 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) + end if +C + end +C + subroutine test_pair_rsend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(1) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Rsend and recv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 1456 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + 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) +C + call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr) +C + if (status(MPI_SOURCE) .ne. next) then + print *, 'Rsend: Incorrect source, expected', next, + . ', got', status(MPI_SOURCE) + errs = errs + 1 + end if +C + if (status(MPI_TAG) .ne. tag) then + print *, 'Rsend: Incorrect tag, expected', tag, + . ', got', status(MPI_TAG) + errs = errs + 1 + end if +C + call MPI_Get_count(status, MPI_REAL, i, ierr) +C + if (i .ne. count) then + print *, 'Rsend: Incorrect count, expected', count, + . ', got', i + errs = errs + 1 + end if +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'rsend and recv', errs ) +C + else if (prev .eq. 0) then +C + 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, + . 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) + end if +C + end +C + subroutine test_pair_ssend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Ssend and recv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 1789 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Iprobe(MPI_ANY_SOURCE, tag, + . comm, flag, status, ierr) +C + if (flag) then + 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) +C + do while (.not. flag) + call MPI_Iprobe(MPI_ANY_SOURCE, tag, + . comm, flag, status, ierr) + end do +C + if (status(MPI_SOURCE) .ne. next) then + print *, 'Ssend: Incorrect source, expected', next, + . ', got', status(MPI_SOURCE) + errs = errs + 1 + end if +C + if (status(MPI_TAG) .ne. tag) then + print *, 'Ssend: Incorrect tag, expected', tag, + . ', got', status(MPI_TAG) + errs = errs + 1 + end if +C + call MPI_Get_count(status, MPI_REAL, i, ierr) +C + if (i .ne. count) then + print *, 'Ssend: Incorrect count, expected', count, + . ', got', i + errs = errs + 1 + end if +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, next, tag, count, status, + . TEST_SIZE, 'ssend and recv', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'ssend and recv', errs ) +C + call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag, + . comm, ierr) + end if +C + end +C + subroutine test_pair_isend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(2) + integer statuses(MPI_STATUS_SIZE,2) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' isend and irecv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 2123 + count = TEST_SIZE / 5 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Isend(send_buf, count, MPI_REAL, next, tag, + . comm, requests(2), ierr) +C + call MPI_Waitall(2, requests, statuses, ierr) +C + call rq_check( requests, 2, 'isend and irecv' ) +C + call msg_check( recv_buf, next, tag, count, statuses(1,1), + . TEST_SIZE, 'isend and irecv', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . status, ierr) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'isend and irecv', errs ) +C + call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + call MPI_Wait(requests(1), status, ierr) +C +C call rq_check( requests(1), 1, 'isend and irecv' ) +C + end if +C + end +C + subroutine test_pair_irsend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index, i + integer TEST_SIZE + integer dupcom + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(2) + integer statuses(MPI_STATUS_SIZE,2) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Irsend and irecv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + call mpi_comm_dup( comm, dupcom, ierr ) +C + tag = 2456 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +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, + . dupcom, status, ierr ) +C + call MPI_Irsend(send_buf, count, MPI_REAL, next, tag, + . comm, requests(2), ierr) +C + index = -1 + do while (index .ne. 1) + call MPI_Waitany(2, requests, index, statuses, ierr) + end do +C + call rq_check( requests(1), 1, 'irsend and irecv' ) +C + call msg_check( recv_buf, next, tag, count, statuses, + . TEST_SIZE, 'irsend and irecv', errs ) +C + else if (prev .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . 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, + . dupcom, status, ierr ) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Test(requests(1), flag, status, ierr) + end do +C + call rq_check( requests, 1, 'irsend and irecv (test)' ) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'irsend and irecv', errs ) +C + call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + call MPI_Waitall(1, requests, statuses, ierr) +C + call rq_check( requests, 1, 'irsend and irecv' ) +C + end if +C + call mpi_comm_free( dupcom, ierr ) +C + end +C + subroutine test_pair_issend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE), requests(2) + integer statuses(MPI_STATUS_SIZE,2) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' issend and irecv (testall)' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 2789 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + if (rank .eq. 0) then +C + call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), 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) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Testall(2, requests, flag, statuses, ierr) + end do +C + call rq_check( requests, 2, 'issend and irecv (testall)' ) +C + call msg_check( recv_buf, next, tag, count, statuses(1,1), + . TEST_SIZE, 'issend and recv (testall)', errs ) +C + else if (prev .eq. 0) then +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, + . 'issend and recv', errs ) + + call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Testany(1, requests(1), index, flag, + . statuses(1,1), ierr) + end do +C + call rq_check( requests, 1, 'issend and recv (testany)' ) +C + end if +C + end +C + subroutine test_pair_psend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + integer statuses(MPI_STATUS_SIZE,2), requests(2) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Persistent send and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 3123 + count = TEST_SIZE / 5 +C + call clear_test_data(recv_buf,TEST_SIZE) + call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(2), ierr) +C + if (rank .eq. 0) then +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Send_init(send_buf, count, MPI_REAL, next, tag, + . comm, requests(1), ierr) +C + 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), + . TEST_SIZE, 'persistent send/recv', errs ) +C + call MPI_Request_free(requests(1), ierr) +C + 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) + call MPI_Wait(requests(2), status, ierr) +C + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + * 'persistent send/recv', errs ) +C + do i = 1,count + send_buf(i) = recv_buf(i) + end do +C + call MPI_Start(requests(1), ierr) + call MPI_Wait(requests(1), status, ierr) +C + call MPI_Request_free(requests(1), ierr) + end if +C + call dummyRef( send_buf, count, ierr ) + call MPI_Request_free(requests(2), ierr) +C + end +C + subroutine test_pair_prsend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index, i + integer outcount, indices(2) + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer statuses(MPI_STATUS_SIZE,2), requests(2) + integer status(MPI_STATUS_SIZE) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Persistent Rsend and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 3456 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(2), ierr) +C + if (rank .eq. 0) then +C + call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag, + . comm, requests(1), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, + . comm, status, ierr ) +C + call MPI_Startall(2, requests, ierr) +C + index = -1 +C + do while (index .ne. 2) + call MPI_Waitsome(2, requests, outcount, + . indices, statuses, ierr) + do i = 1,outcount + if (indices(i) .eq. 2) then + call msg_check( recv_buf, next, tag, count, + . statuses(1,i), TEST_SIZE, 'waitsome', errs ) + index = 2 + end if + end do + end do +C + call MPI_Request_free(requests(1), ierr) + else if (prev .eq. 0) then +C + call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag, + . comm, requests(1), ierr) +C + call MPI_Start(requests(2), ierr) +C + call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, + . comm, ierr ) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Test(requests(2), flag, status, ierr) + end do + call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, + . 'test', errs ) +C + do i = 1,count + send_buf(i) = recv_buf(i) + end do +C + call MPI_Start(requests(1), ierr) + call MPI_Wait(requests(1), status, ierr) +C + call MPI_Request_free(requests(1), ierr) + end if +C + call dummyRef( send_buf, count, ierr ) + call MPI_Request_free(requests(2), ierr) +C + end +C + subroutine test_pair_pssend( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, index, i + integer outcount, indices(2) + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer statuses(MPI_STATUS_SIZE,2), requests(2) + integer status(MPI_STATUS_SIZE) + logical flag + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Persistent Ssend and recv' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 3789 + count = TEST_SIZE / 3 +C + call clear_test_data(recv_buf,TEST_SIZE) +C + call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, + . MPI_ANY_SOURCE, MPI_ANY_TAG, comm, + . requests(1), ierr) +C + if (rank .eq. 0) then +C + call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag, + . comm, requests(2), ierr) +C + call init_test_data(send_buf,TEST_SIZE) +C + call MPI_Startall(2, requests, ierr) +C + index = -1 + do while (index .ne. 1) + call MPI_Testsome(2, requests, outcount, + . indices, statuses, ierr) + do i = 1,outcount + if (indices(i) .eq. 1) then + call msg_check( recv_buf, next, tag, count, + . statuses(1,i), TEST_SIZE, 'testsome', errs ) + index = 1 + end if + end do + end do +C + call MPI_Request_free(requests(2), ierr) +C + else if (prev .eq. 0) then +C + call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag, + . comm, requests(2), ierr) +C + call MPI_Start(requests(1), ierr) +C + flag = .FALSE. + do while (.not. flag) + call MPI_Testany(1, requests(1), index, flag, + . statuses(1,1), ierr) + end do + call msg_check( recv_buf, prev, tag, count, statuses(1,1), + . TEST_SIZE, 'testany', errs ) + + do i = 1,count + send_buf(i) = recv_buf(i) + end do +C + call MPI_Start(requests(2), ierr) + call MPI_Wait(requests(2), status, ierr) +C + call MPI_Request_free(requests(2), ierr) +C + end if +C + call dummyRef( send_buf, count, ierr ) + call MPI_Request_free(requests(1), ierr) +C + end +C + subroutine test_pair_sendrecv( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Sendrecv' + endif +C +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 4123 + count = TEST_SIZE / 5 + + call clear_test_data(recv_buf,TEST_SIZE) + + if (rank .eq. 0) then + + call init_test_data(send_buf,TEST_SIZE) + + call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag, + . recv_buf, count, MPI_REAL, next, tag, + . comm, status, ierr) + + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'sendrecv', errs ) + + else if (prev .eq. 0) then + + 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, + . 'recv/send', errs ) + + call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, + . comm, ierr) + end if +C + end +C + subroutine test_pair_sendrecvrepl( comm, errs ) + implicit none + include 'mpif.h' + integer comm, errs + integer rank, size, ierr, next, prev, tag, count, i + integer TEST_SIZE + parameter (TEST_SIZE=2000) + integer status(MPI_STATUS_SIZE) + real send_buf(TEST_SIZE), recv_buf(TEST_SIZE) + logical verbose + common /flags/ verbose +C + if (verbose) then + print *, ' Sendrecv replace' + endif +C + call mpi_comm_rank( comm, rank, ierr ) + call mpi_comm_size( comm, size, ierr ) + next = rank + 1 + if (next .ge. size) next = 0 +C + prev = rank - 1 + if (prev .lt. 0) prev = size - 1 +C + tag = 4456 + count = TEST_SIZE / 3 + + if (rank .eq. 0) then +C + call init_test_data(recv_buf, TEST_SIZE) +C + do 11 i = count+1,TEST_SIZE + recv_buf(i) = 0.0 + 11 continue +C + call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL, + . next, tag, next, tag, + . comm, status, ierr) + + call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, + . 'sendrecvreplace', errs ) + + else if (prev .eq. 0) then + + call clear_test_data(recv_buf,TEST_SIZE) + + 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, + . 'recv/send for replace', errs ) + + call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, + . comm, ierr) + end if +C + end +C +c------------------------------------------------------------------------------ +c +c Check for correct source, tag, count, and data in test message. +c +c------------------------------------------------------------------------------ + subroutine msg_check( recv_buf, source, tag, count, status, n, + * name, errs ) + implicit none + include 'mpif.h' + integer n, errs + real recv_buf(n) + integer source, tag, count, rank, status(MPI_STATUS_SIZE) + character*(*) name + logical foundError + + integer ierr, recv_src, recv_tag, recv_count + + foundError = .false. + recv_src = status(MPI_SOURCE) + recv_tag = status(MPI_TAG) + call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr ) + call MPI_Get_count(status, MPI_REAL, recv_count, ierr) + + if (recv_src .ne. source) then + print *, '[', rank, '] Unexpected source:', recv_src, + * ' in ', name + errs = errs + 1 + foundError = .true. + end if + + if (recv_tag .ne. tag) then + print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name + errs = errs + 1 + foundError = .true. + end if + + if (recv_count .ne. count) then + print *, '[', rank, '] Unexpected count:', recv_count, + * ' in ', name + errs = errs + 1 + foundError = .true. + end if + + call verify_test_data(recv_buf, count, n, name, errs ) + + end +c------------------------------------------------------------------------------ +c +c Check that requests have been set to null +c +c------------------------------------------------------------------------------ + subroutine rq_check( requests, n, msg ) + include 'mpif.h' + integer n, requests(n) + character*(*) msg + integer i +c + do 10 i=1, n + if (requests(i) .ne. MPI_REQUEST_NULL) then + print *, 'Nonnull request in ', msg + endif + 10 continue +c + end +c------------------------------------------------------------------------------ +c +c Initialize test data buffer with integral sequence. +c +c------------------------------------------------------------------------------ + subroutine init_test_data(buf,n) + integer n + real buf(n) + integer i + + do 10 i = 1, n + buf(i) = REAL(i) + 10 continue + end + +c------------------------------------------------------------------------------ +c +c Clear test data buffer +c +c------------------------------------------------------------------------------ + subroutine clear_test_data(buf, n) + integer n + real buf(n) + integer i + + do 10 i = 1, n + buf(i) = 0. + 10 continue + + end + +c------------------------------------------------------------------------------ +c +c Verify test data buffer +c +c------------------------------------------------------------------------------ + subroutine verify_test_data( buf, count, n, name, errs ) + implicit none + include 'mpif.h' + integer n, errs + real buf(n) + character *(*) name + integer count, ierr, i +C + do 10 i = 1, count + if (buf(i) .ne. REAL(i)) then + print 100, buf(i), i, count, name + errs = errs + 1 + endif + 10 continue +C + do 20 i = count + 1, n + if (buf(i) .ne. 0.) then + print 100, buf(i), i, n, name + errs = errs + 1 + endif + 20 continue +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 codes). Without this, for example, tests fail with the Cray ftn +C compiler. +C + subroutine dummyRef( a, n, ie ) + integer n, ie + real a(n) +C This condition will never be true, but the compile won't know that + if (ie .eq. -1) then + print *, a(n) + endif + return + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/attr1aints.h b/teshsuite/smpi/mpich3-test/f77/pt2pt/attr1aints.h new file mode 100644 index 0000000000..182b04567a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/attr1aints.h @@ -0,0 +1,6 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + integer extrastate, valin, valout, val diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/dummyf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/dummyf.f new file mode 100644 index 0000000000..7524a194e0 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/dummyf.f @@ -0,0 +1,18 @@ +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 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 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 + subroutine dummyupdate( extrastate ) + include 'mpif.h' + include 'attr1aints.h' + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f new file mode 100644 index 0000000000..163f0794b0 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f @@ -0,0 +1,111 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine query_fn( extrastate, status, ierr ) + implicit none + include 'mpif.h' + integer status(MPI_STATUS_SIZE), ierr + include 'attr1aints.h' +C +C set a default status + status(MPI_SOURCE) = MPI_UNDEFINED + status(MPI_TAG) = MPI_UNDEFINED + call mpi_status_set_cancelled( status, .false., ierr) + call mpi_status_set_elements( status, MPI_BYTE, 0, ierr ) + ierr = MPI_SUCCESS + end +C + subroutine free_fn( extrastate, ierr ) + implicit none + include 'mpif.h' + integer value, ierr + include 'attr1aints.h' + integer freefncall + common /fnccalls/ freefncall +C +C For testing purposes, the following print can be used to check whether +C the free_fn is called +C print *, 'Free_fn called' +C + extrastate = extrastate - 1 +C The value returned by the free function is the error code +C returned by the wait/test function + ierr = MPI_SUCCESS + end +C + subroutine cancel_fn( extrastate, complete, ierr ) + implicit none + include 'mpif.h' + integer ierr + logical complete + include 'attr1aints.h' + + ierr = MPI_SUCCESS + end +C +C +C This is a very simple test of generalized requests. Normally, the +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 +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 Most uses of generalized requests will need to use a separate thread. +C + program main + implicit none + include 'mpif.h' + integer errs, ierr + logical flag + integer status(MPI_STATUS_SIZE) + integer request + external query_fn, free_fn, cancel_fn + include 'attr1aints.h' + integer freefncall + common /fnccalls/ freefncall + + errs = 0 + freefncall = 0 + + call MTest_Init( ierr ) + + extrastate = 0 + 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, + & 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 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 + print *, 'Free routine did not update extra_data' + print *, 'extrastate = ', extrastate + endif + endif +C + call MTest_Finalize( errs ) + call mpi_finalize( ierr ) + end +C diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/mprobef.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/mprobef.f new file mode 100644 index 0000000000..e1e554f836 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/mprobef.f @@ -0,0 +1,667 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2012 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none + include 'mpif.h' + integer idx, ierr, rank, size, count + integer sendbuf(8), recvbuf(8) + integer s1(MPI_STATUS_SIZE), s2(MPI_STATUS_SIZE) + integer msg, errs + integer rreq + logical found, flag + + ierr = -1 + errs = 0 + call mpi_init( ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + 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. + 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.' + endif + +C Test 0: simple Send and Mprobe+Mrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(0, 5, MPI_COMM_WORLD, msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T0 Mprobe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T0 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T0 Mprobe().' + endif + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T0 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T0 Mrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T0 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T0 Mrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T0 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T0 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T0 Mrecv().' + endif + endif + +C Test 1: simple Send and Mprobe+Imrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(0, 5, MPI_COMM_WORLD, msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T1 Mprobe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T1 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T1 Mprobe().' + endif + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T1 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq is unmodified at T1 Imrecv().' + endif + call MPI_Wait(rreq, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T1 Imrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T1 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T1 Imrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T1 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T1 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T1 Imrecv().' + endif + endif + +C Test 2: simple Send and Improbe+Mrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Improbe(0, 5, MPI_COMM_WORLD, found, msg, s1, ierr) + do while (.not. found) + call MPI_Improbe(0, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + enddo + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T2 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T2 Improbe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T2 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T2 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T2 Mrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T2 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T2 Mrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T2 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T2 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T2 Mrecv().' + endif + endif + +C Test 3: simple Send and Improbe+Imrecv. + if (rank .eq. 0) then + sendbuf(1) = 1735928559 + sendbuf(2) = 1277009102 + call MPI_Send(sendbuf, 2, MPI_INTEGER, + . 1, 5, MPI_COMM_WORLD, ierr) + else + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Improbe(0, 5, MPI_COMM_WORLD, found, msg, s1, ierr) + do while (.not. found) + call MPI_Improbe(0, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + enddo + if (msg .eq. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg == MPI_MESSAGE_NULL at T3 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != 0 at T3 Improbe().' + endif + if (s1(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's1(MPI_TAG) != 5 at T3 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T3 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 2) then + errs = errs + 1 + print *, 'probed buffer does not have 2 MPI_INTEGERs.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq is unmodified at T3 Imrecv().' + endif + call MPI_Wait(rreq, s2, ierr) + if (recvbuf(1) .ne. 1735928559) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T3 Imrecv().' + endif + if (recvbuf(2) .ne. 1277009102) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T3 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. 0) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != 0 at T3 Imrecv().' + endif + if (s2(MPI_TAG) .ne. 5) then + errs = errs + 1 + print *, 's2(MPI_TAG) != 5 at T3 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T3 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T3 Imrecv().' + endif + endif + +C Test 4: Mprobe+Mrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T4 Mprobe().' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T4 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T4 Mprobe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T4 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T4 Mrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T4 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T4 Mrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T4 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T4 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T4 Mrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + +C Test 5: Mprobe+Imrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + msg = MPI_MESSAGE_NULL + call MPI_Mprobe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . msg, s1, ierr) + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T5 Mprobe().' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T5 Mprobe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T5 Mprobe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T5 Mprobe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq == MPI_REQUEST_NULL at T5 Imrecv().' + endif + flag = .false. + call MPI_Test(rreq, flag, s2, ierr) + if (.not. flag) then + errs = errs + 1 + print *, 'flag is false at T5 Imrecv().' + endif +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T5 Imrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T5 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T5 Imrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T5 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T5 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T5 Imrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + +C Test 6: Improbe+Mrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + found = .false. + msg = MPI_MESSAGE_NULL + call MPI_Improbe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + if (.not. found) then + errs = errs + 1 + print *, 'found is false at T6 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T6 Improbe()' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T6 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T6 Improbe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T6 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Mrecv(recvbuf, count, MPI_INTEGER, msg, s2, ierr) +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T6 Mrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T6 Mrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T6 Mrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T6 Mrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T6 Mrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T6 Mrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + +C Test 7: Improbe+Imrecv with MPI_PROC_NULL + if (.true.) then + do idx = 1, MPI_STATUS_SIZE + s1(idx) = 0 + s2(idx) = 0 + enddo +C the error fields are initialized for modification check. + s1(MPI_ERROR) = MPI_ERR_DIMS + s2(MPI_ERROR) = MPI_ERR_OTHER + + found = .false. + msg = MPI_MESSAGE_NULL + call MPI_Improbe(MPI_PROC_NULL, 5, MPI_COMM_WORLD, + . found, msg, s1, ierr) + if (.not. found) then + errs = errs + 1 + print *, 'found is false at T7 Improbe().' + endif + if (s1(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's1(MPI_SOURCE) != MPI_PROC_NULL at T7 Improbe()' + endif + if (s1(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's1(MPI_TAG) != MPI_ANY_TAG at T7 Improbe().' + endif + if (s1(MPI_ERROR) .ne. MPI_ERR_DIMS) then + errs = errs + 1 + print *, 's1(MPI_ERROR) != MPI_ERR_DIMS at T7 Improbe().' + endif + if (msg .ne. MPI_MESSAGE_NO_PROC) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NO_PROC at T7 Improbe().' + endif + + count = -1 + call MPI_Get_count(s1, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'probed buffer does not have 0 MPI_INTEGER.' + endif + + rreq = MPI_REQUEST_NULL + recvbuf(1) = 19088743 + recvbuf(2) = 1309737967 + call MPI_Imrecv(recvbuf, count, MPI_INTEGER, msg, rreq, ierr) + if (rreq .eq. MPI_REQUEST_NULL) then + errs = errs + 1 + print *, 'rreq == MPI_REQUEST_NULL at T7 Imrecv().' + endif + flag = .false. + call MPI_Test(rreq, flag, s2, ierr) + if (.not. flag) then + errs = errs + 1 + print *, 'flag is false at T7 Imrecv().' + endif +C recvbuf() should remain unmodified + if (recvbuf(1) .ne. 19088743) then + errs = errs + 1 + print *, 'recvbuf(1) is corrupted at T7 Imrecv().' + endif + if (recvbuf(2) .ne. 1309737967) then + errs = errs + 1 + print *, 'recvbuf(2) is corrupted at T7 Imrecv().' + endif + if (s2(MPI_SOURCE) .ne. MPI_PROC_NULL) then + errs = errs + 1 + print *, 's2(MPI_SOURCE) != MPI_PROC_NULL at T7 Imrecv().' + endif + if (s2(MPI_TAG) .ne. MPI_ANY_TAG) then + errs = errs + 1 + print *, 's2(MPI_TAG) != MPI_ANY_TAG at T7 Imrecv().' + endif + if (s2(MPI_ERROR) .ne. MPI_ERR_OTHER) then + errs = errs + 1 + print *, 's2(MPI_ERROR) != MPI_ERR_OTHER at T7 Imrecv().' + endif + if (msg .ne. MPI_MESSAGE_NULL) then + errs = errs + 1 + print *, 'msg != MPI_MESSAGE_NULL at T7 Imrecv().' + endif + + count = -1 + call MPI_Get_count(s2, MPI_INTEGER, count, ierr) + if (count .ne. 0) then + errs = errs + 1 + print *, 'recv buffer does not have 0 MPI_INTEGER.' + endif + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/statusesf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/statusesf.f new file mode 100644 index 0000000000..b01d26bc6a --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/statusesf.f @@ -0,0 +1,56 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + program main + implicit none +C Test support for MPI_STATUS_IGNORE and MPI_STATUSES_IGNORE + include 'mpif.h' + integer nreqs + parameter (nreqs = 100) + integer reqs(nreqs) + integer ierr, rank, i + integer errs + + ierr = -1 + errs = 0 + call mpi_init( ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + 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 + endif + do i=1, nreqs, 2 + ierr = -1 + call mpi_isend( MPI_BOTTOM, 0, MPI_BYTE, rank, i, + $ MPI_COMM_WORLD, reqs(i), ierr ) + if (ierr .ne. MPI_SUCCESS) then + errs = errs + 1 + 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 + endif + enddo + + ierr = -1 + 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 + endif + + call mtest_finalize( errs ) + call mpi_finalize( ierr ) + end diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/testlist b/teshsuite/smpi/mpich3-test/f77/pt2pt/testlist new file mode 100644 index 0000000000..3385b9d641 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/testlist @@ -0,0 +1,4 @@ +#statusesf 1 +#greqf 1 +allpairf 2 +#mprobef 2 mpiversion=3.0 diff --git a/teshsuite/smpi/mpich3-test/f77/testlist b/teshsuite/smpi/mpich3-test/f77/testlist new file mode 100644 index 0000000000..e7d921441c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/testlist @@ -0,0 +1,12 @@ +#attr +coll +datatype +pt2pt +#info +#spawn +#io +# +init +#comm +ext +#topo diff --git a/teshsuite/smpi/mpich3-test/f77/util/mtestf.f b/teshsuite/smpi/mpich3-test/f77/util/mtestf.f new file mode 100644 index 0000000000..ba7092ef17 --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/util/mtestf.f @@ -0,0 +1,112 @@ +C -*- Mode: Fortran; -*- +C +C (C) 2003 by Argonne National Laboratory. +C See COPYRIGHT in top-level directory. +C + subroutine MTest_Init( ierr ) +C Place the include first so that we can automatically create a +C Fortran 90 version that uses the mpi module instead. If +C the module is in a different place, the compiler can complain +C about out-of-order statements + implicit none + include 'mpif.h' + integer ierr + logical flag + logical dbgflag + integer wrank + common /mtest/ dbgflag, wrank + + call MPI_Initialized( flag, ierr ) + if (.not. flag) then + call MPI_Init( ierr ) + endif + + dbgflag = .false. + call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr ) + end +C + subroutine MTest_Finalize( errs ) + implicit none + 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 ) + + if (rank .eq. 0) then + if (toterrs .gt. 0) then + print *, " Found ", toterrs, " errors" + else + print *, " No Errors" + endif + endif + end +C +C A simple get intracomm for now + logical function MTestGetIntracomm( comm, min_size, qsmaller ) + implicit none + include 'mpif.h' + integer ierr + integer comm, min_size, size, rank + logical qsmaller + integer myindex + common /grr/ myindex + + comm = MPI_COMM_NULL + if (myindex .eq. 0) then + comm = MPI_COMM_WORLD + else if (myindex .eq. 1) then + call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr ) + 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, + & ierr ) + else + if (min_size .eq. 1 .and. myindex .eq. 3) then + comm = MPI_COMM_SELF + endif + endif + myindex = mod( myindex, 4 ) + 1 + MTestGetIntracomm = comm .ne. MPI_COMM_NULL + end +C + subroutine MTestFreeComm( comm ) + implicit none + include 'mpif.h' + integer comm, ierr + if (comm .ne. MPI_COMM_WORLD .and. + & comm .ne. MPI_COMM_SELF .and. + & comm .ne. MPI_COMM_NULL) then + call mpi_comm_free( comm, ierr ) + endif + end +C + subroutine MTestPrintError( errcode ) + implicit none + include 'mpif.h' + integer errcode + integer errclass, slen, ierr + character*(MPI_MAX_ERROR_STRING) string + + call MPI_Error_class( errcode, errclass, ierr ) + call MPI_Error_string( errcode, string, slen, ierr ) + print *, "Error class ", errclass, "(", string(1:slen), ")" + end +C + subroutine MTestPrintErrorMsg( msg, errcode ) + implicit none + include 'mpif.h' + character*(*) msg + integer errcode + integer errclass, slen, ierr + character*(MPI_MAX_ERROR_STRING) string + + call MPI_Error_class( errcode, errclass, ierr ) + call MPI_Error_string( errcode, string, slen, ierr ) + print *, msg, ": Error class ", errclass, " + $ (", string(1:slen), ")" + end diff --git a/teshsuite/smpi/mpich3-test/runtests b/teshsuite/smpi/mpich3-test/runtests index 03c9b88d15..3c5a3c8a98 100755 --- a/teshsuite/smpi/mpich3-test/runtests +++ b/teshsuite/smpi/mpich3-test/runtests @@ -154,7 +154,7 @@ foreach $_ (@ARGV) { elsif (/--?maxnp=(.*)/) { $np_max = $1; } elsif (/--?tests=(.*)/) { $listfiles = $1; } elsif (/--?srcdir=(.*)/) { $srcdir = $1; - $mpiexec="$mpiexec -platform ${srcdir}/../../../../examples/msg/small_platform_with_routers.xml -hostfile ${srcdir}/../hostfile --log=root.thr:critical"; } + $mpiexec="$mpiexec -platform ${srcdir}/../../../../examples/msg/small_platform_with_routers.xml -hostfile ${srcdir}/../hostfile --log=root.thr:critical --cfg=smpi/running_power:1e9"; } elsif (/--?verbose/) { $verbose = 1; } elsif (/--?showprogress/) { $showProgress = 1; } elsif (/--?debug/) { $debug = 1; } diff --git a/teshsuite/smpi/mpich3-test/testlist b/teshsuite/smpi/mpich3-test/testlist index f4764eed5a..2110a22696 100644 --- a/teshsuite/smpi/mpich3-test/testlist +++ b/teshsuite/smpi/mpich3-test/testlist @@ -16,7 +16,7 @@ pt2pt #topo #perf #io -#f77 +f77 #cxx # #