teshsuite/smpi/mpich3-test/f90/rma/winerrf90.f90

   1 ! This file created from test/mpi/f77/rma/winerrf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2003 by Argonne National Laboratory.
   5 !      See COPYRIGHT in top-level directory.
   6 !
   7        program main
   8        use mpi
   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        INTERFACE
  16        SUBROUTINE myerrhanfunc(vv0,vv1)
  17        INTEGER vv0,vv1
  18        END SUBROUTINE
  19        END INTERFACE
  20        integer myerrhan, qerr
  21        integer (kind=MPI_ADDRESS_KIND) asize
  22
  23        integer callcount, codesSeen(3)
  24        common /myerrhan/ callcount, codesSeen
  25
  26        errs = 0
  27        callcount = 0
  28        call mtest_init( ierr )
  29 !
  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 )
  37 !
  38        call mpi_win_create_errhandler( myerrhanfunc, myerrhan, ierr )
  39 !
  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
  43 !
  44        call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
  45        call mpi_type_size( MPI_INTEGER, intsize, ierr )
  46        asize  = 10 * intsize
  47        call mpi_win_create( buf, asize, intsize, MPI_INFO_NULL, &
  48       &                      comm, win, ierr )
  49 !
  50        call mpi_win_set_errhandler( win, myerrhan, ierr )
  51
  52        call mpi_win_get_errhandler( win, qerr, ierr )
  53        if (qerr .ne. myerrhan) then
  54           errs = errs + 1
  55           print *, ' Did not get expected error handler'
  56        endif
  57        call mpi_errhandler_free( qerr, ierr )
  58 ! We can free our error handler now
  59        call mpi_errhandler_free( myerrhan, ierr )
  60
  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 )
  64
  65        if (callcount .ne. 3) then
  66           errs = errs + 1
  67           print *, ' Expected 3 calls to error handler, found ',  &
  68       &             callcount
  69        else
  70           if (codesSeen(1) .ne. newerrclass) then
  71              errs = errs + 1
  72              print *, 'Expected class ', newerrclass, ' got ',  &
  73       &                codesSeen(1)
  74           endif
  75           if (codesSeen(2) .ne. code(1)) then
  76              errs = errs + 1
  77              print *, 'Expected code ', code(1), ' got ',  &
  78       &                codesSeen(2)
  79           endif
  80           if (codesSeen(3) .ne. code(2)) then
  81              errs = errs + 1
  82              print *, 'Expected code ', code(2), ' got ',  &
  83       &                codesSeen(3)
  84           endif
  85        endif
  86
  87        call mpi_win_free( win, ierr )
  88        call mpi_comm_free( comm, ierr )
  89 !
  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
  93           errs = errs + 1
  94           print *, ' Wrong string for error class: ', errstring(1:rlen)
  95        endif
  96        call mpi_error_class( code(1), 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(1), errstring, rlen, ierr )
 102        if (errstring(1:rlen) .ne. "First new code") then
 103           errs = errs + 1
 104           print *, ' Wrong string for error code: ', errstring(1:rlen)
 105        endif
 106        call mpi_error_class( code(2), eclass, ierr )
 107        if (eclass .ne. newerrclass) then
 108           errs = errs + 1
 109           print *, ' Class for new code is not correct'
 110        endif
 111        call mpi_error_string( code(2), errstring, rlen, ierr )
 112        if (errstring(1:rlen) .ne. "Second new code") then
 113           errs = errs + 1
 114           print *, ' Wrong string for error code: ', errstring(1:rlen)
 115        endif
 116
 117        call mtest_finalize( errs )
 118        call mpi_finalize( ierr )
 119
 120        end
 121 !
 122        subroutine myerrhanfunc( win, errcode )
 123        use mpi
 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 ! 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