fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Browse Source
psblas3-accel
Salvatore Filippone 10 years ago
parent 0fb9b0356a
commit 9b66b15ca2
5 changed files with 586 additions and 169 deletions
Show Stats Download Patch File Download Diff File

8
base/modules/parts.f90
Unescape Escape View File

@ -1,8 +0,0 @@
module psb_parts_mod
interface
subroutine psb_parts(glob_index,nrow,np,pv,nv)
integer(psb_ipk_), intent (in) :: glob_index,np,nrow
integer(psb_ipk_), intent (out) :: nv, pv(*)
end subroutine psb_parts
end interface
end module psb_parts_mod

8
base/modules/parts.fh
Unescape Escape View File

@ -1,8 +0,0 @@
interface
!.....user passed subroutine.....
subroutine parts(glob_index,nrow,np,pv,nv)
import :: psb_ipk_
integer(psb_ipk_), intent (in) :: glob_index,np,nrow
integer(psb_ipk_), intent (out) :: nv, pv(*)
end subroutine parts
end interface

82
base/modules/psb_error_impl.F90
Unescape Escape View File

@ -9,6 +9,57 @@ subroutine psb_errcomm(ictxt, err)
end subroutine psb_errcomm
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(ictxt,err_act)
use psb_error_mod, psb_protect_name => psb_par_error_handler
use psb_penv_mod
implicit none
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: err_act
call psb_erractionrestore(err_act)
if (err_act == psb_act_print_) &
& call psb_error(ictxt, abrt=.false.)
if (err_act == psb_act_abort_) &
& call psb_error(ictxt, abrt=.true.)
return
end subroutine psb_par_error_handler
subroutine psb_par_error_print_stack(ictxt)
use psb_error_mod, psb_protect_name => psb_par_error_print_stack
use psb_penv_mod
integer(psb_mpik_), intent(in) :: ictxt
call psb_error(ictxt, 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
@ -39,7 +90,7 @@ subroutine psb_serror()
end if
end if
#if defined(HAVE_FLUSH_STMT)
flush(0)
flush(psb_err_unit)
#endif
@ -47,18 +98,23 @@ end subroutine psb_serror
! handles the occurence of an error in a parallel routine
subroutine psb_perror(ictxt)
subroutine psb_perror(ictxt,abrt)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_ipk_) :: i_e_d(5)
integer(psb_mpik_), intent(in) :: ictxt
logical, intent(in), optional :: abrt
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
character(len=40) :: a_e_d
integer(psb_ipk_) :: i_e_d(5)
integer(psb_mpik_) :: iam, np
logical :: abrt_
abrt_=.true.
if (present(abrt)) abrt_=abrt
call psb_info(ictxt,iam,np)
if (psb_errstatus_fatal()) then
@ -71,11 +127,11 @@ subroutine psb_perror(ictxt)
! write(psb_err_unit,'(50("="))')
end do
#if defined(HAVE_FLUSH_STMT)
flush(0)
flush(psb_err_unit)
#endif
call psb_abort(ictxt,-1)
if (abrt_) call psb_abort(ictxt,-1)
else
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
@ -84,10 +140,10 @@ subroutine psb_perror(ictxt)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
end do
#if defined(HAVE_FLUSH_STMT)
flush(0)
flush(psb_err_unit)
#endif
call psb_abort(ictxt,-1)
if (abrt_) call psb_abort(ictxt,-1)
end if
end if

655
base/modules/psb_error_mod.F90
Unescape Escape View File

