teshsuite/smpi/mpich-test/env/errhandf.f

   1 C
   2 C Test that error handlers can be applied and used through Fortran
   3 C
   4       program main
   5
   6       include 'mpif.h'
   7       integer ierr, errorclass
   8       integer buf, errors, request
   9 C
  10       call mpi_init(ierr)
  11 C
  12 C  Try to set the errors-return handler
  13 C
  14       call mpi_errhandler_set(mpi_comm_world, mpi_errors_return, ierr)
  15       errors = 0
  16 C
  17 C Activate the handler with a simple case
  18 C
  19       call mpi_send( buf, 1, MPI_INTEGER, -99, 0, MPI_COMM_WORLD, ierr )
  20       if (IERR .eq. MPI_SUCCESS) then
  21          errors = errors + 1
  22          print *, 'MPI_Send of negative rank did not return error'
  23       endif
  24 C
  25 C Check for a reasonable error message
  26       call mpi_error_class(ierr, errorclass, err)
  27       if (errorclass .ne. MPI_ERR_RANK) then
  28          errors = errors + 1
  29          print *, 'Error class was not MPI_ERR_RANK, was ', errorclass
  30       endif
  31 C
  32 C Activate the handler with a simple case
  33 C
  34       call mpi_irecv( buf, 1, MPI_INTEGER, -100, 2, MPI_COMM_WORLD,
  35      *                request, ierr )
  36       if (IERR .eq. MPI_SUCCESS) then
  37          errors = errors + 1
  38          print *, 'MPI_Irecv of negative rank did not return error'
  39       endif
  40 C
  41 C Check for a reasonable error message
  42       call mpi_error_class(ierr, errorclass, err)
  43       if (errorclass .ne. MPI_ERR_RANK) then
  44          errors = errors + 1
  45          print *, 'Error class was not MPI_ERR_RANK, was ', errorclass
  46       endif
  47
  48       if (errors .eq. 0) then
  49          print *, ' No Errors'
  50       else
  51          print *, ' Found ', errors, ' errors'
  52       endif
  53 C
  54       call mpi_finalize(ierr)
  55 C
  56       end