1 ! This file created from test/mpi/f77/rma/winerrf.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2003 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
9 integer errs, ierr, code(2), newerrclass, eclass
10 character*(MPI_MAX_ERROR_STRING) errstring
11 integer comm, rlen, intsize
14 ! external myerrhanfunc
16 SUBROUTINE myerrhanfunc(vv0,vv1)
20 integer myerrhan, qerr
21 integer (kind=MPI_ADDRESS_KIND) asize
23 integer callcount, codesSeen(3)
24 common /myerrhan/ callcount, codesSeen
28 call mtest_init( ierr )
30 ! Setup some new codes and classes
31 call mpi_add_error_class( newerrclass, ierr )
32 call mpi_add_error_code( newerrclass, code(1), ierr )
33 call mpi_add_error_code( newerrclass, code(2), ierr )
34 call mpi_add_error_string( newerrclass, "New Class", ierr )
35 call mpi_add_error_string( code(1), "First new code", ierr )
36 call mpi_add_error_string( code(2), "Second new code", ierr )
38 call mpi_win_create_errhandler( myerrhanfunc, myerrhan, ierr )
40 ! Create a new communicator so that we can leave the default errors-abort
41 ! on MPI_COMM_WORLD. Use this comm for win_create, just to leave a little
42 ! more separation from comm_world
44 call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
45 call mpi_type_size( MPI_INTEGER, intsize, ierr )
47 call mpi_win_create( buf, asize, intsize, MPI_INFO_NULL, &
50 call mpi_win_set_errhandler( win, myerrhan, ierr )
52 call mpi_win_get_errhandler( win, qerr, ierr )
53 if (qerr .ne. myerrhan) then
55 print *, ' Did not get expected error handler'
57 call mpi_errhandler_free( qerr, ierr )
58 ! We can free our error handler now
59 call mpi_errhandler_free( myerrhan, ierr )
61 call mpi_win_call_errhandler( win, newerrclass, ierr )
62 call mpi_win_call_errhandler( win, code(1), ierr )
63 call mpi_win_call_errhandler( win, code(2), ierr )
65 if (callcount .ne. 3) then
67 print *, ' Expected 3 calls to error handler, found ', &
70 if (codesSeen(1) .ne. newerrclass) then
72 print *, 'Expected class ', newerrclass, ' got ', &
75 if (codesSeen(2) .ne. code(1)) then
77 print *, 'Expected code ', code(1), ' got ', &
80 if (codesSeen(3) .ne. code(2)) then
82 print *, 'Expected code ', code(2), ' got ', &
87 call mpi_win_free( win, ierr )
88 call mpi_comm_free( comm, ierr )
90 ! Check error strings while here here...
91 call mpi_error_string( newerrclass, errstring, rlen, ierr )
92 if (errstring(1:rlen) .ne. "New Class") then
94 print *, ' Wrong string for error class: ', errstring(1:rlen)
96 call mpi_error_class( code(1), eclass, ierr )
97 if (eclass .ne. newerrclass) then
99 print *, ' Class for new code is not correct'
101 call mpi_error_string( code(1), errstring, rlen, ierr )
102 if (errstring(1:rlen) .ne. "First new code") then
104 print *, ' Wrong string for error code: ', errstring(1:rlen)
106 call mpi_error_class( code(2), eclass, ierr )
107 if (eclass .ne. newerrclass) then
109 print *, ' Class for new code is not correct'
111 call mpi_error_string( code(2), errstring, rlen, ierr )
112 if (errstring(1:rlen) .ne. "Second new code") then
114 print *, ' Wrong string for error code: ', errstring(1:rlen)
117 call mtest_finalize( errs )
118 call mpi_finalize( ierr )
122 subroutine myerrhanfunc( win, errcode )
126 integer callcount, codesSeen(3)
127 character*(MPI_MAX_ERROR_STRING) errstring
128 common /myerrhan/ callcount, codesSeen
130 callcount = callcount + 1
131 ! Remember the code we've seen
132 if (callcount .le. 3) then
133 codesSeen(callcount) = errcode
135 call mpi_error_string( errcode, errstring, rlen, ierr )
136 if (ierr .ne. MPI_SUCCESS) then
137 print *, ' Panic! could not get error string'
138 call mpi_abort( MPI_COMM_WORLD, 1, ierr )