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
|
C
C Copyright (C) by Argonne National Laboratory
C See COPYRIGHT in top-level directory
C
program main
C
include 'mpif.h'
integer ierr
integer errs
logical found
integer comm2
integer key
include 'attraints.h'
errs = 0
C
C initialize the mpi environment
C
call mtest_init(ierr)
call mpi_comm_create_keyval(MPI_COMM_DUP_FN,
$ MPI_NULL_DELETE_FN,
$ key,
$ extrastate,
$ ierr)
C
C set a value for the attribute
C
valin = huge(valin)
C
C set attr in comm_world
C
call mpi_comm_set_attr(MPI_COMM_WORLD,
$ key,
$ valin,
$ ierr)
call mpi_comm_get_attr(MPI_COMM_WORLD,
$ key,
$ valout,
$ found,
$ ierr)
if (found .neqv. .true.) then
print *, "mpi_comm_set_attr reported key, but not found on ",
$ "mpi_comm_world"
errs = errs + 1
else if (valout .ne. valin) then
print *, "key found, but valin does not match valout"
print *, valout, " != ", valin
errs = errs + 1
end if
C
C dup the communicator, attribute should follow
C
call mpi_comm_dup(MPI_COMM_WORLD,
$ comm2,
$ ierr)
C
C get the value for the attribute
C
call mpi_comm_get_attr(comm2,
$ key,
$ valout,
$ found,
$ ierr)
if (found .neqv. .true.) then
print *, "mpi_comm_set_attr reported key, but not found on ",
$ "duped comm"
errs = errs + 1
else if (valout .ne. valin) then
print *, "key found, but value does not match that on ",
$ "mpi_comm_world"
print *, valout, " != ", valin
errs = errs + 1
end if
C
C free the duped communicator
C
call mpi_comm_free(comm2, ierr)
C
C free keyval
C
call mpi_comm_delete_attr(MPI_COMM_WORLD,
$ key, ierr)
call mpi_comm_free_keyval(key,
$ ierr)
call mtest_finalize( errs )
end
|
