Logo AND Algorithmique Numérique Distribuée

Public GIT Repository
Merge branch 'master' of git+ssh://scm.gforge.inria.fr//gitroot/simgrid/simgrid
authorPierre Veyre <pierre.veyre@cc.in2p3.fr>
Wed, 17 Jul 2013 07:57:16 +0000 (09:57 +0200)
committerPierre Veyre <pierre.veyre@cc.in2p3.fr>
Wed, 17 Jul 2013 07:57:16 +0000 (09:57 +0200)
85 files changed:
ChangeLog
buildtools/Cmake/AddTests.cmake
buildtools/Cmake/DefinePackages.cmake
buildtools/Cmake/MakeExe.cmake
include/smpi/mpif.h
include/smpi/smpi.h
src/smpi/private.h
src/smpi/smpi_base.c
src/smpi/smpi_f77.c
src/smpi/smpi_global.c
src/smpi/smpi_mpi.c
src/smpi/smpi_pmpi.c
src/smpi/smpiff.in
teshsuite/smpi/mpich3-test/CMakeLists.txt
teshsuite/smpi/mpich3-test/f77/attr/CMakeLists.txt [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/attraints.h [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/attrmpi1f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/baseattrf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/commattr2f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/commattr3f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/commattrf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/typeattr2f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/typeattr3f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/attr/typeattrf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/CMakeLists.txt [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/allredint8f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/allredopttf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/alltoallvf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/alltoallwf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/exscanf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/inplacef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/nonblocking_inpf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/nonblockingf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/red_scat_blockf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/redscatf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/split_typef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/coll/vw_inplacef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/comm/CMakeLists.txt [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/comm/commerrf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/comm/commnamef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/comm/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/CMakeLists.txt [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/gaddressf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/hindex1f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/hindexed_blockf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/packef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/typeaints.h [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/typename3f.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/typenamef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/typesnamef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/datatype/typesubf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/CMakeLists.txt [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/add1size.h [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/allocmemf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/c2f2c.c [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/c2fmult.c [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/ctypesinf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/ext/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/init/CMakeLists.txt [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/init/baseenvf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/init/checksizes.c [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/init/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/CMakeLists.txt [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/attr1aints.h [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/dummyf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/greqf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/mprobef.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/statusesf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/pt2pt/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/testlist [new file with mode: 0644]
teshsuite/smpi/mpich3-test/f77/util/mtestf.f [new file with mode: 0644]
teshsuite/smpi/mpich3-test/runtests
teshsuite/smpi/mpich3-test/testlist

index 98b7afe..0add88d 100644 (file)
--- 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, ...)
index 5bd343e..e38d36e 100644 (file)
@@ -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()
 
index f53e862..a6b4b42 100644 (file)
@@ -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
index f56dc00..fac59a6 100644 (file)
@@ -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)
 
index aabde41..690380e 100644 (file)
@@ -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)
       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)
       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)
       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)
       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
       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
index 9cff118..1eebe9f 100644 (file)
@@ -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));
index 651841c..0a63808 100644 (file)
@@ -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);
index 88e9307..f114a57 100644 (file)
@@ -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;
index 56fefc8..dbd1895 100644 (file)
 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);
+  }
+}
index 7cf9d54..27a53de 100644 (file)
@@ -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);
index f98336e..c3dd85e 100644 (file)
@@ -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);
 }
index 7859738..b753958 100644 (file)
@@ -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;
 }
 
