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
131
132
133
134
135
136
137
138
139
|
! This file created from f77/rma/winerrf.f with f77tof90
!
! Copyright (C) by Argonne National Laboratory
! See COPYRIGHT in top-level directory
!
program main
use mpi
integer errs, ierr, code(2), newerrclass, eclass
character*(MPI_MAX_ERROR_STRING) errstring
integer comm, rlen, intsize
integer buf(10)
integer win
! external myerrhanfunc
INTERFACE
SUBROUTINE myerrhanfunc(vv0,vv1)
INTEGER vv0,vv1
END SUBROUTINE
END INTERFACE
integer myerrhan, qerr
integer (kind=MPI_ADDRESS_KIND) asize
integer callcount, codesSeen(3)
common /myerrhan/ callcount, codesSeen
errs = 0
callcount = 0
call mtest_init( ierr )
!
! Setup some new codes and classes
call mpi_add_error_class( newerrclass, ierr )
call mpi_add_error_code( newerrclass, code(1), ierr )
call mpi_add_error_code( newerrclass, code(2), ierr )
call mpi_add_error_string( newerrclass, "New Class", ierr )
call mpi_add_error_string( code(1), "First new code", ierr )
call mpi_add_error_string( code(2), "Second new code", ierr )
!
call mpi_win_create_errhandler( myerrhanfunc, myerrhan, ierr )
!
! Create a new communicator so that we can leave the default errors-abort
! on MPI_COMM_WORLD. Use this comm for win_create, just to leave a little
! more separation from comm_world
!
call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
call mpi_type_size( MPI_INTEGER, intsize, ierr )
asize = 10 * intsize
call mpi_win_create( buf, asize, intsize, MPI_INFO_NULL, &
& comm, win, ierr )
!
call mpi_win_set_errhandler( win, myerrhan, ierr )
call mpi_win_get_errhandler( win, qerr, ierr )
if (qerr .ne. myerrhan) then
errs = errs + 1
print *, ' Did not get expected error handler'
endif
call mpi_errhandler_free( qerr, ierr )
! We can free our error handler now
call mpi_errhandler_free( myerrhan, ierr )
call mpi_win_call_errhandler( win, newerrclass, ierr )
call mpi_win_call_errhandler( win, code(1), ierr )
call mpi_win_call_errhandler( win, code(2), ierr )
if (callcount .ne. 3) then
errs = errs + 1
print *, ' Expected 3 calls to error handler, found ', &
& callcount
else
if (codesSeen(1) .ne. newerrclass) then
errs = errs + 1
print *, 'Expected class ', newerrclass, ' got ', &
& codesSeen(1)
endif
if (codesSeen(2) .ne. code(1)) then
errs = errs + 1
print *, 'Expected code ', code(1), ' got ', &
& codesSeen(2)
endif
if (codesSeen(3) .ne. code(2)) then
errs = errs + 1
print *, 'Expected code ', code(2), ' got ', &
& codesSeen(3)
endif
endif
call mpi_win_free( win, ierr )
call mpi_comm_free( comm, ierr )
!
! Check error strings while here here...
call mpi_error_string( newerrclass, errstring, rlen, ierr )
if (errstring(1:rlen) .ne. "New Class") then
errs = errs + 1
print *, ' Wrong string for error class: ', errstring(1:rlen)
endif
call mpi_error_class( code(1), eclass, ierr )
if (eclass .ne. newerrclass) then
errs = errs + 1
print *, ' Class for new code is not correct'
endif
call mpi_error_string( code(1), errstring, rlen, ierr )
if (errstring(1:rlen) .ne. "First new code") then
errs = errs + 1
print *, ' Wrong string for error code: ', errstring(1:rlen)
endif
call mpi_error_class( code(2), eclass, ierr )
if (eclass .ne. newerrclass) then
errs = errs + 1
print *, ' Class for new code is not correct'
endif
call mpi_error_string( code(2), errstring, rlen, ierr )
if (errstring(1:rlen) .ne. "Second new code") then
errs = errs + 1
print *, ' Wrong string for error code: ', errstring(1:rlen)
endif
call mtest_finalize( errs )
end
!
subroutine myerrhanfunc( win, errcode )
use mpi
integer win, errcode
integer rlen, ierr
integer callcount, codesSeen(3)
character*(MPI_MAX_ERROR_STRING) errstring
common /myerrhan/ callcount, codesSeen
callcount = callcount + 1
! Remember the code we've seen
if (callcount .le. 3) then
codesSeen(callcount) = errcode
endif
call mpi_error_string( errcode, errstring, rlen, ierr )
if (ierr .ne. MPI_SUCCESS) then
print *, ' Panic! could not get error string'
call mpi_abort( MPI_COMM_WORLD, 1, ierr )
endif
end
|
