1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
!
! Copyright (C) by Argonne National Laboratory
! See COPYRIGHT in top-level directory
!
program main
use mpi_f08
integer errs, toterrs, ierr
integer wrank, wsize
type(MPI_Group) wgroup
type(MPI_Info) info
type(MPI_Request) req
integer fsize, frank
!integer comm, group, type, op, errh, result
type(MPI_Comm) comm
type(MPI_Group) group
type(MPI_Datatype) type
type(MPI_Op) op
type(MPI_Errhandler) errh
integer result
integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest, &
& c2ferrhandler, c2fop
character value*100
logical flag
errs = 0
call mpi_init( ierr )
!
! Test passing a Fortran MPI object to C
call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
errs = errs + c2fcomm( MPI_COMM_WORLD%MPI_VAL)
call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr )
errs = errs + c2fgroup( wgroup%MPI_VAL )
call mpi_group_free( wgroup, ierr )
call mpi_info_create( info, ierr )
call mpi_info_set( info, "host", "myname", ierr )
call mpi_info_set( info, "wdir", "/rdir/foo", ierr )
errs = errs + c2finfo( info%MPI_VAL )
call mpi_info_free( info, ierr )
errs = errs + c2ftype( MPI_INTEGER%MPI_VAL )
call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG, &
& MPI_COMM_WORLD, req, ierr )
call mpi_cancel( req, ierr )
errs = errs + c2frequest( req%MPI_VAL )
call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
errs = errs + c2ferrhandler( MPI_ERRORS_RETURN%MPI_VAL )
errs = errs + c2fop( MPI_SUM%MPI_VAL )
!
! Test using a C routine to provide the Fortran handle
call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
call f2ccomm( comm )
call mpi_comm_size( comm, fsize, ierr )
call mpi_comm_rank( comm, frank, ierr )
if (fsize.ne.wsize .or. frank.ne.wrank) then
errs = errs + 1
print *, "Comm(fortran) has wrong size or rank"
endif
call f2cgroup( group )
call mpi_group_size( group, fsize, ierr )
call mpi_group_rank( group, frank, ierr )
if (fsize.ne.wsize .or. frank.ne.wrank) then
errs = errs + 1
print *, "Group(fortran) has wrong size or rank"
endif
call mpi_group_free( group, ierr )
call f2ctype( type )
if (type .ne. MPI_INTEGER) then
errs = errs + 1
print *, "Datatype(fortran) is not MPI_INT"
endif
call f2cinfo( info )
call mpi_info_get( info, "host", 100, value, flag, ierr )
if (.not. flag) then
errs = errs + 1
print *, "Info test for host returned false"
else if (value .ne. "myname") then
errs = errs + 1
print *, "Info test for host returned ", value
endif
call mpi_info_get( info, "wdir", 100, value, flag, ierr )
if (.not. flag) then
errs = errs + 1
print *, "Info test for wdir returned false"
else if (value .ne. "/rdir/foo") then
errs = errs + 1
print *, "Info test for wdir returned ", value
endif
call mpi_info_free( info, ierr )
call f2cop( op )
if (op .ne. MPI_SUM) then
errs = errs + 1
print *, "Fortran MPI_SUM not MPI_SUM in C"
endif
call f2cerrhandler( errh )
if (errh .ne. MPI_ERRORS_RETURN) then
errs = errs + 1
print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C"
endif
!
! Summarize the errors
!
call mtest_finalize( errs )
end
|