index b86184b..7fd89c8 100644 (file)
@@ -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}"
index 802e555..82b588b 100644 (file)
@@ -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 (file)
index 0000000..50752bb
--- /dev/null
@@ -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 (file)
index 0000000..182b045
--- /dev/null
@@ -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 (file)
index 0000000..44e5b5e
--- /dev/null
@@ -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 (file)
index 0000000..59d69bc
--- /dev/null
@@ -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 (file)
index 0000000..36f520d
--- /dev/null
@@ -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 (file)
index 0000000..92d47f9
--- /dev/null
@@ -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 (file)
index 0000000..cfa5ffb
--- /dev/null
@@ -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 (file)
index 0000000..491ec88
--- /dev/null
@@ -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 (file)
index 0000000..27d9d59
--- /dev/null
@@ -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 (file)
index 0000000..5fbbdbb
--- /dev/null
@@ -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 (file)
index 0000000..5d30e70
--- /dev/null
@@ -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 (file)
index 0000000..78aaa35
--- /dev/null
@@ -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 (file)
index 0000000..805f851
--- /dev/null
@@ -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 (file)
index 0000000..10ece87
--- /dev/null
@@ -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 (file)
index 0000000..1b71c8d
--- /dev/null
@@ -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 (file)
index 0000000..0a2831a
--- /dev/null
@@ -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 (file)
index 0000000..7ab0d60
--- /dev/null
@@ -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 (file)
index 0000000..5e6f64e
--- /dev/null
@@ -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 (file)
index 0000000..230cccb
--- /dev/null
@@ -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 (file)
index 0000000..d2c3bbd
--- /dev/null
@@ -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 (file)
index 0000000..b912acd
--- /dev/null
@@ -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 (file)
index 0000000..831f2fc
--- /dev/null
@@ -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 (file)
index 0000000..b19b1e7
--- /dev/null
@@ -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 (file)
index 0000000..6037308
--- /dev/null
@@ -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 (file)
index 0000000..3f3aa3e
--- /dev/null
@@ -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 (file)
index 0000000..dd71163
--- /dev/null
@@ -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 (file)
index 0000000..566d294
--- /dev/null
@@ -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 (file)
index 0000000..4ad1d4a
--- /dev/null
@@ -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 (file)
index 0000000..acd9a3d
--- /dev/null
@@ -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 (file)
index 0000000..e58337f
--- /dev/null
@@ -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 (file)
index 0000000..4ff5caf
--- /dev/null
@@ -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 (file)
index 0000000..6523065
--- /dev/null
@@ -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 (file)
index 0000000..91212fb
--- /dev/null
@@ -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 (file)
index 0000000..f4c5e3f
--- /dev/null
@@ -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 (file)
index 0000000..4dba0f2
--- /dev/null
@@ -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 (file)
index 0000000..1a689ed
--- /dev/null
@@ -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 (file)
index 0000000..8dc00a8
--- /dev/null
@@ -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 (file)
index 0000000..f91e91f
--- /dev/null
@@ -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 (file)
index 0000000..5da0524
--- /dev/null
@@ -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 (file)
index 0000000..ded63b0
--- /dev/null
@@ -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 (file)
index 0000000..2bd194c
--- /dev/null
@@ -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 (file)
index 0000000..32e9af4
--- /dev/null
@@ -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 (file)
index 0000000..17414d0
--- /dev/null
@@ -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 (file)
index 0000000..611fbcf
--- /dev/null
@@ -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 (file)
index 0000000..b958c49
--- /dev/null
@@ -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 (file)
index 0000000..f175149
--- /dev/null
@@ -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 (file)
index 0000000..ade7a6a
--- /dev/null
@@ -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 (file)
index 0000000..940a4c3
--- /dev/null
@@ -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 (file)
index 0000000..cc8792d
--- /dev/null
@@ -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 (file)
index 0000000..4e048b2
--- /dev/null
@@ -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 <stdio.h>
+#include "mpi.h"
+#include "../../include/mpitestconf.h"
+#include <string.h>
+
+/* 
+   Name mapping.  All routines are created with names that are lower case
+   with a single trailing underscore.  This matches many compilers.
+   We use #define to change the name for Fortran compilers that do
+   not use the lowercase/underscore pattern 
+*/
+
+#ifdef F77_NAME_UPPER
+#define 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 (file)
index 0000000..1755925
--- /dev/null
@@ -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 (file)
index 0000000..07c21d6
--- /dev/null
@@ -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 <stdio.h>
+#include "mpitest.h"
+
+int main( int argc, char *argv[] )
+{
+    MPI_Fint handleA, handleB;
+    int      rc;
+    int      errs = 0;
+    int      buf[1];
+    MPI_Request cRequest;
+    MPI_Status st;
+    int        tFlag;
+
+    MTest_Init( &argc, &argv );
+
+    /* Request */
+    rc = MPI_Irecv( buf, 1, MPI_INT, 0, 0, MPI_COMM_WORLD, &cRequest );
+    if (rc) {
+       errs++;
+       printf( "Unable to create request\n" );
+    }
+    else {
+       handleA = MPI_Request_c2f( cRequest );
+       handleB = MPI_Request_c2f( cRequest );
+       if (handleA != handleB) {
+           errs++;
+           printf( "MPI_Request_c2f does not give the same handle twice on the same MPI_Request\n" );
+       }
+    }
+    MPI_Cancel( &cRequest );
+    MPI_Test( &cRequest, &tFlag, &st );
+    MPI_Test_cancelled( &st, &tFlag );
+    if (!tFlag) {
+       errs++;
+       printf( "Unable to cancel MPI_Irecv request\n" );
+    }
+    /* Using MPI_Request_free should be ok, but some MPI implementations
+       object to it imediately after the cancel and that isn't essential to
+       this test */
+
+    MTest_Finalize( errs );
+    MPI_Finalize();
+    
+    return 0;
+}
diff --git a/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c b/teshsuite/smpi/mpich3-test/f77/ext/ctypesfromc.c
new file mode 100644 (file)
index 0000000..51015da
--- /dev/null
@@ -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 <stdio.h>
+#include "mpi.h"
+#include "../../include/mpitestconf.h"
+#include <string.h>
+
+/* 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 (file)
index 0000000..4693bc8
--- /dev/null
@@ -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 (file)
index 0000000..745768e
--- /dev/null
@@ -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 (file)
index 0000000..363d9ff
--- /dev/null
@@ -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 (file)
index 0000000..b8b1f6c
--- /dev/null
@@ -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 (file)
index 0000000..e91dc8d
--- /dev/null
@@ -0,0 +1,23 @@
+#include "mpi.h"
+#include <stdio.h>
+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 (file)
index 0000000..0b0b623
--- /dev/null
@@ -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 (file)
index 0000000..2d99d06
--- /dev/null
@@ -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 (file)
index 0000000..750c568
--- /dev/null
@@ -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 (file)
index 0000000..182b045
--- /dev/null
@@ -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 (file)
index 0000000..7524a19
--- /dev/null
@@ -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 (file)
index 0000000..163f079
--- /dev/null
@@ -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 (file)
index 0000000..e1e554f
--- /dev/null
@@ -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
+            &n