C -*- Mode: Fortran; -*- 

C

C  (C) 2003 by Argonne National Laboratory.

C      See COPYRIGHT in top-level directory.

C

       program main

       implicit none

       include 'mpif.h'

       integer errs, ierr, code(2), newerrclass, eclass

       character*(MPI_MAX_ERROR_STRING) errstring

       integer comm, rlen

       integer buf(10)

       integer file

       external myerrhanfunc

CF90   INTERFACE 

CF90   SUBROUTINE myerrhanfunc(vv0,vv1)

CF90   INTEGER vv0,vv1

CF90   END SUBROUTINE

CF90   END INTERFACE

       integer myerrhan, qerr

       integer callcount, codesSeen(3)

       common /myerrhan/ callcount, codesSeen

       errs = 0

       callcount = 0

       call mtest_init( ierr )

C

C 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 )

C

       call mpi_file_create_errhandler( myerrhanfunc, myerrhan, ierr )

C

C Create a new communicator so that we can leave the default errors-abort

C on MPI_COMM_WORLD.  Use this comm for file_open, just to leave a little

C more separation from comm_world

C

       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

C

       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 )

C 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 )

C

C 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 )

       call mpi_finalize( ierr )

       end

C

       subroutine myerrhanfunc( file, errcode )

       implicit none

       include 'mpif.h'

       integer file, errcode

       integer rlen, ierr

       integer callcount, codesSeen(3)

       character*(MPI_MAX_ERROR_STRING) errstring

       common /myerrhan/ callcount, codesSeen

       callcount = callcount + 1

C 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