1 C -*- Mode: Fortran; -*-
3 C (C) 2003 by Argonne National Laboratory.
4 C See COPYRIGHT in top-level directory.
9 integer errs, toterrs, ierr
11 integer wgroup, info, req
13 integer comm, group, type, op, errh, result
14 integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest,
15 $ c2ferrhandler, c2fop
23 C Test passing a Fortran MPI object to C
24 call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
25 errs = errs + c2fcomm( MPI_COMM_WORLD )
26 call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr )
27 errs = errs + c2fgroup( wgroup )
28 call mpi_group_free( wgroup, ierr )
30 call mpi_info_create( info, ierr )
31 call mpi_info_set( info, "host", "myname", ierr )
32 call mpi_info_set( info, "wdir", "/rdir/foo", ierr )
33 errs = errs + c2finfo( info )
34 call mpi_info_free( info, ierr )
36 errs = errs + c2ftype( MPI_INTEGER )
38 call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG,
39 $ MPI_COMM_WORLD, req, ierr )
40 call mpi_cancel( req, ierr )
41 errs = errs + c2frequest( req )
42 call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
44 !errs = errs + c2ferrhandler( MPI_ERRORS_RETURN )
46 errs = errs + c2fop( MPI_SUM )
49 C Test using a C routine to provide the Fortran handle
50 call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
51 call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
54 call mpi_comm_size( comm, fsize, ierr )
55 call mpi_comm_rank( comm, frank, ierr )
56 if (fsize.ne.wsize .or. frank.ne.wrank) then
58 print *, "Comm(fortran) has wrong size or rank"
61 call f2cgroup( group )
62 call mpi_group_size( group, fsize, ierr )
63 call mpi_group_rank( group, frank, ierr )
64 if (fsize.ne.wsize .or. frank.ne.wrank) then
66 print *, "Group(fortran) has wrong size or rank"
68 call mpi_group_free( group, ierr )
71 if (type .ne. MPI_INTEGER) then
73 print *, "Datatype(fortran) is not MPI_INT"
77 call mpi_info_get( info, "host", 100, value, flag, ierr )
80 print *, "Info test for host returned false"
81 else if (value .ne. "myname") then
83 print *, "Info test for host returned ", value
85 call mpi_info_get( info, "wdir", 100, value, flag, ierr )
88 print *, "Info test for wdir returned false"
89 else if (value .ne. "/rdir/foo") then
91 print *, "Info test for wdir returned ", value
93 call mpi_info_free( info, ierr )
96 if (op .ne. MPI_SUM) then
98 print *, "Fortran MPI_SUM not MPI_SUM in C"
101 call f2cerrhandler( errh )
102 if (errh .ne. MPI_ERRORS_RETURN) then
104 print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C"
107 C Summarize the errors
109 call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
110 $ MPI_COMM_WORLD, ierr )
111 if (wrank .eq. 0) then
112 if (toterrs .eq. 0) then
113 print *, ' No Errors'
115 print *, ' Found ', toterrs, ' errors'
119 call mpi_finalize( ierr )