subroutine prterr(error, ie, istdout, istderr, comm)
use w90_comms, only: comms_no_sync_bcast, comms_no_sync_send, comms_no_sync_recv, &
w90_comm_type, mpirank, mpisize
use w90_error_base, only: code_deactivated, code_remote, w90_error_type
! arguments
integer, intent(inout) :: ie ! global error value to be returned
integer, intent(in) :: istderr, istdout
type(w90_comm_type), intent(in) :: comm
type(w90_error_type), allocatable, intent(inout) :: error
! local variables
type(w90_error_type), allocatable :: le ! unchecked error state for calls made in this routine
integer :: je ! error value on remote ranks
integer :: j ! rank index
integer :: failrank ! lowest rank reporting an error
character(len=128) :: mesg ! only print 128 chars of error
ie = 0
mesg = 'not set'
if (mpirank(comm) == 0) then
! currently this printout will list only the lowest failing rank, not all failing ranks
do j = mpisize(comm) - 1, 1, -1
call comms_no_sync_recv(je, 1, j, le, comm)
if (je /= code_remote .and. je /= 0) then
failrank = j
ie = je
call comms_no_sync_recv(mesg, 128, j, le, comm)
end if
end do
! if the error is on rank0
if (error%code /= code_remote .and. error%code /= 0) then
failrank = 0
ie = error%code
mesg = error%message
end if
write (istdout, *) 'Exiting.......'
write (istdout, '(1x,a)') trim(mesg)
write (istdout, '(1x,a,i0,a)') '(rank: ', failrank, ')'
write (istderr, *) 'Exiting.......'
write (istderr, '(1x,a)') trim(mesg)
write (istderr, '(1x,a,i0,a)') '(rank: ', failrank, ')'
!write (istderr, '(1x,a)') 'error encountered; check .wout log'
else ! non 0 ranks
je = error%code
call comms_no_sync_send(je, 1, 0, le, comm)
if (je /= code_remote .and. je /= 0) then
ie = je ! also set failed status on non 0 ranks
mesg = error%message
call comms_no_sync_send(mesg, 128, 0, le, comm)
end if
end if
! Every rank must report the same failure. A non-root rank whose own error is
! code_remote (the error originated elsewhere) leaves ie at 0 above and would
! otherwise return "success" to a library caller while root returns the failure.
call comms_no_sync_bcast(ie, 1, le, comm)
flush (istdout)
flush (istderr)
error%code = code_deactivated
deallocate (error) ! else allocated error trips uncaught error mechanism (ifdef W90DEV, see io.F90)
end subroutine prterr