teshsuite/smpi/mpich3-test/f77/comm/commerrf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2003 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6        program main
   7        implicit none
   8        include 'mpif.h'
   9        integer errs, ierr, code(2), newerrclass, eclass
  10        character*(MPI_MAX_ERROR_STRING) errstring
  11        integer comm, rlen
  12        external myerrhanfunc
  13 CF90   INTERFACE
  14 CF90   SUBROUTINE myerrhanfunc(vv0,vv1)
  15 CF90   INTEGER vv0,vv1
  16 CF90   END SUBROUTINE
  17 CF90   END INTERFACE
  18        integer myerrhan, qerr
  19        integer callcount, codesSeen(3)
  20        common /myerrhan/ callcount, codesSeen
  21
  22        errs = 0
  23        callcount = 0
  24        call mtest_init( ierr )
  25 C
  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 )
  33 C
  34 C
  35        call mpi_comm_create_errhandler( myerrhanfunc, myerrhan, ierr )
  36 C
  37 C Create a new communicator so that we can leave the default errors-abort
  38 C on MPI_COMM_WORLD
  39        call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  40 C
  41        call mpi_comm_set_errhandler( comm, myerrhan, ierr )
  42
  43        call mpi_comm_get_errhandler( comm, qerr, ierr )
  44        if (qerr .ne. myerrhan) then
  45           errs = errs + 1
  46           print *, ' Did not get expected error handler'
  47        endif
  48        call mpi_errhandler_free( qerr, ierr )
  49 C We can free our error handler now
  50        call mpi_errhandler_free( myerrhan, ierr )
  51
  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 )
  55
  56        if (callcount .ne. 3) then
  57           errs = errs + 1
  58           print *, ' Expected 3 calls to error handler, found ',
  59      &             callcount
  60        else
  61           if (codesSeen(1) .ne. newerrclass) then
  62              errs = errs + 1
  63              print *, 'Expected class ', newerrclass, ' got ',
  64      &                codesSeen(1)
  65           endif
  66           if (codesSeen(2) .ne. code(1)) then
  67              errs = errs + 1
  68              print *, 'Expected code ', code(1), ' got ',
  69      &                codesSeen(2)
  70           endif
  71           if (codesSeen(3) .ne. code(2)) then
  72              errs = errs + 1
  73              print *, 'Expected code ', code(2), ' got ',
  74      &                codesSeen(3)
  75           endif
  76        endif
  77
  78        call mpi_comm_free( comm, ierr )
  79 C
  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
  83           errs = errs + 1
  84           print *, ' Wrong string for error class: ', errstring(1:rlen)
  85        endif
  86        call mpi_error_class( code(1), eclass, ierr )
  87        if (eclass .ne. newerrclass) then
  88           errs = errs + 1
  89           print *, ' Class for new code is not correct'
  90        endif
  91        call mpi_error_string( code(1), errstring, rlen, ierr )
  92        if (errstring(1:rlen) .ne. "First new code") then
  93           errs = errs + 1
  94           print *, ' Wrong string for error code: ', errstring(1:rlen)
  95        endif
  96        call mpi_error_class( code(2), eclass, ierr )
  97        if (eclass .ne. newerrclass) then
  98           errs = errs + 1
  99           print *, ' Class for new code is not correct'
 100        endif
 101        call mpi_error_string( code(2), errstring, rlen, ierr )
 102        if (errstring(1:rlen) .ne. "Second new code") then
 103           errs = errs + 1
 104           print *, ' Wrong string for error code: ', errstring(1:rlen)
 105        endif
 106
 107        call mtest_finalize( errs )
 108        call mpi_finalize( ierr )
 109
 110        end
 111 C
 112        subroutine myerrhanfunc( comm, errcode )
 113        implicit none
 114        include 'mpif.h'
 115        integer comm, errcode
 116        integer rlen, ierr
 117        integer callcount, codesSeen(3)
 118        character*(MPI_MAX_ERROR_STRING) errstring
 119        common /myerrhan/ callcount, codesSeen
 120
 121        callcount = callcount + 1
 122 C Remember the code we've seen
 123        if (callcount .le. 3) then
 124           codesSeen(callcount) = errcode
 125        endif
 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 )
 130        endif
 131        end