teshsuite/smpi/mpich3-test/f77/rma/winerrf.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, intsize
  12        integer buf(10)
  13        integer win
  14        external myerrhanfunc
  15 CF90   INTERFACE
  16 CF90   SUBROUTINE myerrhanfunc(vv0,vv1)
  17 CF90   INTEGER vv0,vv1
  18 CF90   END SUBROUTINE
  19 CF90   END INTERFACE
  20        integer myerrhan, qerr
  21        include 'addsize.h'
  22        integer callcount, codesSeen(3)
  23        common /myerrhan/ callcount, codesSeen
  24
  25        errs = 0
  26        callcount = 0
  27        call mtest_init( ierr )
  28 C
  29 C Setup some new codes and classes
  30        call mpi_add_error_class( newerrclass, ierr )
  31        call mpi_add_error_code( newerrclass, code(1), ierr )
  32        call mpi_add_error_code( newerrclass, code(2), ierr )
  33        call mpi_add_error_string( newerrclass, "New Class", ierr )
  34        call mpi_add_error_string( code(1), "First new code", ierr )
  35        call mpi_add_error_string( code(2), "Second new code", ierr )
  36 C
  37        call mpi_win_create_errhandler( myerrhanfunc, myerrhan, ierr )
  38 C
  39 C Create a new communicator so that we can leave the default errors-abort
  40 C on MPI_COMM_WORLD.  Use this comm for win_create, just to leave a little
  41 C more separation from comm_world
  42 C
  43        call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  44        call mpi_type_size( MPI_INTEGER, intsize, ierr )
  45        asize  = 10 * intsize
  46        call mpi_win_create( buf, asize, intsize, MPI_INFO_NULL,
  47      &                      comm, win, ierr )
  48 C
  49        call mpi_win_set_errhandler( win, myerrhan, ierr )
  50
  51        call mpi_win_get_errhandler( win, qerr, ierr )
  52        if (qerr .ne. myerrhan) then
  53           errs = errs + 1
  54           print *, ' Did not get expected error handler'
  55        endif
  56        call mpi_errhandler_free( qerr, ierr )
  57 C We can free our error handler now
  58        call mpi_errhandler_free( myerrhan, ierr )
  59
  60        call mpi_win_call_errhandler( win, newerrclass, ierr )
  61        call mpi_win_call_errhandler( win, code(1), ierr )
  62        call mpi_win_call_errhandler( win, code(2), ierr )
  63
  64        if (callcount .ne. 3) then
  65           errs = errs + 1
  66           print *, ' Expected 3 calls to error handler, found ',
  67      &             callcount
  68        else
  69           if (codesSeen(1) .ne. newerrclass) then
  70              errs = errs + 1
  71              print *, 'Expected class ', newerrclass, ' got ',
  72      &                codesSeen(1)
  73           endif
  74           if (codesSeen(2) .ne. code(1)) then
  75              errs = errs + 1
  76              print *, 'Expected code ', code(1), ' got ',
  77      &                codesSeen(2)
  78           endif
  79           if (codesSeen(3) .ne. code(2)) then
  80              errs = errs + 1
  81              print *, 'Expected code ', code(2), ' got ',
  82      &                codesSeen(3)
  83           endif
  84        endif
  85
  86        call mpi_win_free( win, ierr )
  87        call mpi_comm_free( comm, ierr )
  88 C
  89 C Check error strings while here here...
  90        call mpi_error_string( newerrclass, errstring, rlen, ierr )
  91        if (errstring(1:rlen) .ne. "New Class") then
  92           errs = errs + 1
  93           print *, ' Wrong string for error class: ', errstring(1:rlen)
  94        endif
  95        call mpi_error_class( code(1), eclass, ierr )
  96        if (eclass .ne. newerrclass) then
  97           errs = errs + 1
  98           print *, ' Class for new code is not correct'
  99        endif
 100        call mpi_error_string( code(1), errstring, rlen, ierr )
 101        if (errstring(1:rlen) .ne. "First new code") then
 102           errs = errs + 1
 103           print *, ' Wrong string for error code: ', errstring(1:rlen)
 104        endif
 105        call mpi_error_class( code(2), eclass, ierr )
 106        if (eclass .ne. newerrclass) then
 107           errs = errs + 1
 108           print *, ' Class for new code is not correct'
 109        endif
 110        call mpi_error_string( code(2), errstring, rlen, ierr )
 111        if (errstring(1:rlen) .ne. "Second new code") then
 112           errs = errs + 1
 113           print *, ' Wrong string for error code: ', errstring(1:rlen)
 114        endif
 115
 116        call mtest_finalize( errs )
 117        call mpi_finalize( ierr )
 118
 119        end
 120 C
 121        subroutine myerrhanfunc( win, errcode )
 122        implicit none
 123        include 'mpif.h'
 124        integer win, errcode
 125        integer rlen, ierr
 126        integer callcount, codesSeen(3)
 127        character*(MPI_MAX_ERROR_STRING) errstring
 128        common /myerrhan/ callcount, codesSeen
 129
 130        callcount = callcount + 1
 131 C Remember the code we've seen
 132        if (callcount .le. 3) then
 133           codesSeen(callcount) = errcode
 134        endif
 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 )
 139        endif
 140        end