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
123
124
125
126
127
128
129
130
|
! -*- Mode: Fortran; -*-
!
! (C) 2011 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 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
end
|