@ -32,7 +32,9 @@
module psb_error_mod
use psb_const_mod
integer(psb_ipk_), parameter, public :: psb_act_ret_=0, psb_act_abort_=1
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
@ -53,21 +55,48 @@ module psb_error_mod
& 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_clean_errstack, psb_error_handler, &
& psb_ser_error_handler, psb_par_error_handler, &
& psb_ser_error_print_stack, psb_par_error_print_stack
interface psb_error_handler
subroutine psb_ser_error_handler(err_act)
import :: psb_ipk_
integer(psb_ipk_), intent(in) :: err_act
end subroutine psb_ser_error_handler
subroutine psb_par_error_handler(ictxt,err_act)
import :: psb_ipk_,psb_mpik_
integer(psb_mpik_), intent(in) :: ictxt
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(ictxt)
subroutine psb_perror(ictxt,abrt)
import :: psb_mpik_
integer(psb_mpik_), intent(in) :: ictxt
integer(psb_mpik_), intent(in) :: ictxt
logical, intent(in), optional :: abrt
end subroutine psb_perror
end interface
interface psb_error_print_stack
subroutine psb_par_error_print_stack(ictxt)
import :: psb_ipk_,psb_mpik_
integer(psb_mpik_), intent(in) :: ictxt
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
subroutine psb_errcomm(ictxt, err)
import :: psb_mpik_, psb_ipk_
@ -76,6 +105,12 @@ module psb_error_mod
end subroutine psb_errcomm
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
#if defined(LONG_INTEGERS)
interface psb_error
@ -119,11 +154,11 @@ module psb_error_mod
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
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
contains
@ -164,6 +199,30 @@ contains
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)
@ -328,13 +387,39 @@ contains
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_ipk_) :: i_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
i_e_d = error_stack%top%i_err_data
a_e_d = error_stack%top%a_err_data
call psb_errmsg(achmsg,err_c, r_name, i_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, i_e_d, a_e_d)
integer(psb_ipk_), intent(out) :: err_c
integer(psb_ipk_), intent(out) :: err_c
character(len=20), intent(out) :: r_name
character(len=40), intent(out) :: a_e_d
integer(psb_ipk_), intent(out) :: i_e_d(5)
integer(psb_ipk_), intent(out) :: i_e_d(5)
type(psb_errstack_node), pointer :: old_node
@ -349,7 +434,7 @@ contains
error_stack%n_elems = error_stack%n_elems - 1
deallocate(old_node)
end if
if (error_stack%n_elems == 0) error_status=0
if (error_stack%n_elems == 0) error_status=psb_no_err_
end subroutine psb_errpop
@ -369,299 +454,591 @@ contains
end subroutine psb_clean_errstack
! prints the error msg associated to a specific error code
subroutine psb_errmsg(err_c, r_name, i_e_d, a_e_d,me)
subroutine psb_ach_errmsg(achmsg,err_c, r_name, i_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_ipk_), intent(in) :: i_e_d(5)
integer(psb_mpik_), optional :: me
character(len=psb_max_errmsg_len_) :: tmpmsg
if(present(me)) then
write(psb_err_unit,&
write(tmpmsg,&
& '("Process: ",i0,". PSBLAS Error (",i0,") in subroutine: ",a20)')&
& me,err_c,trim(r_name)
else
write(psb_err_unit,'("PSBLAS Error (",i0,") in subroutine: ",a)')&
write(tmpmsg,'("PSBLAS Error (",i0,") in subroutine: ",a)')&
& err_c,trim(r_name)
end if
select case (err_c)
case(:psb_success_)
write(psb_err_unit,'("error on calling sperror. err_c must be greater than 0")')
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_)
write(psb_err_unit,'("pivot too small: ",i0,1x,a)')i_e_d(1),trim(a_e_d)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("pivot too small: ",i0,1x,a)')i_e_d(1),trim(a_e_d)
case(psb_err_invalid_ovr_num_)
write(psb_err_unit,'("Invalid number of ovr:",i0)')i_e_d(1)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid number of ovr:",i0)')i_e_d(1)
case(psb_err_invalid_input_)
write(psb_err_unit,'("Invalid input")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid input")')
case(psb_err_iarg_neg_)
write(psb_err_unit,'("input argument n. ",i0," cannot be less than 0")')i_e_d(1)
write(psb_err_unit,'("current value is ",i0)')i_e_d(2)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," cannot be less than 0")')i_e_d(1)
write(achmsg(3),'("current value is ",i0)')i_e_d(2)
case(psb_err_iarg_pos_)
write(psb_err_unit,'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1)
write(psb_err_unit,'("current value is ",i0)')i_e_d(2)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1)
write(achmsg(3),'("current value is ",i0)')i_e_d(2)
case(psb_err_input_value_invalid_i_)
write(psb_err_unit,'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write(psb_err_unit,'("current value is ",i0)')i_e_d(2)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write(achmsg(3),'("current value is ",i0)')i_e_d(2)
case(psb_err_input_asize_invalid_i_)
write(psb_err_unit,'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1)
write(psb_err_unit,'("Current value is ",i0)')i_e_d(2)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1)
write(achmsg(3),'("Current value is ",i0)')i_e_d(2)
case(psb_err_input_asize_small_i_)
write(psb_err_unit,'("Size of input array argument n. ",i0," is too small.")')i_e_d(1)
write(psb_err_unit,'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Size of input array argument n. ",i0," is too small.")')i_e_d(1)
write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3)
case(psb_err_iarg_invalid_i_)
write(psb_err_unit,'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write(psb_err_unit,'("current value is ",a)')a_e_d(2:2)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write(achmsg(3),'("current value is ",a)')a_e_d(2:2)
case(psb_err_iarg_not_gtia_ii_)
write(psb_err_unit,&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("input argument n. ",i0," must be equal or greater than input argument n. ",i0)') &
& i_e_d(1), i_e_d(3)
write(psb_err_unit,'("current values are ",i0," < ",i0)')&
write(achmsg(3),'("current values are ",i0," < ",i0)')&
& i_e_d(2),i_e_d(5)
case(psb_err_iarg_not_gteia_ii_)
write(psb_err_unit,'("input argument n. ",i0," must be greater than or equal to ",i0)')&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," must be greater than or equal to ",i0)')&
& i_e_d(1),i_e_d(2)
write(psb_err_unit,'("current value is ",i0," < ",i0)')&
write(achmsg(3),'("current value is ",i0," < ",i0)')&
& i_e_d(3), i_e_d(2)
case(psb_err_iarg_invalid_value_)
write(psb_err_unit,'("input argument n. ",i0," in entry # ",i0," has an invalid value")')&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," in entry # ",i0," has an invalid value")')&
& i_e_d(1:2)
write(psb_err_unit,'("current value is ",a)')trim(a_e_d)
write(achmsg(3),'("current value is ",a)')trim(a_e_d)
case(psb_err_asb_nrc_error_)
write(psb_err_unit,'("Impossible error in ASB: nrow>ncol,")')
write(psb_err_unit,'("Actual values are ",i0," > ",i0)')i_e_d(1:2)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Impossible error in ASB: nrow>ncol,")')
write(achmsg(3),'("Actual values are ",i0," > ",i0)')i_e_d(1:2)
! ... csr format error ...
case(psb_err_iarg2_neg_)
write(psb_err_unit,'("input argument ia2(1) is less than 0")')
write(psb_err_unit,'("current value is ",i0)')i_e_d(1)
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument ia2(1) is less than 0")')
write(achmsg(3),'("current value is ",i0)')i_e_d(1)
! ... csr format error ...
case(psb_err_ia2_not_increasing_)
write(psb_err_unit,'("indices in ia2 array are not in increasing order")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("indices in ia2 array are not in increasing order")')
case(psb_err_ia1_not_increasing_)
write(psb_err_unit,'("indices in ia1 array are not in increasing order")')
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_)
write(psb_err_unit,'("indices in ia1 array are not within problem dimension")')
write(psb_err_unit,'("problem dimension is ",i0)')i_e_d(1)
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)')i_e_d(1)
case(psb_err_invalid_args_combination_)
write(psb_err_unit,'("invalid combination of input arguments")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("invalid combination of input arguments")')
case(psb_err_invalid_pid_arg_)
write(psb_err_unit,'("Invalid process identifier in input array argument n. ",i0,".")')&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid process identifier in input array argument n. ",i0,".")')&
& i_e_d(1)
write(psb_err_unit,'("Current value is ",i0)')i_e_d(2)
write(achmsg(3),'("Current value is ",i0)')i_e_d(2)
case(psb_err_iarg_n_mbgtian_)
write(psb_err_unit,'("input argument n. ",i0," must be greater than input argument n. ",i0)')&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," must be greater than input argument n. ",i0)')&
& i_e_d(1:2)
write(psb_err_unit,'("current values are ",i0," < ",i0)') i_e_d(3:4)
write(achmsg(3),'("current values are ",i0," < ",i0)') i_e_d(3:4)
case(psb_err_dupl_cd_vl)
write(psb_err_unit,'("there are duplicated entries in vl (input to cdall)")')
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)
write(psb_err_unit,'("there are duplicated elements in coo format")')
write(psb_err_unit,'("and you have chosen psb_dupl_err_ ")')
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_)
write(psb_err_unit,'("Invalid input format ",a3)')&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid input format ",a3)')&
& a_e_d(1:3)
case(psb_err_unsupported_format_)
write(psb_err_unit,'("Format ",a3," not yet supported here")')&
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_)
write(psb_err_unit,'("Format ",a3," is 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_)
write(psb_err_unit,'("indices in input array are not within problem dimension ",2(i0,2x))')&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("indices in input array are not within problem dimension ",2(i0,2x))')&
&i_e_d(1:2)
case(psb_err_iarray_outside_process_)
write(psb_err_unit,'("indices in input array are not belonging to the calling process ",i0)')&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("indices in input array are not belonging to the calling process ",i0)')&
& i_e_d(1)
case(psb_err_forgot_geall_)
write(psb_err_unit,'("To call this routine you must first call psb_geall on the same matrix")')
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_)
write(psb_err_unit,'("To call this routine you must first call psb_spall on the same matrix")')
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_)
write(0,'("Something went wrong before this call to ",a,", probably in cdins/spins")')&
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_iarg_mbeeiarra_i_)
write(psb_err_unit,&
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)') &
& i_e_d(1),i_e_d(4),i_e_d(3)
write(psb_err_unit,'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5)
write(achmsg(3),'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5)
case(psb_err_mpi_error_)
write(psb_err_unit,'("MPI error:",i0)')i_e_d(1)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("MPI error:",i0)')i_e_d(1)
case(psb_err_parm_differs_among_procs_)
write(psb_err_unit,'("Parameter n. ",i0," must be equal on all processes. ",i0)')i_e_d(1)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("Parameter n. ",i0," must be equal on all processes. ",i0)')i_e_d(1)
case(psb_err_entry_out_of_bounds_)
write(psb_err_unit,'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')&
& i_e_d(1),i_e_d(3),i_e_d(4),i_e_d(2)
case(psb_err_inconsistent_index_lists_)
write(psb_err_unit,'("Index lists are inconsistent: some indices are orphans")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Index lists are inconsistent: some indices are orphans")')
case(psb_err_partfunc_toomuchprocs_)
write(psb_err_unit,&
allocate(achmsg(4))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("partition function passed as input argument n. ",i0," returns number of processes")')&
&i_e_d(1)
write(psb_err_unit,&
write(achmsg(3),&
& '("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')&
&i_e_d(4)
write(psb_err_unit,'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3)
write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3)
case(psb_err_partfunc_toofewprocs_)
write(psb_err_unit,'("partition function passed as input argument n. ",i0," returns number of processes")')&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("partition function passed as input argument n. ",i0," returns number of processes")')&
&i_e_d(1)
write(psb_err_unit,'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')&
write(achmsg(3),&
&'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')&
&i_e_d(3),i_e_d(2)
case(psb_err_partfunc_wrong_pid_)
write(psb_err_unit,&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("partition function passed as input argument n. ",i0," returns wrong processes identifier")')&
& i_e_d(1)
write(psb_err_unit,'("on global point ",i0,". Current value returned is : ",i0)')&
write(achmsg(3),&
& '("on global point ",i0,". Current value returned is : ",i0)')&
& i_e_d(3),i_e_d(2)
case(psb_err_no_optional_arg_)
write(psb_err_unit,'("One of the optional arguments ",a," must be present")')&
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_arg_m_required_)
write(psb_err_unit,'("Argument M is required when argument PARTS is specified")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Argument M is required when argument PARTS is specified")')
case(psb_err_spmat_invalid_state_)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Sparse Matrix and descriptors are in an invalid state for this subroutine call: ",i0)')&
&i_e_d(1)
case(psb_err_missing_override_method_)
write(psb_err_unit,&
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_)
write(psb_err_unit,'("input argument n. ",i0," has a dynamic type not allowed here.")')&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("input argument n. ",i0," has a dynamic type not allowed here.")')&
& i_e_d(1)
case (psb_err_rectangular_mat_unsupported_)
write(psb_err_unit,&
case(psb_err_rectangular_mat_unsupported_)
write(achmsg(2),&
&'("This routine does not support rectangular matrices: ",i0, " /= ",i0)') &
& i_e_d(1), i_e_d(2)
case (psb_err_invalid_mat_state_)
write(psb_err_unit,'("Invalid state for sparse matrix")')
case (psb_err_invalid_cd_state_)
write(psb_err_unit,'("Invalid state for communication descriptor")')
case (psb_err_invalid_a_and_cd_state_)
write(psb_err_unit,'("Invalid combined state for A and DESC_A")')
case (psb_err_invalid_vect_state_)
write(psb_err_unit,'("Invalid state for vector")')
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(1125:1999)
write(psb_err_unit,'("computational error. code: ",i0)')err_c
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_)
write(psb_err_unit,&
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_)
write(psb_err_unit,'("Invalid input state for matrix.")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid input state for matrix.")')
case(psb_err_input_no_regen_)
write(psb_err_unit,'("Input state for matrix is not adequate for regeneration.")')
case (2233:2999)
write(psb_err_unit,'("resource error. code: ",i0)')err_c
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)
write(psb_err_unit,&
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_)
write(psb_err_unit,&
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_)
write(psb_err_unit,&
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_)
write(psb_err_unit,'("Case trans = C is not yet implemented.")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Case trans = C is not yet implemented.")')
case(psb_err_transpose_not_n_unsupported_)
write(psb_err_unit,'("Case trans /= N is not yet implemented.")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Case trans /= N is not yet implemented.")')
case(psb_err_only_unit_diag_)
write(psb_err_unit,'("Only unit diagonal so far for triangular matrices. ")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Only unit diagonal so far for triangular matrices. ")')
case(3023)
write(psb_err_unit,'("Cases DESCRA(1:1)=S DESCRA(1:1)=T not yet implemented. ")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Cases DESCRA(1:1)=S DESCRA(1:1)=T not yet implemented. ")')
case(3024)
write(psb_err_unit,'("Cases DESCRA(1:1)=G not yet implemented. ")')
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_)
write(psb_err_unit,'("Case ja /= ix or ia/=iy is not yet implemented.")')
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_)
write(psb_err_unit,'("Case ix /= 1 or iy /= 1 is not yet implemented.")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Case ix /= 1 or iy /= 1 is not yet implemented.")')
case(3050)
write(psb_err_unit,'("Case ix /= iy is not yet implemented.")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Case ix /= iy is not yet implemented.")')
case(3060)
write(psb_err_unit,'("Case ix /= 1 is not yet implemented.")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Case ix /= 1 is not yet implemented.")')
case(3070)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("This operation is only implemented with no overlap.")')
case(3080)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Decompostion type ",i0," not yet supported.")')&
& i_e_d(1)
case(3090)
write(psb_err_unit,'("Insert matrix mode not yet implemented.")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Insert matrix mode not yet implemented.")')
case(3100)
write(psb_err_unit,&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Error on index. Element has not been inserted")')
write(psb_err_unit,&
write(achmsg(3),&
& '("local index is: ",i0," and global index is:",i0)')&
& i_e_d(1:2)
case(psb_err_input_matrix_unassembled_)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("Before you call this routine, you must assembly sparse matrix")')
case(3111)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Before you call this routine, you must initialize the preconditioner")')
case(3112)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Before you call this routine, you must build the preconditioner")')
case(3113:3998)
write(psb_err_unit,'("miscellaneus error. code: ",i0)')err_c
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("miscellaneus error. code: ",i0)')err_c
case(psb_err_missing_aux_lib_)
write(psb_err_unit,&
allocate(achmsg(3))
achmsg(1) = tmpmsg
write(achmsg(2),&
&'("This method requires an external support library.")')
write(psb_err_unit,&
write(achmsg(3),&
&'("Fix configure and rebuild the software.")')
case(psb_err_alloc_dealloc_)
write(psb_err_unit,'("Allocation/deallocation error")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Allocation/deallocation error")')
case(psb_err_internal_error_)
write(psb_err_unit,'("Internal error: ",a)') &
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Internal error: ",a)') &
& trim(a_e_d)
case(psb_err_from_subroutine_)
write(psb_err_unit,'("Error from call to subroutine ",a)')&
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_)
write(psb_err_unit,'("Error from call to a subroutine ")')
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Error from call to a subroutine ")')
case(psb_err_from_subroutine_i_)
write(psb_err_unit,'("Error ",i0," from call to a subroutine ")')&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Error ",i0," from call to a subroutine ")')&
& i_e_d(1)
case(psb_err_from_subroutine_ai_)
write(psb_err_unit,'("Error from call to subroutine ",a," ",i0)')&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Error from call to subroutine ",a," ",i0)')&
& trim(a_e_d),i_e_d(1)
case(psb_err_alloc_request_)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Error on allocation request for ",i0," items of type ",a)')&
& i_e_d(1),trim(a_e_d)
case(4110)
write(psb_err_unit,&
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),&
& '("Error ",i0," from call to an external package in subroutine ",a)')&
&i_e_d(1),trim(a_e_d)
case (psb_err_invalid_istop_)
write(psb_err_unit,'("Invalid ISTOP: ",i0)')i_e_d(1)
case (5002)
write(psb_err_unit,'("Invalid PREC: ",i0)')i_e_d(1)
case (5003)
write(psb_err_unit,'("Invalid PREC: ",a3)')a_e_d(1:3)
case(psb_err_invalid_istop_)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid ISTOP: ",i0)')i_e_d(1)
case(5002)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid PREC: ",i0)')i_e_d(1)
case(5003)
allocate(achmsg(2))
achmsg(1) = tmpmsg
write(achmsg(2),'("Invalid PREC: ",a3)')a_e_d(1:3)
case default
write(psb_err_unit,'("unknown error (",i0,") in subroutine ",a)')&
allocate(achmsg(4))
achmsg(1) = tmpmsg
write(achmsg(2),'("unknown error (",i0,") in subroutine ",a)')&
& err_c,trim(r_name)
write(psb_err_unit,'(5(i0,2x))') i_e_d
write(psb_err_unit,'(a)') trim(a_e_d)
write(achmsg(3),'(5(i0,2x))') i_e_d
write(achmsg(4),'(a)') trim(a_e_d)
end select
end subroutine psb_errmsg
end subroutine psb_ach_errmsg
! prints the error msg associated to a specific error code
subroutine psb_errmsg(err_c, r_name, i_e_d, a_e_d,me)
integer(psb_ipk_), intent(in) :: err_c
character(len=20), intent(in) :: r_name
character(len=40), intent(in) :: a_e_d
integer(psb_ipk_), intent(in) :: i_e_d(5)
integer(psb_mpik_), optional :: me
integer(psb_ipk_) :: i
character(len=psb_max_errmsg_len_), allocatable :: achmsg(:)
call psb_ach_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d,me)
do i=1,size(achmsg)
write(psb_err_unit,'(a)'),trim(achmsg(i))
end do
end subroutine psb_errmsg
end module psb_error_mod

2
test/pargen/runs/ppde.inp
Unescape Escape View File

@ -2,7 +2,7 @@
BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES
BJAC Preconditioner NONE DIAG BJAC
CSR Storage format for matrix A: CSR COO JAD
160 Domain size (acutal system is this**3)
100 Domain size (acutal system is this**3)
2 Stopping criterion
1000 MAXIT
-1 ITRACE

Write Preview
Loading…
Cancel
Save