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
|
C
C Copyright (C) by Argonne National Laboratory
C See COPYRIGHT in top-level directory
C
program main
implicit none
include 'mpif.h'
include 'addsize.h'
include 'iooffset.h'
integer ierr, rank, i
integer errs
external comm_errh_fn, win_errh_fn, file_errh_fn
integer comm_errh, win_errh, file_errh
integer winbuf(2), winh, wdup, wdsize, sizeofint, id
integer fh, status(MPI_STATUS_SIZE)
common /ec/ iseen
integer iseen(3)
save /ec/
iseen(1) = 0
iseen(2) = 0
iseen(3) = 0
ierr = -1
errs = 0
call mtest_init( ierr )
call mpi_type_size( MPI_INTEGER, sizeofint, ierr )
call mpi_comm_create_errhandler( comm_errh_fn, comm_errh, ierr )
if (ierr .ne. MPI_SUCCESS) then
call mtestprinterrormsg( "Comm_create_errhandler:", ierr )
errs = errs + 1
endif
call mpi_win_create_errhandler( win_errh_fn, win_errh, ierr )
if (ierr .ne. MPI_SUCCESS) then
call mtestprinterrormsg( "Win_create_errhandler:", ierr )
errs = errs + 1
endif
call mpi_file_create_errhandler( file_errh_fn, file_errh, ierr )
if (ierr .ne. MPI_SUCCESS) then
call mtestprinterrormsg( "File_create_errhandler:", ierr )
errs = errs + 1
endif
C
call mpi_comm_dup( MPI_COMM_WORLD, wdup, ierr )
call mpi_comm_set_errhandler( wdup, comm_errh, ierr )
call mpi_comm_size( wdup, wdsize, ierr )
call mpi_send( id, 1, MPI_INTEGER, wdsize, -37, wdup, ierr )
C NOTE: ierr may be MPI_SUCCESS but handler should be invoked
if (iseen(1) .ne. 1) then
errs = errs + 1
print *, ' Failed to increment comm error counter'
endif
asize = 2*sizeofint
call mpi_win_create( winbuf, asize, sizeofint, MPI_INFO_NULL
$ , wdup, winh, ierr )
if (ierr .ne. MPI_SUCCESS) then
call mtestprinterrormsg( "Win_create:", ierr )
errs = errs + 1
endif
call mpi_win_set_errhandler( winh, win_errh, ierr )
asize = 0
call mpi_put( winbuf, 1, MPI_INT, wdsize, asize, 1, MPI_INT, winh,
$ ierr )
C NOTE: ierr may be MPI_SUCCESS but handler should be invoked
if (iseen(3) .ne. 1) then
errs = errs + 1
print *, ' Failed to increment win error counter'
endif
call mpi_file_open( MPI_COMM_SELF, 'ftest', MPI_MODE_CREATE +
$ MPI_MODE_RDWR + MPI_MODE_DELETE_ON_CLOSE, MPI_INFO_NULL, fh,
$ ierr )
if (ierr .ne. MPI_SUCCESS) then
call mtestprinterrormsg( "File_open:", ierr )
errs = errs + 1
endif
call mpi_file_set_errhandler( fh, file_errh, ierr )
offset = -100
call mpi_file_read_at( fh, offset, winbuf, 1, MPI_INTEGER, status,
$ ierr )
C NOTE: ierr may be MPI_SUCCESS but handler should be invoked
if (iseen(2) .ne. 1) then
errs = errs + 1
print *, ' Failed to increment file error counter'
endif
call mpi_comm_free( wdup, ierr )
call mpi_win_free( winh, ierr )
call mpi_file_close( fh, ierr )
call mpi_errhandler_free( win_errh, ierr )
call mpi_errhandler_free( comm_errh, ierr )
call mpi_errhandler_free( file_errh, ierr )
call mtest_finalize( errs )
end
C
subroutine comm_errh_fn( comm, ec )
integer comm, ec
common /ec/ iseen
integer iseen(3)
save /ec/
C
iseen(1) = iseen(1) + 1
C
end
C
subroutine win_errh_fn( win, ec )
integer win, ec
common /ec/ iseen
integer iseen(3)
save /ec/
C
iseen(3) = iseen(3) + 1
C
end
subroutine file_errh_fn( fh, ec )
integer fh, ec
common /ec/ iseen
integer iseen(3)
save /ec/
C
iseen(2) = iseen(2) + 1
C
end
|
