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

169 lines
4.2 KiB
Fortran

! checks wether an error has occurred on one of the porecesses in the execution pool
subroutine psb_errcomm_i(ctxt, err)
use psb_error_mod, psb_protect_name => psb_errcomm
use psb_penv_mod
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(inout) :: err
if (psb_get_global_checks()) call psb_amx(ctxt, err)
end subroutine psb_errcomm_i
#if defined(IPK8)
subroutine psb_errcomm_m(ctxt, err)
use psb_error_mod, psb_protect_name => psb_errcomm
use psb_penv_mod
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(inout) :: err
if (psb_get_global_checks()) call psb_amx(ctxt, err)
end subroutine psb_errcomm_m
#endif
subroutine psb_ser_error_handler(err_act)
use psb_error_mod, psb_protect_name => psb_ser_error_handler
use psb_penv_mod
implicit none
integer(psb_ipk_), intent(inout) :: err_act
call psb_erractionrestore(err_act)
if (err_act /= psb_act_ret_) &
& call psb_error()
if (err_act == psb_act_abort_) stop
return
end subroutine psb_ser_error_handler
subroutine psb_par_error_handler(ctxt,err_act)
use psb_error_mod, psb_protect_name => psb_par_error_handler
use psb_penv_mod
implicit none
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: err_act
call psb_erractionrestore(err_act)
if (err_act == psb_act_print_) then
call psb_error(ctxt, abrt=.false.)
else if (err_act == psb_act_ret_) then
! do nothing
else
call psb_error(ctxt, abrt=.true.)
end if
return
end subroutine psb_par_error_handler
subroutine psb_par_error_print_stack(ctxt)
use psb_error_mod, psb_protect_name => psb_par_error_print_stack
use psb_penv_mod
type(psb_ctxt_type), intent(in) :: ctxt
call psb_error(ctxt, abrt=.false.)
end subroutine psb_par_error_print_stack
subroutine psb_ser_error_print_stack()
use psb_error_mod, psb_protect_name => psb_ser_error_print_stack
call psb_error()
end subroutine psb_ser_error_print_stack
! handles the occurence of an error in a serial routine
subroutine psb_serror()
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_epk_) :: e_e_d(5)
if (psb_errstatus_fatal()) 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, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d)
! write(psb_err_unit,'(50("="))')
end do
else
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d)
do while (psb_get_numerr() > 0)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
end do
end if
end if
#if defined(HAVE_FLUSH_STMT)
flush(psb_err_unit)
#endif
end subroutine psb_serror
! handles the occurence of an error in a parallel routine
subroutine psb_perror(ctxt,abrt)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
type(psb_ctxt_type), intent(in) :: ctxt
logical, intent(in), optional :: abrt
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_epk_) :: e_e_d(5)
integer(psb_mpk_) :: iam, np
logical :: abrt_
abrt_=.true.
if (present(abrt)) abrt_=abrt
call psb_info(ctxt,iam,np)
if (psb_errstatus_fatal()) 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, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d,iam)
! write(psb_err_unit,'(50("="))')
end do
#if defined(HAVE_FLUSH_STMT)
flush(psb_err_unit)
#endif
if (abrt_) call psb_abort(ctxt,-1)
else
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d,iam)
do while (psb_get_numerr() > 0)
call psb_errpop(err_c, r_name, e_e_d, a_e_d)
end do
#if defined(HAVE_FLUSH_STMT)
flush(psb_err_unit)
#endif
if (abrt_) call psb_abort(ctxt,-1)
end if
end if
end subroutine psb_perror