fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-18 11:52:11 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
960e13a6b4233df29b4bf7a0ce7accadc0945756
psblas3/src/modules/psb_error_mod.f90
T
Salvatore Filippone 960e13a6b4 Initial revision
2005-09-07 09:16:09 +00:00

429 lines
15 KiB
Fortran
Raw Blame History

module psb_error_mod
public psb_errpush, psb_error, psb_get_errstatus,&
& psb_get_errverbosity, psb_set_errverbosity,psb_errcomm, &
& psb_erractionsave, psb_erractionrestore, act_ret, act_abort, &
& no_err, psb_get_erraction, psb_set_erraction
interface psb_error
module procedure psb_serror
module procedure psb_perror
end interface
integer, parameter :: act_ret=0, act_abort=1, no_err=0
private
type psb_errstack_node
integer :: err_code=0 ! the error code
character(len=20) :: routine='' ! the name of the routine generating the error
integer,dimension(5) :: i_err_data=0 ! array of integer data to complete the error msg
! real(kind(1.d0))(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
character(len=20) :: a_err_data='' ! array of character data to complete the error msg
type(psb_errstack_node), pointer :: next ! pointer to the next element in the stack
end type psb_errstack_node
type psb_errstack
type(psb_errstack_node), pointer :: top => null() ! pointer to the top element of the stack
integer :: n_elems=0 ! number of entries in the stack
end type psb_errstack
type(psb_errstack) :: error_stack ! the PSBLAS-2.0 error stack
integer :: error_status=0 ! the error status (maybe not here)
integer :: verbosity_level=1 ! the verbosity level (maybe not here)
integer :: err_action=1
contains
! saves action to support error traceback
! also changes error action to "return"
subroutine psb_erractionsave(err_act)
integer, intent(out) :: err_act
err_act=err_action
err_action=act_ret
end subroutine psb_erractionsave
! return the action to take upon error occurrence
subroutine psb_get_erraction(err_act)
integer, 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, intent(in) :: err_act
err_action=err_act
end subroutine psb_set_erraction
! restores error action previously saved with psb_erractionsave
subroutine psb_erractionrestore(err_act)
integer, intent(in) :: err_act
err_action=err_act
end subroutine psb_erractionrestore
! checks wether an error has occurred on one of the porecesses in the execution pool
subroutine psb_errcomm(icontxt, err)
integer, intent(in) :: icontxt
integer, intent(inout):: err
integer :: temp(2)
integer, parameter :: ione=1
call igamx2d(icontxt, 'A', ' ', ione, ione, err, ione,&
&temp ,temp,-ione ,-ione,-ione)
end subroutine psb_errcomm
! sets verbosity of the error message
subroutine psb_set_errverbosity(v)
integer, intent(in) :: v
verbosity_level=v
end subroutine psb_set_errverbosity
! returns verbosity of the error message
subroutine psb_get_errverbosity(v)
integer, intent(out) :: v
v=verbosity_level
end subroutine psb_get_errverbosity
! checks the status of the error condition
subroutine psb_get_errstatus(s)
integer, intent(out) :: s
s=error_status
end subroutine psb_get_errstatus
! pushes an error on the error stack
subroutine psb_errpush(err_c, r_name, i_err, a_err)
integer, intent(in) :: err_c
character(len=20), intent(in) :: r_name
character(len=20), optional :: a_err
integer, optional :: i_err(5)
type(psb_errstack_node), pointer :: new_node
allocate(new_node)
new_node%err_code = err_c
new_node%routine = r_name
if(present(i_err)) new_node%i_err_data = i_err
if(present(a_err)) new_node%a_err_data = a_err
new_node%next => error_stack%top
error_stack%top => new_node
error_stack%n_elems = error_stack%n_elems+1
if(error_status.eq.0) error_status=1
nullify(new_node)
end subroutine psb_errpush
! pops an error from the error stack
subroutine psb_errpop(err_c, r_name, i_e_d, a_e_d)
integer, intent(out) :: err_c
character(len=20), intent(out) :: r_name, a_e_d
integer, intent(out) :: i_e_d(5)
type(psb_errstack_node), pointer :: old_node
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
old_node => error_stack%top
error_stack%top => old_node%next
error_stack%n_elems = error_stack%n_elems - 1
if(error_stack%n_elems.eq.0) error_status=0
deallocate(old_node)
end subroutine psb_errpop
! handles the occurence of an error in a parallel routine
subroutine psb_perror(icontxt)
integer, intent(in) :: icontxt
integer :: err_c
character(len=20) :: r_name, a_e_d
integer :: i_e_d(5)
integer :: nprow, npcol, me, mypcol, temp(2)
integer, parameter :: ione=1, izero=0
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if(error_status.gt.0) then
if(verbosity_level.gt.1) then
do while (error_stack%n_elems.gt.izero)
write(0,'(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,me)
! write(0,'(50("="))')
end do
call blacs_abort(icontxt,-1)
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,me)
do while (error_stack%n_elems.gt.0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
end do
call blacs_abort(icontxt,-1)
end if
end if
if(error_status.gt.izero) then
call blacs_abort(icontxt,err_c)
end if
end subroutine psb_perror
! handles the occurence of an error in a serial routine
subroutine psb_serror()
integer :: err_c
character(len=20) :: r_name, a_e_d
integer :: i_e_d(5)
integer :: nprow, npcol, me, mypcol, temp(2)
integer, parameter :: ione=1, izero=0
if(error_status.gt.0) then
if(verbosity_level.gt.1) then
do while (error_stack%n_elems.gt.izero)
write(0,'(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(0,'(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 (error_stack%n_elems.gt.0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
end do
end if
end if
end subroutine psb_serror
! 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, intent(in) :: err_c
character(len=20), intent(in) :: r_name, a_e_d
integer, intent(in) :: i_e_d(5)
integer, optional :: me
if(present(me)) then
write(0,'("Process: ",i0,". PSBLAS Error (",i0,") in subroutine: ",a20)')me,err_c,r_name
else
write(0,'("PSBLAS Error (",i0,") in subroutine: ",a20)')err_c,r_name
end if
select case (err_c)
case(:0)
write (0,'("error on calling sperror. err_c must be greater than 0")')
case(2)
write (0,'("pivot too small")')
case(3)
write (0,'("Invalid number of ovr:",i0)')i_e_d(1)
case(5)
write (0,'("Invalid input")')
case(10)
write (0,'("input argument n. ",i0," cannot be less than 0")')i_e_d(1)
write (0,'("current value is ",i0)')i_e_d(2)
case(20)
write (0,'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1)
write (0,'("current value is ",i0)')i_e_d(2)
case(30)
write (0,'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write (0,'("current value is ",i0)')i_e_d(2)
case(35)
write (0,'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1)
write (0,'("Current value is ",i0)')i_e_d(2)
case(40)
write (0,'("input argument n. ",i0," has an invalid value")')i_e_d(1)
write (0,'("current value is ",a)')a_e_d(2:2)
case(50)
write (0,'("input argument n. ",i0," must be equal or greater than input argument n. ",i0)') i_e_d(1), i_e_d(2)
write (0,'("current values are ",i0," < ",i0)') i_e_d(3),i_e_d(4)
case(60)
write (0,'("input argument n. ",i0," must be equal or greater than ",i0)')i_e_d(1),i_e_d(2)
write (0,'("current value is ",i0," < ",i0)')i_e_d(3), i_e_d(2)
case(70)
write (0,'("input argument n. ",i0," in entry # ",i0," has an invalid value")')i_e_d(1:2)
write (0,'("current value is ",a)')a_e_d
case(71)
write (0,'("Impossible error in ASB: nrow>ncol,")')
write (0,'("Actual values are ",i0," > ",i0)')i_e_d(1:2)
! ... csr format error ...
case(80)
write (0,'("input argument ia2(1) is less than 0")')
write (0,'("current value is ",i0)')i_e_d(1)
! ... csr format error ...
case(90)
write (0,'("indices in ia2 array are not in increasing order")')
case(91)
write (0,'("indices in ia1 array are not in increasing order")')
! ... csr format error ...
case(100)
write (0,'("indices in ia1 array are not within problem dimension")')
write (0,'("problem dimension is ",i0)')i_e_d(1)
case(110)
write (0,'("invalid combination of input arguments")')
case(115)
write (0,'("Invalid process identifier in input array argument n. ",i0,".")')i_e_d(1)
write (0,'("Current value is ",i0)')i_e_d(2)
case(120)
write (0,'("input argument n. ",i0," must be greater than input argument n. ",i0)')i_e_d(1:2)
write (0,'("current values are ",i0," < ",i0)') i_e_d(3:4)
! ... coo format error ...
case(130)
write (0,'("there are duplicated elements in coo format")')
write (0,'("please set repflag flag to 2 or 3")')
case(134)
write (0,'("Invalid input format ",a3)')a_e_d(1:3)
case(135)
write (0,'("Format ",a3," not yet supported here")')a_e_d(1:3)
case(136)
write (0,'("Format ",a3," is unknown")')a_e_d(1:3)
case(140)
write (0,'("indices in input array are not within problem dimension ",2(i0,2x))')i_e_d(1:2)
case(150)
write (0,'("indices in input array are not belonging to the calling process ",i0)')i_e_d(1)
case(290)
write (0,'("Is not possible to call this routine without calling before psdalloc on the same matrix")')
case(295)
write (0,'("Is not possible to call this routine without calling before psdspalloc on the same matrix")')
case(300)
write (0,'("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 (0,'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5)
case(400)
write (0,'("MPI error:",i0)')i_e_d(1)
case(550)
write (0,'("Parameter n. ",i0," must be equal on all BLACS processes. ",i0)')i_e_d(1)
case(570)
write (0,'("partition function passed as input argument n. ",i0," returns number of processes")')i_e_d(1)
write (0,'("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')i_e_d(4)
write (0,'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3)
case(575)
write (0,'("partition function passed as input argument n. ",i0," returns number of processes")')i_e_d(1)
write (0,'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')i_e_d(3),i_e_d(2)
case(580)
write (0,'("partition function passed as input argument n. ",i0," returns wrong processes identifier")')i_e_d(1)
write (0,'("on global point ",i0,". Current value returned is : ",i0)')i_e_d(3),i_e_d(2)
case(600)
write (0,'("Sparse Matrix and decsriptors are in an invalid state for this subroutine call: ",i0)')i_e_d(1)
case (1122)
write (0,'("Invalid state for DESC_A")')
case (1123)
write (0,'("Invalid combined state for A and DESC_A")')
case(1124:1999)
write (0,'("computational error. code: ",i0)')err_c
case(2010)
write (0,'("BLACS error. Number of processes=-1")')
case(2025)
write (0,'("Cannot allocate ",i0," bytes")')i_e_d(1)
case(2030)
write (0,'("BLACS ERROR: Number of grid columns must be equal to 1\nCurrent value is ",i4," != 1.")')i_e_d(1)
case(2231)
write (0,'("Invalid input state for matrix.")')
case(2232)
write (0,'("Input state for matrix is not adequate for regeneration.")')
case (2233:2999)
write(0,'("resource error. code: ",i0)')err_c
case(3000:3009)
write (0,'("sparse matrix representation ",a3," not yet implemented")')a_e_d(1:3)
case(3010)
write (0,'("Case lld not equal matrix_data[N_COL_] is not yet implemented.")')
case(3015)
write (0,'("transpose option for sparse matrix representation ",a3," not implemented")')a_e_d(1:3)
case(3020)
write (0,'("Case trans = C is not yet implemented.")')
case(3021)
write (0,'("Case trans /= N is not yet implemented.")')
case(3022)
write (0,'("Only unit diagonal so far for triangular matrices. ")')
case(3023)
write (0,'("Cases DESCRA(1:1)=S DESCRA(1:1)=T not yet implemented. ")')
case(3024)
write (0,'("Cases DESCRA(1:1)=G not yet implemented. ")')
case(3030)
write (0,'("Case ja/=ix or ia/=iy is not yet implemented.")')
case(3040)
write (0,'("Case ix /= 1 or iy /= 1 is not yet implemented.")')
case(3050)
write (0,'("Case ix /= iy is not yet implemented.")')
case(3060)
write (0,'("Case ix /= 1 is not yet implemented.")')
case(3070)
write (0,'("This operation is only implemented with no overlap.")')
case(3080)
write (0,'("Decompostion type ",i0," not yet supported.")')i_e_d(1)
case(3090)
write (0,'("Insert matrix mode not yet implemented.")')
case(3100)
write (0,'("Error on index. Element has not been inserted")')
write (0,'("local index is: ",i0," and global index is:",i0)')i_e_d(1:2)
case(3110)
write (0,'("Before you call this routine, you must assembly sparse matrix")')
case(3111:3999)
write(0,'("miscellaneus error. code: ",i0)')err_c
case(4000)
write(0,'("Allocation/deallocation error")')
case(4010)
write (0,'("Error from call to subroutine ",a)')a_e_d
case(4011)
write (0,'("Error from call to a subroutine ")')
case(4012)
write (0,'("Error ",i0," from call to a subroutine ")')i_e_d(1)
case (5001)
write (0,'("Invalid ISTOP: ",i0)')i_e_d(1)
case (5002)
write (0,'("Invalid PREC: ",i0)')i_e_d(1)
case (5003)
write (0,'("Invalid PREC: ",a3)')a_e_d(1:3)
case default
write(0,'("unknown error (",i0,") in subroutine ",a)')err_c,r_name
write(0,'(5(i0,2x))') i_e_d
write(0,'(a)') a_e_d
end select
end subroutine psb_errmsg
end module psb_error_mod
Reference in New Issue View Git Blame Copy Permalink