1 C -*- Mode: Fortran; -*-
3 C (C) 2003 by Argonne National Laboratory.
4 C See COPYRIGHT in top-level directory.
9 integer errs, ierr, code(2), newerrclass, eclass
10 character*(MPI_MAX_ERROR_STRING) errstring
14 CF90 SUBROUTINE myerrhanfunc(vv0,vv1)
18 integer myerrhan, qerr
19 integer callcount, codesSeen(3)
20 common /myerrhan/ callcount, codesSeen
24 call mtest_init( ierr )
26 C Setup some new codes and classes
27 call mpi_add_error_class( newerrclass, ierr )
28 call mpi_add_error_code( newerrclass, code(1), ierr )
29 call mpi_add_error_code( newerrclass, code(2), ierr )
30 call mpi_add_error_string( newerrclass, "New Class", ierr )
31 call mpi_add_error_string( code(1), "First new code", ierr )
32 call mpi_add_error_string( code(2), "Second new code", ierr )
35 call mpi_comm_create_errhandler( myerrhanfunc, myerrhan, ierr )
37 C Create a new communicator so that we can leave the default errors-abort
39 call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
41 call mpi_comm_set_errhandler( comm, myerrhan, ierr )
43 call mpi_comm_get_errhandler( comm, qerr, ierr )
44 if (qerr .ne. myerrhan) then
46 print *, ' Did not get expected error handler'
48 call mpi_errhandler_free( qerr, ierr )
49 C We can free our error handler now
50 call mpi_errhandler_free( myerrhan, ierr )
52 call mpi_comm_call_errhandler( comm, newerrclass, ierr )
53 call mpi_comm_call_errhandler( comm, code(1), ierr )
54 call mpi_comm_call_errhandler( comm, code(2), ierr )
56 if (callcount .ne. 3) then
58 print *, ' Expected 3 calls to error handler, found ',
61 if (codesSeen(1) .ne. newerrclass) then
63 print *, 'Expected class ', newerrclass, ' got ',
66 if (codesSeen(2) .ne. code(1)) then
68 print *, 'Expected code ', code(1), ' got ',
71 if (codesSeen(3) .ne. code(2)) then
73 print *, 'Expected code ', code(2), ' got ',
78 call mpi_comm_free( comm, ierr )
80 C Check error strings while here...
81 call mpi_error_string( newerrclass, errstring, rlen, ierr )
82 if (errstring(1:rlen) .ne. "New Class") then
84 print *, ' Wrong string for error class: ', errstring(1:rlen)
86 call mpi_error_class( code(1), eclass, ierr )
87 if (eclass .ne. newerrclass) then
89 print *, ' Class for new code is not correct'
91 call mpi_error_string( code(1), errstring, rlen, ierr )
92 if (errstring(1:rlen) .ne. "First new code") then
94 print *, ' Wrong string for error code: ', errstring(1:rlen)
96 call mpi_error_class( code(2), eclass, ierr )
97 if (eclass .ne. newerrclass) then
99 print *, ' Class for new code is not correct'
101 call mpi_error_string( code(2), errstring, rlen, ierr )
102 if (errstring(1:rlen) .ne. "Second new code") then
104 print *, ' Wrong string for error code: ', errstring(1:rlen)
107 call mtest_finalize( errs )
108 call mpi_finalize( ierr )
112 subroutine myerrhanfunc( comm, errcode )
115 integer comm, errcode
117 integer callcount, codesSeen(3)
118 character*(MPI_MAX_ERROR_STRING) errstring
119 common /myerrhan/ callcount, codesSeen
121 callcount = callcount + 1
122 C Remember the code we've seen
123 if (callcount .le. 3) then
124 codesSeen(callcount) = errcode
126 call mpi_error_string( errcode, errstring, rlen, ierr )
127 if (ierr .ne. MPI_SUCCESS) then
128 print *, ' Panic! could not get error string'
129 call mpi_abort( MPI_COMM_WORLD, 1, ierr )