! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 ! Salvatore Filippone ! Alfredo Buttari ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: ! 1. Redistributions of source code must retain the above copyright ! notice, this list of conditions and the following disclaimer. ! 2. Redistributions in binary form must reproduce the above copyright ! notice, this list of conditions, and the following disclaimer in the ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS ! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. ! ! module psb_error_mod use psb_const_mod integer(psb_ipk_), parameter, public :: psb_act_ret_=0 integer(psb_ipk_), parameter, public :: psb_act_print_=1 integer(psb_ipk_), parameter, public :: psb_act_abort_=2 integer(psb_ipk_), parameter, public :: psb_debug_ext_=1, psb_debug_outer_=2 integer(psb_ipk_), parameter, public :: psb_debug_comp_=3, psb_debug_inner_=4 integer(psb_ipk_), parameter, public :: psb_debug_serial_=8, psb_debug_serial_comp_=9 integer(psb_ipk_), parameter, public :: psb_no_err_ = 0 integer(psb_ipk_), parameter, public :: psb_err_warning_ = 1 integer(psb_ipk_), parameter, public :: psb_err_fatal_ = 2 integer(psb_ipk_), parameter, public :: psb_max_errmsg_len_ = 132 ! ! Error handling ! public psb_errpush, psb_error, psb_get_errstatus,& & psb_errstatus_fatal, psb_errstatus_warning,& & psb_errstatus_ok, psb_warning_push,& & psb_errpop, psb_errcomm, psb_get_numerr, & & psb_get_errverbosity, psb_set_errverbosity, & & psb_erractionsave, psb_erractionrestore, & & psb_get_erraction, psb_set_erraction, & & psb_set_erract_return, psb_set_erract_print, psb_set_erract_abort,& & psb_is_erract_return, psb_is_erract_print, psb_is_erract_abort,& & psb_get_debug_level, psb_set_debug_level,& & psb_get_debug_unit, psb_set_debug_unit,& & psb_get_serial_debug_level, psb_set_serial_debug_level,& & psb_clean_errstack, psb_error_handler, & & psb_ser_error_handler, psb_par_error_handler, & & psb_ser_error_print_stack, psb_par_error_print_stack,& & psb_error_print_stack, psb_errmsg, psb_ach_errmsg, & & psb_set_global_checks, psb_clear_global_checks, psb_get_global_checks,& & psb_check_error interface psb_error_handler subroutine psb_ser_error_handler(err_act) import :: psb_ipk_ integer(psb_ipk_), intent(inout) :: err_act end subroutine psb_ser_error_handler subroutine psb_par_error_handler(ctxt,err_act) import :: psb_ipk_,psb_mpk_, psb_ctxt_type type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: err_act end subroutine psb_par_error_handler end interface interface psb_error subroutine psb_serror() end subroutine psb_serror subroutine psb_perror(ctxt,abrt) import :: psb_ipk_, psb_ctxt_type type(psb_ctxt_type), intent(in) :: ctxt logical, intent(in), optional :: abrt end subroutine psb_perror end interface interface psb_error_print_stack subroutine psb_par_error_print_stack(ctxt) import :: psb_ipk_, psb_ctxt_type type(psb_ctxt_type), intent(in) :: ctxt end subroutine psb_par_error_print_stack subroutine psb_ser_error_print_stack() end subroutine psb_ser_error_print_stack end interface interface psb_errcomm #if defined(IPK8) subroutine psb_errcomm_m(ctxt, err) import :: psb_ipk_, psb_mpk_, psb_ctxt_type type(pxb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(inout) :: err end subroutine psb_errcomm_m #endif subroutine psb_errcomm_i(ctxt, err) import :: psb_ipk_, psb_ctxt_type type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(inout) :: err end subroutine psb_errcomm_i end interface psb_errcomm interface psb_errpop module procedure psb_errpop, psb_ach_errpop end interface interface psb_errmsg module procedure psb_errmsg, psb_ach_errmsg end interface private type psb_errstack_node ! the error code integer(psb_ipk_) :: err_code=0 ! the name of the routine generating the error character(len=20) :: routine='' ! array of integer data to complete the error msg integer(psb_epk_),dimension(5) :: e_err_data=0 ! real(psb_dpk_)(dim=10) :: r_err_data=0.d0 ! array of real data to complete the error msg ! complex(dim=10) :: c_err_data=0.c0 ! array of complex data to complete the error msg ! array of character data to complete the error msg character(len=40) :: a_err_data='' ! pointer to the next element in the stack type(psb_errstack_node), pointer :: next end type psb_errstack_node type psb_errstack ! pointer to the top element of the stack type(psb_errstack_node), pointer :: top => null() ! number of entries in the stack integer(psb_ipk_) :: n_elems=0 end type psb_errstack type(psb_errstack), save :: error_stack integer(psb_ipk_), save :: error_status = psb_no_err_ integer(psb_ipk_), save :: verbosity_level = 1 integer(psb_ipk_), save :: err_action = psb_act_abort_ integer(psb_ipk_), save :: debug_level = 0, debug_unit, serial_debug_level=0 logical, save :: comm_global_checks = .false. contains subroutine psb_set_global_checks(val) logical, intent(in), optional :: val if (present(val)) then comm_global_checks = val else comm_global_checks = .true. end if end subroutine psb_set_global_checks subroutine psb_clear_global_checks() comm_global_checks = .false. end subroutine psb_clear_global_checks function psb_get_global_checks() result(val) logical :: val val = comm_global_checks end function psb_get_global_checks subroutine psb_check_error(ctxt,abrt) implicit none type(psb_ctxt_type), intent(in) :: ctxt logical, optional, intent(in) :: abrt if (psb_errstatus_fatal()) then call psb_error(ctxt,abrt) end if end subroutine psb_check_error ! saves action to support error traceback ! also changes error action to "return" subroutine psb_erractionsave(err_act) integer(psb_ipk_), intent(out) :: err_act err_act = err_action err_action = psb_act_ret_ end subroutine psb_erractionsave ! return the action to take upon error occurrence subroutine psb_get_erraction(err_act) integer(psb_ipk_), intent(out) :: err_act err_act=err_action end subroutine psb_get_erraction ! sets the action to take upon error occurrence subroutine psb_set_erraction(err_act) integer(psb_ipk_), intent(in) :: err_act err_action=err_act end subroutine psb_set_erraction ! sets the action to take upon error occurrence subroutine psb_set_erract_return() err_action = psb_act_ret_ end subroutine psb_set_erract_return subroutine psb_set_erract_print() err_action = psb_act_print_ end subroutine psb_set_erract_print subroutine psb_set_erract_abort() err_action = psb_act_abort_ end subroutine psb_set_erract_abort function psb_is_erract_return() result(res) logical :: res res = (err_action == psb_act_ret_) end function psb_is_erract_return function psb_is_erract_print() result(res) logical :: res res = (err_action == psb_act_print_) end function psb_is_erract_print function psb_is_erract_abort() result(res) logical :: res res = (err_action == psb_act_abort_) end function psb_is_erract_abort ! restores error action previously saved with psb_erractionsave subroutine psb_erractionrestore(err_act) integer(psb_ipk_), intent(in) :: err_act err_action = err_act end subroutine psb_erractionrestore function psb_get_debug_level() integer(psb_ipk_) :: psb_get_debug_level psb_get_debug_level = debug_level end function psb_get_debug_level subroutine psb_set_debug_level(level) integer(psb_ipk_), intent(in) :: level if (level >= 0) then debug_level = level else debug_level = 0 end if end subroutine psb_set_debug_level function psb_get_debug_unit() integer(psb_ipk_) :: psb_get_debug_unit psb_get_debug_unit = debug_unit end function psb_get_debug_unit subroutine psb_set_debug_unit(unit) integer(psb_ipk_), intent(in) :: unit if ((unit >= 0).or.(unit == psb_err_unit)& & .or.(unit == psb_out_unit)) then debug_unit = unit else debug_unit = 0 end if end subroutine psb_set_debug_unit function psb_get_serial_debug_level() integer(psb_ipk_) :: psb_get_serial_debug_level psb_get_serial_debug_level = serial_debug_level end function psb_get_serial_debug_level subroutine psb_set_serial_debug_level(level) integer(psb_ipk_), intent(in) :: level if (level >= 0) then serial_debug_level = level else serial_debug_level = 0 end if end subroutine psb_set_serial_debug_level ! sets verbosity of the error message subroutine psb_set_errverbosity(v) integer(psb_ipk_), intent(in) :: v verbosity_level=v end subroutine psb_set_errverbosity ! returns number of errors function psb_get_numerr() integer(psb_ipk_) :: psb_get_numerr psb_get_numerr = error_stack%n_elems end function psb_get_numerr ! returns verbosity of the error message function psb_get_errverbosity() integer(psb_ipk_) :: psb_get_errverbosity psb_get_errverbosity=verbosity_level end function psb_get_errverbosity ! checks the status of the error condition function psb_get_errstatus() integer(psb_ipk_) :: psb_get_errstatus psb_get_errstatus = error_status end function psb_get_errstatus subroutine psb_set_errstatus(ircode) integer(psb_ipk_) :: ircode if ((psb_no_err_<=ircode).and.(ircode <= psb_err_fatal_))& & error_status=ircode end subroutine psb_set_errstatus function psb_errstatus_fatal() result(res) logical :: res res = (error_status == psb_err_fatal_) end function psb_errstatus_fatal function psb_errstatus_warning() result(res) logical :: res res = (error_status == psb_err_warning_) end function psb_errstatus_warning function psb_errstatus_ok() result(res) logical :: res res = (error_status == psb_no_err_) end function psb_errstatus_ok ! pushes an error on the error stack subroutine psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) integer(psb_ipk_), intent(in) :: err_c character(len=*), intent(in) :: r_name character(len=*), optional :: a_err integer(psb_ipk_), optional :: i_err(:) integer(psb_lpk_), optional :: l_err(:) integer(psb_mpk_), optional :: m_err(:) integer(psb_epk_), optional :: e_err(:) type(psb_errstack_node), pointer :: new_node integer :: isz allocate(new_node) new_node%err_code = err_c new_node%routine = r_name if (present(m_err)) then isz = min(size(new_node%e_err_data),size(m_err)) new_node%e_err_data(1:isz) = m_err(1:isz) end if if (present(e_err)) then isz = min(size(new_node%e_err_data),size(e_err)) new_node%e_err_data(1:isz) = e_err(1:isz) end if if (present(i_err)) then isz = min(size(new_node%e_err_data),size(i_err)) new_node%e_err_data(1:isz) = i_err(1:isz) end if if (present(l_err)) then isz = min(size(new_node%e_err_data),size(l_err)) new_node%e_err_data(1:isz) = l_err(1:isz) end if if(present(a_err)) then new_node%a_err_data = a_err end if new_node%next => error_stack%top error_stack%top => new_node error_stack%n_elems = error_stack%n_elems+1 nullify(new_node) end subroutine psb_stackpush ! pushes an error on the error stack subroutine psb_errpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) integer(psb_ipk_), intent(in) :: err_c character(len=*), intent(in) :: r_name character(len=*), optional :: a_err integer(psb_ipk_), optional :: i_err(:) integer(psb_lpk_), optional :: l_err(:) integer(psb_mpk_), optional :: m_err(:) integer(psb_epk_), optional :: e_err(:) call psb_set_errstatus(psb_err_fatal_) call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) end subroutine psb_errpush ! pushes a warning on the error stack subroutine psb_warning_push(err_c, r_name, a_err, i_err, l_err, m_err, e_err) integer(psb_ipk_), intent(in) :: err_c character(len=*), intent(in) :: r_name character(len=*), optional :: a_err integer(psb_ipk_), optional :: i_err(:) integer(psb_lpk_), optional :: l_err(:) integer(psb_mpk_), optional :: m_err(:) integer(psb_epk_), optional :: e_err(:) if (.not.psb_errstatus_fatal())& & call psb_set_errstatus( psb_err_warning_) call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) end subroutine psb_warning_push ! pops an error from the error stack subroutine psb_ach_errpop(achmsg) character(len=psb_max_errmsg_len_), allocatable, intent(out) :: achmsg(:) integer(psb_ipk_) :: err_c character(len=20) :: r_name character(len=40) :: a_e_d integer(psb_epk_) :: e_e_d(5) type(psb_errstack_node), pointer :: old_node if (error_stack%n_elems > 0) then err_c = error_stack%top%err_code r_name = error_stack%top%routine e_e_d = error_stack%top%e_err_data a_e_d = error_stack%top%a_err_data call psb_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d) old_node => error_stack%top error_stack%top => old_node%next error_stack%n_elems = error_stack%n_elems - 1 deallocate(old_node) end if if (error_stack%n_elems == 0) error_status=0 end subroutine psb_ach_errpop ! pops an error from the error stack subroutine psb_errpop(err_c, r_name, e_e_d, a_e_d) integer(psb_ipk_), intent(out) :: err_c character(len=20), intent(out) :: r_name character(len=40), intent(out) :: a_e_d integer(psb_epk_), intent(out) :: e_e_d(5) type(psb_errstack_node), pointer :: old_node if (error_stack%n_elems > 0) then err_c = error_stack%top%err_code r_name = error_stack%top%routine e_e_d = error_stack%top%e_err_data a_e_d = error_stack%top%a_err_data old_node => error_stack%top error_stack%top => old_node%next error_stack%n_elems = error_stack%n_elems - 1 deallocate(old_node) end if if (error_stack%n_elems == 0) error_status=psb_no_err_ end subroutine psb_errpop ! Clean the error stack subroutine psb_clean_errstack() integer(psb_ipk_) :: err_c character(len=20) :: r_name character(len=40) :: a_e_d integer(psb_epk_) :: e_e_d(5) do while (psb_get_numerr() > 0) call psb_errpop(err_c, r_name, e_e_d, a_e_d) end do end subroutine psb_clean_errstack ! prints the error msg associated to a specific error code subroutine psb_ach_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d,me) character(len=psb_max_errmsg_len_), allocatable, intent(out) :: achmsg(:) integer(psb_ipk_), intent(in) :: err_c character(len=20), intent(in) :: r_name character(len=40), intent(in) :: a_e_d integer(psb_epk_), intent(in) :: e_e_d(5) integer(psb_mpk_), optional :: me character(len=psb_max_errmsg_len_) :: tmpmsg if(present(me)) then write(tmpmsg,& & '("Process: ",i0,". PSBLAS Error (",i0,") in subroutine: ",a)')& & me,err_c,trim(r_name) else write(tmpmsg,'("PSBLAS Error (",i0,") in subroutine: ",a)')& & err_c,trim(r_name) end if select case (err_c) case(:psb_success_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("error on calling perror. err_c must be greater than 0")') case(psb_err_pivot_too_small_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("pivot too small: ",i0,1x,a)')e_e_d(1),trim(a_e_d) case(psb_err_invalid_ovr_num_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid number of ovr:",i0)')e_e_d(1) case(psb_err_invalid_input_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid input")') case(psb_err_iarg_neg_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," cannot be less than 0")')e_e_d(1) write(achmsg(3),'("current value is ",i0)')e_e_d(2) case(psb_err_iarg_pos_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," cannot be greater than 0")')e_e_d(1) write(achmsg(3),'("current value is ",i0)')e_e_d(2) case(psb_err_input_value_invalid_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," has an invalid value")')e_e_d(1) write(achmsg(3),'("current value is ",i0)')e_e_d(2) case(psb_err_input_asize_invalid_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("Size of input array argument n. ",i0," is invalid.")')e_e_d(1) write(achmsg(3),'("Current value is ",i0)')e_e_d(2) case(psb_err_input_asize_small_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("Size of input array argument n. ",i0," is too small.")')e_e_d(1) write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') e_e_d(2),e_e_d(3) case(psb_err_iarg_invalid_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," has an invalid value")')e_e_d(1) write(achmsg(3),'("current value is ",a)')a_e_d(2:2) case(psb_err_iarg_not_gtia_ii_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& & '("input argument n. ",i0," must be equal or greater than input argument n. ",i0)') & & e_e_d(1), e_e_d(3) write(achmsg(3),'("current values are ",i0," < ",i0)')& & e_e_d(2),e_e_d(5) case(psb_err_iarg_not_gteia_ii_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," must be greater than or equal to ",i0)')& & e_e_d(1),e_e_d(2) write(achmsg(3),'("current value is ",i0," < ",i0)')& & e_e_d(3), e_e_d(2) case(psb_err_iarg_invalid_value_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," in entry # ",i0," has an invalid value")')& & e_e_d(1:2) write(achmsg(3),'("current value is ",a)')trim(a_e_d) case(psb_err_asb_nrc_error_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("Impossible error in ASB: nrow>ncol,")') write(achmsg(3),'("Actual values are ",i0," > ",i0)')e_e_d(1:2) ! ... csr format error ... case(psb_err_iarg2_neg_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument ia2(1) is less than 0")') write(achmsg(3),'("current value is ",i0)')e_e_d(1) ! ... csr format error ... case(psb_err_ia2_not_increasing_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("indices in ia2 array are not in increasing order")') case(psb_err_ia1_not_increasing_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("indices in ia1 array are not in increasing order")') ! ... csr format error ... case(psb_err_ia1_badindices_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("indices in ia1 array are not within problem dimension")') write(achmsg(3),'("problem dimension is ",i0)')e_e_d(1) case(psb_err_invalid_args_combination_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("invalid combination of input arguments")') case(psb_err_invalid_pid_arg_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid process identifier in input array argument n. ",i0,".")')& & e_e_d(1) write(achmsg(3),'("Current value is ",i0)')e_e_d(2) case(psb_err_iarg_n_mbgtian_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," must be greater than input argument n. ",i0)')& & e_e_d(1:2) write(achmsg(3),'("current values are ",i0," < ",i0)') e_e_d(3:4) case(psb_err_dupl_cd_vl) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("there are duplicated entries in vl (input to cdall)")') ! ... coo format error ... ! ... coo format error ... case(psb_err_duplicate_coo) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("there are duplicated elements in coo format")') write(achmsg(3),'("and you have chosen psb_dupl_err_ ")') case(psb_err_invalid_input_format_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid input format ",a3)')& & a_e_d(1:3) case(psb_err_unsupported_format_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Format ",a3," not yet supported here")')& &a_e_d(1:3) case(psb_err_format_unknown_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Format ",a3," is unknown")')& & a_e_d(1:3) case(psb_err_iarray_outside_bounds_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("indices in input array are not within problem dimension ",2(i0,2x))')& &e_e_d(1:2) case(psb_err_iarray_outside_process_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("indices in input array are not belonging to the calling process ",i0)')& & e_e_d(1) case(psb_err_forgot_geall_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("To call this routine you must first call psb_geall on the same matrix")') case(psb_err_forgot_spall_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("To call this routine you must first call psb_spall on the same matrix")') case(psb_err_wrong_ins_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("Something went wrong before this call to ",a,", probably in cdins/spins")')& & trim(r_name) case(psb_err_bad_int_cnv_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Bad integer conversion from ",i0,"to ",i0)') & & e_e_d(1),e_e_d(2) case(psb_err_mpi_int_ovflw_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Size argument to MPI overflow.")') case(psb_err_iarg_mbeeiarra_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Input argument n. ",i0," must be equal to entry n. ",i0," in array input argument n.",i0)') & & e_e_d(1),e_e_d(4),e_e_d(3) write(achmsg(3),'("Current values are ",i0," != ",i0)')e_e_d(2), e_e_d(5) case(psb_err_mpi_error_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("MPI error:",i0)')e_e_d(1) case(psb_err_parm_differs_among_procs_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("Parameter n. ",i0," must be equal on all processes. ",i0)')e_e_d(1) case(psb_err_entry_out_of_bounds_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')& & e_e_d(1),e_e_d(3),e_e_d(4),e_e_d(2) case(psb_err_inconsistent_index_lists_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Index lists are inconsistent: some indices are orphans")') case(psb_err_partfunc_toomuchprocs_) allocate(achmsg(4)) achmsg(1) = tmpmsg write(achmsg(2),& &'("partition function passed as input argument n. ",i0," returns number of processes")')& &e_e_d(1) write(achmsg(3),& & '("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')& &e_e_d(4) write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')e_e_d(2),e_e_d(3) case(psb_err_partfunc_toofewprocs_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& &'("partition function passed as input argument n. ",i0," returns number of processes")')& &e_e_d(1) write(achmsg(3),& &'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')& &e_e_d(3),e_e_d(2) case(psb_err_partfunc_wrong_pid_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& &'("partition function passed as input argument n. ",i0," returns wrong processes identifier")')& & e_e_d(1) write(achmsg(3),& & '("on global point ",i0,". Current value returned is : ",i0)')& & e_e_d(3),e_e_d(2) case(psb_err_no_optional_arg_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("One of the optional arguments ",a," must be present")')& & trim(a_e_d) case(psb_err_optional_arg_pair_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("The optional arguments ",a," must be present together")')& & trim(a_e_d) case(psb_err_arg_m_required_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Argument M is required when argument PARTS is specified")') case(psb_err_missing_override_method_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Base class method ",a," called: the class for ",a," is missing an overriding implementation")')& & trim(r_name), trim(a_e_d) case(psb_err_invalid_dynamic_type_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," has a dynamic type not allowed here.")')& & e_e_d(1) case(psb_err_rectangular_mat_unsupported_) write(achmsg(2),& &'("This routine does not support rectangular matrices: ",i0, " /= ",i0)') & & e_e_d(1), e_e_d(2) case(psb_err_invalid_mat_state_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid state for sparse matrix")') case(psb_err_invalid_cd_state_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid state for communication descriptor")') case(psb_err_invalid_a_and_cd_state_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid combined state for A and DESC_A")') case(psb_err_invalid_vect_state_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid state for vector")') case(psb_err_invalid_matrix_sizes_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid combination of matrix sizes")') case(1125:1999) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("computational error. code: ",i0)')err_c case(psb_err_context_error_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(0,'("Parallel context error. Number of processes=-1")') case(psb_err_initerror_neugh_procs_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Initialization error: not enough processes available in the parallel environment")') case(psb_err_invalid_matrix_input_state_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid input state for matrix.")') case(psb_err_input_no_regen_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Input state for matrix is not adequate for regeneration.")') case(2233:2999) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("resource error. code: ",i0)')err_c case(3000:3009) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("sparse matrix representation ",a3," not yet implemented")')& &a_e_d(1:3) case(psb_err_lld_case_not_implemented_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("Case lld not equal matrix_data[N_COL_] is not yet implemented.")') case(psb_err_transpose_unsupported_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("transpose option for sparse matrix representation ",a3," not implemented")')& & a_e_d(1:3) case(psb_err_transpose_c_unsupported_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Case trans = C is not yet implemented.")') case(psb_err_transpose_not_n_unsupported_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Case trans /= N is not yet implemented.")') case(psb_err_only_unit_diag_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Only unit diagonal so far for triangular matrices. ")') case(3023) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Cases DESCRA(1:1)=S DESCRA(1:1)=T not yet implemented. ")') case(3024) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Cases DESCRA(1:1)=G not yet implemented. ")') case(psb_err_ja_nix_ia_niy_unsupported_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Case ja /= ix or ia/=iy is not yet implemented.")') case(psb_err_ix_n1_iy_n1_unsupported_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Case ix /= 1 or iy /= 1 is not yet implemented.")') case(3050) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Case ix /= iy is not yet implemented.")') case(3060) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Case ix /= 1 is not yet implemented.")') case(3070) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("This operation is only implemented with no overlap.")') case(3080) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Decompostion type ",i0," not yet supported.")')& & e_e_d(1) case(3090) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Insert matrix mode not yet implemented.")') case(3100) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Error on index. Element has not been inserted")') write(achmsg(3),& & '("local index is: ",i0," and global index is:",i0)')& & e_e_d(1:2) case(psb_err_input_matrix_unassembled_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("Before you call this routine, you must assembly sparse matrix")') case(3111) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Before you call this routine, you must initialize the preconditioner")') case(3112) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Before you call this routine, you must build the preconditioner")') case(3113:3998) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("miscellaneus error. code: ",i0)')err_c case(psb_err_missing_aux_lib_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& &'("This method requires an external support library.")') write(achmsg(3),& &'("Fix configure and rebuild the software.")') case(psb_err_alloc_dealloc_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Allocation/deallocation error")') case(psb_err_internal_error_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Internal error: ",a)') & & trim(a_e_d) case(psb_err_from_subroutine_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Error from call to subroutine ",a)')& & trim(a_e_d) case(psb_err_from_subroutine_non_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Error from call to a subroutine ")') case(psb_err_from_subroutine_i_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Error ",i0," from call to a subroutine ")')& & e_e_d(1) case(psb_err_from_subroutine_ai_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Error from call to subroutine ",a," ",i0)')& & trim(a_e_d),e_e_d(1) case(psb_err_alloc_request_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Error on allocation request for ",i0," items of type ",a)')& & e_e_d(1),trim(a_e_d) case(4110) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Error ",i0," from call to an external package in subroutine ",a)')& &e_e_d(1),trim(a_e_d) case(psb_err_invalid_istop_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid ISTOP: ",i0)')e_e_d(1) case(psb_err_invalid_irst_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid IRST: ",i0)')e_e_d(1) case(psb_err_invalid_preci_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid PREC: ",i0)')e_e_d(1) case(psb_err_invalid_preca_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid PREC: ",a3)')a_e_d(1:3) case default allocate(achmsg(4)) achmsg(1) = tmpmsg write(achmsg(2),'("unknown error (",i0,") in subroutine ",a)')& & err_c,trim(r_name) write(achmsg(3),'(5(i0,2x))') e_e_d write(achmsg(4),'(a)') trim(a_e_d) end select end subroutine psb_ach_errmsg ! prints the error msg associated to a specific error code subroutine psb_errmsg(iunit, err_c, r_name, e_e_d, a_e_d,me) integer(psb_ipk_), intent(in) :: iunit integer(psb_ipk_), intent(in) :: err_c character(len=20), intent(in) :: r_name character(len=40), intent(in) :: a_e_d integer(psb_epk_), intent(in) :: e_e_d(5) integer(psb_mpk_), optional :: me integer(psb_ipk_) :: i character(len=psb_max_errmsg_len_), allocatable :: achmsg(:) call psb_ach_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d,me) do i=1,size(achmsg) write(iunit,'(a)') trim(achmsg(i)) end do end subroutine psb_errmsg end module psb_error_mod