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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
! This file created from f77/io/fileerrf.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
integer buf(10)
integer file
! external myerrhanfunc
INTERFACE
SUBROUTINE myerrhanfunc(vv0,vv1)
INTEGER vv0,vv1
END SUBROUTINE
END INTERFACE
integer myerrhan, qerr
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_file_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 file_open, just to leave a little
! more separation from comm_world
!
call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
call mpi_file_open( comm, "testfile.txt", MPI_MODE_RDWR + &
& MPI_MODE_CREATE, MPI_INFO_NULL, file, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
call MTestPrintError( ierr )
endif
!
call mpi_file_set_errhandler( file, myerrhan, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
call MTestPrintError( ierr )
endif
call mpi_file_get_errhandler( file, qerr, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
call MTestPrintError( ierr )
endif
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_file_call_errhandler( file, newerrclass, ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
call MTestPrintError( ierr )
endif
call mpi_file_call_errhandler( file, code(1), ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
call MTestPrintError( ierr )
endif
call mpi_file_call_errhandler( file, code(2), ierr )
if (ierr .ne. MPI_SUCCESS) then
errs = errs + 1
call MTestPrintError( ierr )
endif
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_file_close( file, ierr )
call mpi_comm_free( comm, ierr )
call mpi_file_delete( "testfile.txt", MPI_INFO_NULL, 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( file, errcode )
use mpi
integer file, 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
|
