You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
psblas3/base/modules/psb_error_impl.F90

116 lines
2.8 KiB
Fortran

! checks wether an error has occurred on one of the porecesses in the execution pool
subroutine psb_errcomm(ictxt, err)
use psb_error_mod, psb_protect_name => psb_errcomm
use psb_penv_mod
integer, intent(in) :: ictxt
integer, intent(inout):: err
integer :: temp(2)
! Cannot use psb_amx or otherwise we have a recursion in module usage
#if !defined(SERIAL_MPI)
call psb_amx(ictxt, err)
#endif
end subroutine psb_errcomm
! handles the occurence of an error in a serial routine
subroutine psb_serror()
use psb_const_mod
use psb_error_mod
implicit none
integer :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer :: i_e_d(5)
if(psb_get_errstatus() > 0) then
if(psb_get_errverbosity() > 1) then
do while (psb_get_numerr() > izero)
write(psb_err_unit,'(50("="))')
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(err_c, r_name, i_e_d, a_e_d)
! write(psb_err_unit,'(50("="))')
end do
else
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(err_c, r_name, i_e_d, a_e_d)
do while (psb_get_numerr() > 0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
end do
end if
end if
#if defined(HAVE_FLUSH_STMT)
flush(0)
#endif
end subroutine psb_serror
! handles the occurence of an error in a parallel routine
subroutine psb_perror(ictxt)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
integer, intent(in) :: ictxt
integer :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer :: i_e_d(5)
integer :: iam, np
#if defined(SERIAL_MPI)
iam = -1
#else
call psb_info(ictxt,iam,np)
#endif
if(psb_get_errstatus() > 0) then
if(psb_get_errverbosity() > 1) then
do while (psb_get_numerr() > izero)
write(psb_err_unit,'(50("="))')
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(err_c, r_name, i_e_d, a_e_d,iam)
! write(psb_err_unit,'(50("="))')
end do
#if defined(HAVE_FLUSH_STMT)
flush(0)
#endif
#if defined(SERIAL_MPI)
stop
#else
call psb_abort(ictxt,-1)
#endif
else
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
call psb_errmsg(err_c, r_name, i_e_d, a_e_d,iam)
do while (psb_get_numerr() > 0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
end do
#if defined(HAVE_FLUSH_STMT)
flush(0)
#endif
#if defined(SERIAL_MPI)
stop
#else
call psb_abort(ictxt,-1)
#endif
end if
end if
if(psb_get_errstatus() > izero) then
#if defined(SERIAL_MPI)
stop
#else
call psb_abort(ictxt,err_c)
#endif
end if
end subroutine psb_perror