From aaf5383aa41e7cd7e3db6a1493d8fda953b9817d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 17 Apr 2018 16:09:58 +0100 Subject: [PATCH] New error handling interface for i_err and friends. --- base/modules/auxil/psb_c_realloc_mod.F90 | 88 +++++----- base/modules/auxil/psb_d_realloc_mod.F90 | 88 +++++----- base/modules/auxil/psb_e_realloc_mod.F90 | 88 +++++----- base/modules/auxil/psb_m_realloc_mod.F90 | 88 +++++----- base/modules/auxil/psb_s_realloc_mod.F90 | 88 +++++----- base/modules/auxil/psb_z_realloc_mod.F90 | 88 +++++----- base/modules/error.f90 | 2 +- base/modules/psb_error_impl.F90 | 30 ++-- base/modules/psb_error_mod.F90 | 204 ++++++++++++----------- base/serial/impl/psb_c_base_mat_impl.F90 | 160 ++++++------------ base/serial/impl/psb_c_coo_impl.f90 | 164 ++++++------------ base/serial/impl/psb_d_base_mat_impl.F90 | 160 ++++++------------ base/serial/impl/psb_d_coo_impl.f90 | 164 ++++++------------ base/serial/impl/psb_s_base_mat_impl.F90 | 160 ++++++------------ base/serial/impl/psb_s_coo_impl.f90 | 164 ++++++------------ base/serial/impl/psb_z_base_mat_impl.F90 | 160 ++++++------------ base/serial/impl/psb_z_coo_impl.f90 | 164 ++++++------------ base/tools/psb_cdals.f90 | 39 ++--- 18 files changed, 822 insertions(+), 1277 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index f95455919..be460dc64 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -111,8 +111,8 @@ Contains endif if ((len<0)) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -124,8 +124,8 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -136,8 +136,8 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') goto 9999 end if endif @@ -188,14 +188,14 @@ Contains if (len1 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') goto 9999 end if @@ -210,8 +210,8 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -224,8 +224,8 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_spk_)') goto 9999 end if endif @@ -275,8 +275,8 @@ Contains if ((len<0)) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -289,8 +289,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -302,8 +302,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if endif @@ -355,15 +355,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if @@ -379,8 +379,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -394,8 +394,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if endif @@ -450,15 +450,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if @@ -474,8 +474,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -489,8 +489,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='complex(psb_spk_)') goto 9999 end if endif @@ -545,15 +545,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if @@ -569,8 +569,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -584,8 +584,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') goto 9999 end if endif diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index 1ddadad15..528065064 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -111,8 +111,8 @@ Contains endif if ((len<0)) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -124,8 +124,8 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -136,8 +136,8 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') goto 9999 end if endif @@ -188,14 +188,14 @@ Contains if (len1 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') goto 9999 end if @@ -210,8 +210,8 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -224,8 +224,8 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_dpk_)') goto 9999 end if endif @@ -275,8 +275,8 @@ Contains if ((len<0)) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -289,8 +289,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -302,8 +302,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if endif @@ -355,15 +355,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if @@ -379,8 +379,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -394,8 +394,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if endif @@ -450,15 +450,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if @@ -474,8 +474,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -489,8 +489,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='real(psb_dpk_)') goto 9999 end if endif @@ -545,15 +545,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if @@ -569,8 +569,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -584,8 +584,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') goto 9999 end if endif diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 7ef08064a..11e87486e 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -111,8 +111,8 @@ Contains endif if ((len<0)) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -124,8 +124,8 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -136,8 +136,8 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') goto 9999 end if endif @@ -188,14 +188,14 @@ Contains if (len1 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') goto 9999 end if if (len2 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') goto 9999 end if @@ -210,8 +210,8 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_epk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -224,8 +224,8 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_epk_)') goto 9999 end if endif @@ -275,8 +275,8 @@ Contains if ((len<0)) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -289,8 +289,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -302,8 +302,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if endif @@ -355,15 +355,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if @@ -379,8 +379,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -394,8 +394,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if endif @@ -450,15 +450,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if @@ -474,8 +474,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -489,8 +489,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='integer(psb_epk_)') goto 9999 end if endif @@ -545,15 +545,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if @@ -569,8 +569,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -584,8 +584,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') goto 9999 end if endif diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index b7e993e80..29e533adf 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -111,8 +111,8 @@ Contains endif if ((len<0)) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -124,8 +124,8 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -136,8 +136,8 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') goto 9999 end if endif @@ -188,14 +188,14 @@ Contains if (len1 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') goto 9999 end if if (len2 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') goto 9999 end if @@ -210,8 +210,8 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_mpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -224,8 +224,8 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_mpk_)') goto 9999 end if endif @@ -275,8 +275,8 @@ Contains if ((len<0)) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -289,8 +289,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -302,8 +302,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if endif @@ -355,15 +355,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if @@ -379,8 +379,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -394,8 +394,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if endif @@ -450,15 +450,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if @@ -474,8 +474,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -489,8 +489,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='integer(psb_mpk_)') goto 9999 end if endif @@ -545,15 +545,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if @@ -569,8 +569,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -584,8 +584,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') goto 9999 end if endif diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 4a482d2d9..f565f498b 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -111,8 +111,8 @@ Contains endif if ((len<0)) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_spk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -124,8 +124,8 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_spk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -136,8 +136,8 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_spk_)') goto 9999 end if endif @@ -188,14 +188,14 @@ Contains if (len1 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='real(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='real(psb_spk_)') goto 9999 end if @@ -210,8 +210,8 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -224,8 +224,8 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_spk_)') goto 9999 end if endif @@ -275,8 +275,8 @@ Contains if ((len<0)) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -289,8 +289,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -302,8 +302,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if endif @@ -355,15 +355,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if @@ -379,8 +379,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -394,8 +394,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if endif @@ -450,15 +450,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if @@ -474,8 +474,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -489,8 +489,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='real(psb_spk_)') goto 9999 end if endif @@ -545,15 +545,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if @@ -569,8 +569,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -584,8 +584,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') goto 9999 end if endif diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index cdc401d4b..2d2403658 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -111,8 +111,8 @@ Contains endif if ((len<0)) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -124,8 +124,8 @@ Contains Allocate(tmp(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -136,8 +136,8 @@ Contains Allocate(rrax(lb_:ub_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') goto 9999 end if endif @@ -188,14 +188,14 @@ Contains if (len1 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -210,8 +210,8 @@ Contains Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -224,8 +224,8 @@ Contains Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) if (info /= psb_success_) then err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_dpk_)') goto 9999 end if endif @@ -275,8 +275,8 @@ Contains if ((len<0)) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if ub_ = lb_ + len-1 @@ -289,8 +289,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) @@ -302,8 +302,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if endif @@ -355,15 +355,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -379,8 +379,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -394,8 +394,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if endif @@ -450,15 +450,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -474,8 +474,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -489,8 +489,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='complex(psb_dpk_)') goto 9999 end if endif @@ -545,15 +545,15 @@ Contains if (len1 < 0) then err=4025 iplen = len1 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if if (len2 < 0) then err=4025 iplen = len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if @@ -569,8 +569,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & @@ -584,8 +584,8 @@ Contains if (info /= psb_success_) then err=4025 iplen = len1*len2 - call psb_errpush(err,name, & - & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') goto 9999 end if endif diff --git a/base/modules/error.f90 b/base/modules/error.f90 index fe8fea188..894118360 100644 --- a/base/modules/error.f90 +++ b/base/modules/error.f90 @@ -52,7 +52,7 @@ subroutine FCpsb_errpush(err_c, r_name, i_err) character(len=20), intent(in) :: r_name integer(psb_ipk_) :: i_err(5) - call psb_errpush(err_c, r_name, i_err) + call psb_errpush(err_c, r_name, i_err=i_err) end subroutine FCpsb_errpush diff --git a/base/modules/psb_error_impl.F90 b/base/modules/psb_error_impl.F90 index eb179067c..bdb289ec0 100644 --- a/base/modules/psb_error_impl.F90 +++ b/base/modules/psb_error_impl.F90 @@ -2,7 +2,7 @@ subroutine psb_errcomm(ictxt, err) use psb_error_mod, psb_protect_name => psb_errcomm use psb_penv_mod - integer(psb_mpk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(inout):: err if (psb_get_global_checks()) call psb_amx(ictxt, err) @@ -45,7 +45,7 @@ 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_mpk_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: ictxt call psb_error(ictxt, abrt=.false.) @@ -68,24 +68,24 @@ subroutine psb_serror() 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_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, i_e_d, a_e_d) - call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d) + 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, i_e_d, a_e_d) - call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d) + 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, i_e_d, a_e_d) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) end do end if end if @@ -103,13 +103,13 @@ subroutine psb_perror(ictxt,abrt) use psb_error_mod use psb_penv_mod implicit none - integer(psb_mpk_), intent(in) :: ictxt + integer(psb_ipk_), 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_epk_) :: e_e_d(5) integer(psb_mpk_) :: iam, np logical :: abrt_ @@ -122,8 +122,8 @@ subroutine psb_perror(ictxt,abrt) 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(psb_err_unit,err_c, r_name, i_e_d, a_e_d,iam) + 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) @@ -134,10 +134,10 @@ subroutine psb_perror(ictxt,abrt) else - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d,iam) + 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, i_e_d, a_e_d) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) end do #if defined(HAVE_FLUSH_STMT) flush(psb_err_unit) diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index 9d30a9bbb..496a77d73 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -82,8 +82,8 @@ module psb_error_mod subroutine psb_serror() end subroutine psb_serror subroutine psb_perror(ictxt,abrt) - import :: psb_mpk_ - integer(psb_mpk_), intent(in) :: ictxt + import :: psb_ipk_ + integer(psb_ipk_), intent(in) :: ictxt logical, intent(in), optional :: abrt end subroutine psb_perror end interface @@ -91,8 +91,8 @@ module psb_error_mod interface psb_error_print_stack subroutine psb_par_error_print_stack(ictxt) - import :: psb_ipk_,psb_mpk_ - integer(psb_mpk_), intent(in) :: ictxt + import :: psb_ipk_ + integer(psb_ipk_), intent(in) :: ictxt end subroutine psb_par_error_print_stack subroutine psb_ser_error_print_stack() end subroutine psb_ser_error_print_stack @@ -100,8 +100,8 @@ module psb_error_mod interface psb_errcomm subroutine psb_errcomm(ictxt, err) - import :: psb_mpk_, psb_ipk_ - integer(psb_mpk_), intent(in) :: ictxt + import :: psb_ipk_ + integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(inout):: err end subroutine psb_errcomm end interface psb_errcomm @@ -114,15 +114,6 @@ module psb_error_mod module procedure psb_errmsg, psb_ach_errmsg end interface -#if defined(LONG_INTEGERS) - interface psb_error - module procedure psb_perror_ipk - end interface psb_error - interface psb_errcomm - module procedure psb_errcomm_ipk - end interface psb_errcomm -#endif - private @@ -133,7 +124,7 @@ module psb_error_mod ! the name of the routine generating the error character(len=20) :: routine='' ! array of integer data to complete the error msg - integer(psb_ipk_),dimension(5) :: i_err_data=0 + 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 @@ -352,22 +343,37 @@ contains end function psb_errstatus_ok ! pushes an error on the error stack - subroutine psb_stackpush(err_c, r_name, i_err, a_err) - + 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(5) + 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(i_err)) then - new_node%i_err_data = i_err + 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 @@ -380,34 +386,40 @@ contains end subroutine psb_stackpush ! pushes an error on the error stack - subroutine psb_errpush(err_c, r_name, i_err, a_err) + 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(5) + 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 call psb_set_errstatus(psb_err_fatal_) - call psb_stackpush(err_c, r_name, i_err, a_err) + 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, i_err, a_err) + 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 + integer(psb_ipk_), intent(in) :: err_c character(len=*), intent(in) :: r_name character(len=*), optional :: a_err - integer(psb_ipk_), optional :: i_err(5) + 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 if (.not.psb_errstatus_fatal())& & call psb_set_errstatus( psb_err_warning_) - call psb_stackpush(err_c, r_name, i_err, a_err) + call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) end subroutine psb_warning_push @@ -417,16 +429,16 @@ contains 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_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 - i_e_d = error_stack%top%i_err_data + 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, i_e_d, a_e_d) + 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 @@ -438,19 +450,19 @@ contains 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) + 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_ipk_), intent(out) :: i_e_d(5) + 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 - i_e_d = error_stack%top%i_err_data + e_e_d = error_stack%top%e_err_data a_e_d = error_stack%top%a_err_data old_node => error_stack%top @@ -469,23 +481,23 @@ contains 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_epk_) :: e_e_d(5) do while (psb_get_numerr() > 0) - call psb_errpop(err_c, r_name, i_e_d, a_e_d) + 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, i_e_d, a_e_d,me) + 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_ipk_), intent(in) :: i_e_d(5) + 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 @@ -511,12 +523,12 @@ contains case(psb_err_pivot_too_small_) allocate(achmsg(2)) achmsg(1) = tmpmsg - write(achmsg(2),'("pivot too small: ",i0,1x,a)')i_e_d(1),trim(a_e_d) + 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)')i_e_d(1) + write(achmsg(2),'("Invalid number of ovr:",i0)')e_e_d(1) case(psb_err_invalid_input_) allocate(achmsg(2)) @@ -526,37 +538,37 @@ contains case(psb_err_iarg_neg_) 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) + 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")')i_e_d(1) - write(achmsg(3),'("current value is ",i0)')i_e_d(2) + 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")')i_e_d(1) - write(achmsg(3),'("current value is ",i0)')i_e_d(2) + 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.")')i_e_d(1) - write(achmsg(3),'("Current value is ",i0)')i_e_d(2) + 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.")')i_e_d(1) - write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3) + 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")')i_e_d(1) + 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_) @@ -564,37 +576,37 @@ contains 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) + & e_e_d(1), e_e_d(3) write(achmsg(3),'("current values are ",i0," < ",i0)')& - & i_e_d(2),i_e_d(5) + & 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)')& - & i_e_d(1),i_e_d(2) + & e_e_d(1),e_e_d(2) write(achmsg(3),'("current value is ",i0," < ",i0)')& - & i_e_d(3), i_e_d(2) + & 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")')& - & i_e_d(1:2) + & 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)')i_e_d(1:2) + 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)')i_e_d(1) + write(achmsg(3),'("current value is ",i0)')e_e_d(1) ! ... csr format error ... case(psb_err_ia2_not_increasing_) @@ -612,7 +624,7 @@ contains 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) + write(achmsg(3),'("problem dimension is ",i0)')e_e_d(1) case(psb_err_invalid_args_combination_) allocate(achmsg(2)) @@ -623,15 +635,15 @@ contains allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid process identifier in input array argument n. ",i0,".")')& - & i_e_d(1) - write(achmsg(3),'("Current value is ",i0)')i_e_d(2) + & 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)')& - & i_e_d(1:2) - write(achmsg(3),'("current values are ",i0," < ",i0)') i_e_d(3:4) + & 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)) @@ -669,14 +681,14 @@ contains achmsg(1) = tmpmsg write(achmsg(2),& &'("indices in input array are not within problem dimension ",2(i0,2x))')& - &i_e_d(1:2) + &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)')& - & i_e_d(1) + & e_e_d(1) case(psb_err_forgot_geall_) allocate(achmsg(2)) @@ -702,26 +714,26 @@ contains 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(achmsg(3),'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5) + & 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)')i_e_d(1) + 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)')i_e_d(1) + &'("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)')& - & i_e_d(1),i_e_d(3),i_e_d(4),i_e_d(2) + & 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)) @@ -733,31 +745,31 @@ contains achmsg(1) = tmpmsg write(achmsg(2),& &'("partition function passed as input argument n. ",i0," returns number of processes")')& - &i_e_d(1) + &e_e_d(1) write(achmsg(3),& & '("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')& - &i_e_d(4) - write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3) + &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")')& - &i_e_d(1) + &e_e_d(1) write(achmsg(3),& &'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')& - &i_e_d(3),i_e_d(2) + &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")')& - & i_e_d(1) + & e_e_d(1) write(achmsg(3),& & '("on global point ",i0,". Current value returned is : ",i0)')& - & i_e_d(3),i_e_d(2) + & e_e_d(3),e_e_d(2) case(psb_err_no_optional_arg_) allocate(achmsg(2)) @@ -789,11 +801,11 @@ contains allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," has a dynamic type not allowed here.")')& - & i_e_d(1) + & e_e_d(1) 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) + & e_e_d(1), e_e_d(2) case(psb_err_invalid_mat_state_) allocate(achmsg(2)) @@ -927,7 +939,7 @@ contains achmsg(1) = tmpmsg write(achmsg(2),& & '("Decompostion type ",i0," not yet supported.")')& - & i_e_d(1) + & e_e_d(1) case(3090) allocate(achmsg(2)) @@ -941,7 +953,7 @@ contains & '("Error on index. Element has not been inserted")') write(achmsg(3),& & '("local index is: ",i0," and global index is:",i0)')& - & i_e_d(1:2) + & e_e_d(1:2) case(psb_err_input_matrix_unassembled_) allocate(achmsg(2)) @@ -1000,37 +1012,37 @@ contains allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Error ",i0," from call to a subroutine ")')& - & i_e_d(1) + & 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),i_e_d(1) + & 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)')& - & i_e_d(1),trim(a_e_d) + & 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)')& - &i_e_d(1),trim(a_e_d) + &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)')i_e_d(1) + write(achmsg(2),'("Invalid ISTOP: ",i0)')e_e_d(1) case(5002) allocate(achmsg(2)) achmsg(1) = tmpmsg - write(achmsg(2),'("Invalid PREC: ",i0)')i_e_d(1) + write(achmsg(2),'("Invalid PREC: ",i0)')e_e_d(1) case(5003) allocate(achmsg(2)) @@ -1042,7 +1054,7 @@ contains achmsg(1) = tmpmsg write(achmsg(2),'("unknown error (",i0,") in subroutine ",a)')& & err_c,trim(r_name) - write(achmsg(3),'(5(i0,2x))') i_e_d + write(achmsg(3),'(5(i0,2x))') e_e_d write(achmsg(4),'(a)') trim(a_e_d) end select @@ -1051,18 +1063,18 @@ contains ! prints the error msg associated to a specific error code - subroutine psb_errmsg(iunit, err_c, r_name, i_e_d, a_e_d,me) + 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_ipk_), intent(in) :: i_e_d(5) + 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, i_e_d, a_e_d,me) + 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)) diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 954e21436..56a93fa6d 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_c_base_cp_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_c_base_cp_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_c_base_cp_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_c_base_cp_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_c_base_mv_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_c_base_mv_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_c_base_mv_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_c_base_mv_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -462,10 +451,9 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +542,7 @@ subroutine psb_c_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +636,6 @@ subroutine psb_c_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -800,7 +786,6 @@ subroutine psb_c_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -998,8 +983,7 @@ subroutine psb_c_base_mold(a,b,info) class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1024,7 +1008,6 @@ subroutine psb_c_base_transp_2mat(a,b) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transp' call psb_erractionsave(err_act) @@ -1039,8 +1022,7 @@ subroutine psb_c_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1062,7 +1044,6 @@ subroutine psb_c_base_transc_2mat(a,b) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transc' call psb_erractionsave(err_act) @@ -1077,8 +1058,7 @@ subroutine psb_c_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1099,7 +1079,6 @@ subroutine psb_c_base_transp_1mat(a) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transp' call psb_erractionsave(err_act) @@ -1131,7 +1110,6 @@ subroutine psb_c_base_transc_1mat(a) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transc' call psb_erractionsave(err_act) @@ -1180,8 +1158,7 @@ subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. @@ -1207,8 +1184,7 @@ subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_csmv' logical, parameter :: debug=.false. @@ -1235,8 +1211,7 @@ subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_inner_cssm' logical, parameter :: debug=.false. @@ -1262,8 +1237,7 @@ subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_inner_cssv' logical, parameter :: debug=.false. @@ -1294,7 +1268,6 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_spk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_cssm' logical, parameter :: debug=.false. @@ -1311,14 +1284,12 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1338,8 +1309,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1362,8 +1332,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1387,8 +1356,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1402,16 +1370,13 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_c_base_cssm @@ -1428,9 +1393,8 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_spk_), intent(in), optional :: d(:) complex(psb_spk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='c_cssm' logical, parameter :: debug=.false. @@ -1447,14 +1411,12 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1474,8 +1436,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1493,8 +1454,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1518,8 +1478,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1578,8 +1537,7 @@ subroutine psb_c_base_scals(d,a,info) complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_scals' logical, parameter :: debug=.false. @@ -1605,8 +1563,7 @@ subroutine psb_c_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_scal' logical, parameter :: debug=.false. @@ -1632,8 +1589,7 @@ function psb_c_base_maxval(a) result(res) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1660,8 +1616,7 @@ function psb_c_base_csnmi(a) result(res) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_spk_), allocatable :: vt(:) @@ -1699,8 +1654,7 @@ function psb_c_base_csnm1(a) result(res) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_spk_), allocatable :: vt(:) @@ -1735,8 +1689,7 @@ subroutine psb_c_base_rowsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1758,8 +1711,7 @@ subroutine psb_c_base_arwsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1781,8 +1733,7 @@ subroutine psb_c_base_colsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1804,8 +1755,7 @@ subroutine psb_c_base_aclsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1831,8 +1781,7 @@ subroutine psb_c_base_get_diag(a,d,info) complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1898,9 +1847,8 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_spk_), allocatable :: tmp(:) class(psb_c_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='c_cssm' logical, parameter :: debug=.false. @@ -1917,14 +1865,12 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1947,8 +1893,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1966,8 +1911,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1993,8 +1937,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2032,8 +1975,7 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_inner_vect_sv' logical, parameter :: debug=.false. diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index dab1934c4..5a79b7e76 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -39,8 +39,7 @@ subroutine psb_c_coo_get_diag(a,d,info) complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +50,7 @@ subroutine psb_c_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +86,7 @@ subroutine psb_c_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +111,7 @@ subroutine psb_c_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +123,7 @@ subroutine psb_c_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +153,7 @@ subroutine psb_c_coo_scals(d,a,info) complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,8 +187,7 @@ subroutine psb_c_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='c_coo_reallocate_nz' logical, parameter :: debug=.false. @@ -226,8 +219,7 @@ subroutine psb_c_coo_mold(a,b,info) class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -261,8 +253,7 @@ subroutine psb_c_coo_reinit(a,clear) class(psb_c_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -308,8 +299,7 @@ subroutine psb_c_coo_trim(a) use psb_error_mod implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -365,8 +355,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -374,14 +363,12 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -391,8 +378,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -433,13 +419,12 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='complex' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' @@ -562,8 +547,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) complex(psb_spk_) :: acc complex(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. @@ -593,14 +577,12 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -918,8 +900,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) complex(psb_spk_) :: acc complex(psb_spk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_cssv_impl' logical, parameter :: debug=.false. @@ -943,14 +924,12 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1262,8 +1241,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc complex(psb_spk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1297,16 +1275,15 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == czero) then @@ -1450,15 +1427,14 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc complex(psb_spk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1494,14 +1470,12 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1654,8 +1628,7 @@ function psb_c_coo_maxval(a) result(res) class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='c_coo_maxval' logical, parameter :: debug=.false. @@ -1686,7 +1659,6 @@ function psb_c_coo_csnmi(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_coo_csnmi' logical, parameter :: debug=.false. @@ -1748,7 +1720,6 @@ function psb_c_coo_csnm1(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_coo_csnm1' logical, parameter :: debug=.false. @@ -1787,7 +1758,6 @@ subroutine psb_c_coo_rowsum(d,a) complex(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1795,10 +1765,10 @@ subroutine psb_c_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1836,7 +1806,6 @@ subroutine psb_c_coo_arwsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1846,8 +1815,7 @@ subroutine psb_c_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1884,7 +1852,6 @@ subroutine psb_c_coo_colsum(d,a) complex(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1894,8 +1861,7 @@ subroutine psb_c_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1933,7 +1899,6 @@ subroutine psb_c_coo_aclsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1943,11 +1908,11 @@ subroutine psb_c_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = sone else @@ -2006,8 +1971,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2282,7 +2246,6 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2556,12 +2519,11 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2570,27 +2532,23 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2931,8 +2889,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2974,8 +2931,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3021,8 +2977,7 @@ subroutine psb_c_cp_coo_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3054,8 +3009,7 @@ subroutine psb_c_cp_coo_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3089,8 +3043,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3132,8 +3085,7 @@ subroutine psb_c_mv_coo_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3177,8 +3129,7 @@ subroutine psb_c_mv_coo_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3210,8 +3161,7 @@ subroutine psb_c_mv_coo_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3245,8 +3195,7 @@ subroutine psb_c_coo_cp_from(a,b) type(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3276,8 +3225,7 @@ subroutine psb_c_coo_mv_from(a,b) type(psb_c_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3314,7 +3262,6 @@ subroutine psb_c_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3379,7 +3326,6 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index 41270028d..e2141c803 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_d_base_cp_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_d_base_cp_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_d_base_cp_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_d_base_cp_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_d_base_mv_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_d_base_mv_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_d_base_mv_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_d_base_mv_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -462,10 +451,9 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +542,7 @@ subroutine psb_d_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +636,6 @@ subroutine psb_d_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -800,7 +786,6 @@ subroutine psb_d_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -998,8 +983,7 @@ subroutine psb_d_base_mold(a,b,info) class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1024,7 +1008,6 @@ subroutine psb_d_base_transp_2mat(a,b) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transp' call psb_erractionsave(err_act) @@ -1039,8 +1022,7 @@ subroutine psb_d_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1062,7 +1044,6 @@ subroutine psb_d_base_transc_2mat(a,b) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transc' call psb_erractionsave(err_act) @@ -1077,8 +1058,7 @@ subroutine psb_d_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1099,7 +1079,6 @@ subroutine psb_d_base_transp_1mat(a) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transp' call psb_erractionsave(err_act) @@ -1131,7 +1110,6 @@ subroutine psb_d_base_transc_1mat(a) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transc' call psb_erractionsave(err_act) @@ -1180,8 +1158,7 @@ subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_csmm' logical, parameter :: debug=.false. @@ -1207,8 +1184,7 @@ subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_csmv' logical, parameter :: debug=.false. @@ -1235,8 +1211,7 @@ subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_inner_cssm' logical, parameter :: debug=.false. @@ -1262,8 +1237,7 @@ subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_inner_cssv' logical, parameter :: debug=.false. @@ -1294,7 +1268,6 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) real(psb_dpk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_cssm' logical, parameter :: debug=.false. @@ -1311,14 +1284,12 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1338,8 +1309,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1362,8 +1332,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1387,8 +1356,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1402,16 +1370,13 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_d_base_cssm @@ -1428,9 +1393,8 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_dpk_), intent(in), optional :: d(:) real(psb_dpk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='d_cssm' logical, parameter :: debug=.false. @@ -1447,14 +1411,12 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1474,8 +1436,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1493,8 +1454,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1518,8 +1478,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1578,8 +1537,7 @@ subroutine psb_d_base_scals(d,a,info) real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_scals' logical, parameter :: debug=.false. @@ -1605,8 +1563,7 @@ subroutine psb_d_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_scal' logical, parameter :: debug=.false. @@ -1632,8 +1589,7 @@ function psb_d_base_maxval(a) result(res) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1660,8 +1616,7 @@ function psb_d_base_csnmi(a) result(res) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_dpk_), allocatable :: vt(:) @@ -1699,8 +1654,7 @@ function psb_d_base_csnm1(a) result(res) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_dpk_), allocatable :: vt(:) @@ -1735,8 +1689,7 @@ subroutine psb_d_base_rowsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1758,8 +1711,7 @@ subroutine psb_d_base_arwsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1781,8 +1733,7 @@ subroutine psb_d_base_colsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1804,8 +1755,7 @@ subroutine psb_d_base_aclsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1831,8 +1781,7 @@ subroutine psb_d_base_get_diag(a,d,info) real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1898,9 +1847,8 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_dpk_), allocatable :: tmp(:) class(psb_d_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='d_cssm' logical, parameter :: debug=.false. @@ -1917,14 +1865,12 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1947,8 +1893,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1966,8 +1911,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1993,8 +1937,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2032,8 +1975,7 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_inner_vect_sv' logical, parameter :: debug=.false. diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 653e9f35a..0ee30332f 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -39,8 +39,7 @@ subroutine psb_d_coo_get_diag(a,d,info) real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +50,7 @@ subroutine psb_d_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +86,7 @@ subroutine psb_d_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +111,7 @@ subroutine psb_d_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +123,7 @@ subroutine psb_d_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +153,7 @@ subroutine psb_d_coo_scals(d,a,info) real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,8 +187,7 @@ subroutine psb_d_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='d_coo_reallocate_nz' logical, parameter :: debug=.false. @@ -226,8 +219,7 @@ subroutine psb_d_coo_mold(a,b,info) class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -261,8 +253,7 @@ subroutine psb_d_coo_reinit(a,clear) class(psb_d_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -308,8 +299,7 @@ subroutine psb_d_coo_trim(a) use psb_error_mod implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -365,8 +355,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -374,14 +363,12 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -391,8 +378,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -433,13 +419,12 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='real' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' @@ -562,8 +547,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) real(psb_dpk_) :: acc real(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_csmm' logical, parameter :: debug=.false. @@ -593,14 +577,12 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -918,8 +900,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) real(psb_dpk_) :: acc real(psb_dpk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_cssv_impl' logical, parameter :: debug=.false. @@ -943,14 +924,12 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1262,8 +1241,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc real(psb_dpk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1297,16 +1275,15 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == dzero) then @@ -1450,15 +1427,14 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc real(psb_dpk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1494,14 +1470,12 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1654,8 +1628,7 @@ function psb_d_coo_maxval(a) result(res) class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='d_coo_maxval' logical, parameter :: debug=.false. @@ -1686,7 +1659,6 @@ function psb_d_coo_csnmi(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_coo_csnmi' logical, parameter :: debug=.false. @@ -1748,7 +1720,6 @@ function psb_d_coo_csnm1(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_coo_csnm1' logical, parameter :: debug=.false. @@ -1787,7 +1758,6 @@ subroutine psb_d_coo_rowsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1795,10 +1765,10 @@ subroutine psb_d_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1836,7 +1806,6 @@ subroutine psb_d_coo_arwsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1846,8 +1815,7 @@ subroutine psb_d_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1884,7 +1852,6 @@ subroutine psb_d_coo_colsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1894,8 +1861,7 @@ subroutine psb_d_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1933,7 +1899,6 @@ subroutine psb_d_coo_aclsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1943,11 +1908,11 @@ subroutine psb_d_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = done else @@ -2006,8 +1971,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2282,7 +2246,6 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2556,12 +2519,11 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2570,27 +2532,23 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2931,8 +2889,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2974,8 +2931,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3021,8 +2977,7 @@ subroutine psb_d_cp_coo_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3054,8 +3009,7 @@ subroutine psb_d_cp_coo_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3089,8 +3043,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3132,8 +3085,7 @@ subroutine psb_d_mv_coo_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3177,8 +3129,7 @@ subroutine psb_d_mv_coo_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3210,8 +3161,7 @@ subroutine psb_d_mv_coo_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3245,8 +3195,7 @@ subroutine psb_d_coo_cp_from(a,b) type(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3276,8 +3225,7 @@ subroutine psb_d_coo_mv_from(a,b) type(psb_d_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3314,7 +3262,6 @@ subroutine psb_d_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3379,7 +3326,6 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 3bc62e0c0..1e6dda4ca 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_s_base_cp_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_s_base_cp_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_s_base_cp_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_s_base_cp_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_s_base_mv_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_s_base_mv_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_s_base_mv_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_s_base_mv_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -462,10 +451,9 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +542,7 @@ subroutine psb_s_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +636,6 @@ subroutine psb_s_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -800,7 +786,6 @@ subroutine psb_s_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -998,8 +983,7 @@ subroutine psb_s_base_mold(a,b,info) class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1024,7 +1008,6 @@ subroutine psb_s_base_transp_2mat(a,b) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transp' call psb_erractionsave(err_act) @@ -1039,8 +1022,7 @@ subroutine psb_s_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1062,7 +1044,6 @@ subroutine psb_s_base_transc_2mat(a,b) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transc' call psb_erractionsave(err_act) @@ -1077,8 +1058,7 @@ subroutine psb_s_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1099,7 +1079,6 @@ subroutine psb_s_base_transp_1mat(a) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transp' call psb_erractionsave(err_act) @@ -1131,7 +1110,6 @@ subroutine psb_s_base_transc_1mat(a) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transc' call psb_erractionsave(err_act) @@ -1180,8 +1158,7 @@ subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_csmm' logical, parameter :: debug=.false. @@ -1207,8 +1184,7 @@ subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_csmv' logical, parameter :: debug=.false. @@ -1235,8 +1211,7 @@ subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_inner_cssm' logical, parameter :: debug=.false. @@ -1262,8 +1237,7 @@ subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_inner_cssv' logical, parameter :: debug=.false. @@ -1294,7 +1268,6 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) real(psb_spk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_cssm' logical, parameter :: debug=.false. @@ -1311,14 +1284,12 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1338,8 +1309,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1362,8 +1332,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1387,8 +1356,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1402,16 +1370,13 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_s_base_cssm @@ -1428,9 +1393,8 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_spk_), intent(in), optional :: d(:) real(psb_spk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='s_cssm' logical, parameter :: debug=.false. @@ -1447,14 +1411,12 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1474,8 +1436,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1493,8 +1454,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1518,8 +1478,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1578,8 +1537,7 @@ subroutine psb_s_base_scals(d,a,info) real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_scals' logical, parameter :: debug=.false. @@ -1605,8 +1563,7 @@ subroutine psb_s_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_scal' logical, parameter :: debug=.false. @@ -1632,8 +1589,7 @@ function psb_s_base_maxval(a) result(res) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1660,8 +1616,7 @@ function psb_s_base_csnmi(a) result(res) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_spk_), allocatable :: vt(:) @@ -1699,8 +1654,7 @@ function psb_s_base_csnm1(a) result(res) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_spk_), allocatable :: vt(:) @@ -1735,8 +1689,7 @@ subroutine psb_s_base_rowsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1758,8 +1711,7 @@ subroutine psb_s_base_arwsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1781,8 +1733,7 @@ subroutine psb_s_base_colsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1804,8 +1755,7 @@ subroutine psb_s_base_aclsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1831,8 +1781,7 @@ subroutine psb_s_base_get_diag(a,d,info) real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1898,9 +1847,8 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_spk_), allocatable :: tmp(:) class(psb_s_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='s_cssm' logical, parameter :: debug=.false. @@ -1917,14 +1865,12 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1947,8 +1893,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1966,8 +1911,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1993,8 +1937,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2032,8 +1975,7 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_inner_vect_sv' logical, parameter :: debug=.false. diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index 132a1f684..254c91edc 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -39,8 +39,7 @@ subroutine psb_s_coo_get_diag(a,d,info) real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +50,7 @@ subroutine psb_s_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +86,7 @@ subroutine psb_s_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +111,7 @@ subroutine psb_s_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +123,7 @@ subroutine psb_s_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +153,7 @@ subroutine psb_s_coo_scals(d,a,info) real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,8 +187,7 @@ subroutine psb_s_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='s_coo_reallocate_nz' logical, parameter :: debug=.false. @@ -226,8 +219,7 @@ subroutine psb_s_coo_mold(a,b,info) class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -261,8 +253,7 @@ subroutine psb_s_coo_reinit(a,clear) class(psb_s_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -308,8 +299,7 @@ subroutine psb_s_coo_trim(a) use psb_error_mod implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -365,8 +355,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -374,14 +363,12 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -391,8 +378,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -433,13 +419,12 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='real' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' @@ -562,8 +547,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) real(psb_spk_) :: acc real(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_csmm' logical, parameter :: debug=.false. @@ -593,14 +577,12 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -918,8 +900,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) real(psb_spk_) :: acc real(psb_spk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_cssv_impl' logical, parameter :: debug=.false. @@ -943,14 +924,12 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1262,8 +1241,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc real(psb_spk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1297,16 +1275,15 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == szero) then @@ -1450,15 +1427,14 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc real(psb_spk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1494,14 +1470,12 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1654,8 +1628,7 @@ function psb_s_coo_maxval(a) result(res) class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='s_coo_maxval' logical, parameter :: debug=.false. @@ -1686,7 +1659,6 @@ function psb_s_coo_csnmi(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_coo_csnmi' logical, parameter :: debug=.false. @@ -1748,7 +1720,6 @@ function psb_s_coo_csnm1(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_coo_csnm1' logical, parameter :: debug=.false. @@ -1787,7 +1758,6 @@ subroutine psb_s_coo_rowsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1795,10 +1765,10 @@ subroutine psb_s_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1836,7 +1806,6 @@ subroutine psb_s_coo_arwsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1846,8 +1815,7 @@ subroutine psb_s_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1884,7 +1852,6 @@ subroutine psb_s_coo_colsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1894,8 +1861,7 @@ subroutine psb_s_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1933,7 +1899,6 @@ subroutine psb_s_coo_aclsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1943,11 +1908,11 @@ subroutine psb_s_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = sone else @@ -2006,8 +1971,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2282,7 +2246,6 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2556,12 +2519,11 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2570,27 +2532,23 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2931,8 +2889,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2974,8 +2931,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3021,8 +2977,7 @@ subroutine psb_s_cp_coo_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3054,8 +3009,7 @@ subroutine psb_s_cp_coo_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3089,8 +3043,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3132,8 +3085,7 @@ subroutine psb_s_mv_coo_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3177,8 +3129,7 @@ subroutine psb_s_mv_coo_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3210,8 +3161,7 @@ subroutine psb_s_mv_coo_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3245,8 +3195,7 @@ subroutine psb_s_coo_cp_from(a,b) type(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3276,8 +3225,7 @@ subroutine psb_s_coo_mv_from(a,b) type(psb_s_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3314,7 +3262,6 @@ subroutine psb_s_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3379,7 +3326,6 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index dfa39b8dd..b1d78d7bc 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_z_base_cp_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_z_base_cp_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_z_base_cp_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_z_base_cp_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_z_base_mv_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_z_base_mv_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_z_base_mv_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_z_base_mv_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -462,10 +451,9 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +542,7 @@ subroutine psb_z_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +636,6 @@ subroutine psb_z_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -800,7 +786,6 @@ subroutine psb_z_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -998,8 +983,7 @@ subroutine psb_z_base_mold(a,b,info) class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1024,7 +1008,6 @@ subroutine psb_z_base_transp_2mat(a,b) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transp' call psb_erractionsave(err_act) @@ -1039,8 +1022,7 @@ subroutine psb_z_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1062,7 +1044,6 @@ subroutine psb_z_base_transc_2mat(a,b) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transc' call psb_erractionsave(err_act) @@ -1077,8 +1058,7 @@ subroutine psb_z_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1099,7 +1079,6 @@ subroutine psb_z_base_transp_1mat(a) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transp' call psb_erractionsave(err_act) @@ -1131,7 +1110,6 @@ subroutine psb_z_base_transc_1mat(a) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transc' call psb_erractionsave(err_act) @@ -1180,8 +1158,7 @@ subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. @@ -1207,8 +1184,7 @@ subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_csmv' logical, parameter :: debug=.false. @@ -1235,8 +1211,7 @@ subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_inner_cssm' logical, parameter :: debug=.false. @@ -1262,8 +1237,7 @@ subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_inner_cssv' logical, parameter :: debug=.false. @@ -1294,7 +1268,6 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_dpk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_cssm' logical, parameter :: debug=.false. @@ -1311,14 +1284,12 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1338,8 +1309,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1362,8 +1332,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1387,8 +1356,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1402,16 +1370,13 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_z_base_cssm @@ -1428,9 +1393,8 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_dpk_), intent(in), optional :: d(:) complex(psb_dpk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='z_cssm' logical, parameter :: debug=.false. @@ -1447,14 +1411,12 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1474,8 +1436,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1493,8 +1454,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1518,8 +1478,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1578,8 +1537,7 @@ subroutine psb_z_base_scals(d,a,info) complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_scals' logical, parameter :: debug=.false. @@ -1605,8 +1563,7 @@ subroutine psb_z_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_scal' logical, parameter :: debug=.false. @@ -1632,8 +1589,7 @@ function psb_z_base_maxval(a) result(res) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1660,8 +1616,7 @@ function psb_z_base_csnmi(a) result(res) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_dpk_), allocatable :: vt(:) @@ -1699,8 +1654,7 @@ function psb_z_base_csnm1(a) result(res) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_dpk_), allocatable :: vt(:) @@ -1735,8 +1689,7 @@ subroutine psb_z_base_rowsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1758,8 +1711,7 @@ subroutine psb_z_base_arwsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1781,8 +1733,7 @@ subroutine psb_z_base_colsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1804,8 +1755,7 @@ subroutine psb_z_base_aclsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1831,8 +1781,7 @@ subroutine psb_z_base_get_diag(a,d,info) complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1898,9 +1847,8 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_dpk_), allocatable :: tmp(:) class(psb_z_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='z_cssm' logical, parameter :: debug=.false. @@ -1917,14 +1865,12 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1947,8 +1893,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1966,8 +1911,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1993,8 +1937,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2032,8 +1975,7 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_inner_vect_sv' logical, parameter :: debug=.false. diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index 1605aa470..6a54a022f 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -39,8 +39,7 @@ subroutine psb_z_coo_get_diag(a,d,info) complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +50,7 @@ subroutine psb_z_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +86,7 @@ subroutine psb_z_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +111,7 @@ subroutine psb_z_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +123,7 @@ subroutine psb_z_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +153,7 @@ subroutine psb_z_coo_scals(d,a,info) complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,8 +187,7 @@ subroutine psb_z_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='z_coo_reallocate_nz' logical, parameter :: debug=.false. @@ -226,8 +219,7 @@ subroutine psb_z_coo_mold(a,b,info) class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -261,8 +253,7 @@ subroutine psb_z_coo_reinit(a,clear) class(psb_z_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -308,8 +299,7 @@ subroutine psb_z_coo_trim(a) use psb_error_mod implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -365,8 +355,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -374,14 +363,12 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -391,8 +378,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -433,13 +419,12 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='complex' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' @@ -562,8 +547,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) complex(psb_dpk_) :: acc complex(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. @@ -593,14 +577,12 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -918,8 +900,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) complex(psb_dpk_) :: acc complex(psb_dpk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_cssv_impl' logical, parameter :: debug=.false. @@ -943,14 +924,12 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1262,8 +1241,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc complex(psb_dpk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1297,16 +1275,15 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == zzero) then @@ -1450,15 +1427,14 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc complex(psb_dpk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1494,14 +1470,12 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1654,8 +1628,7 @@ function psb_z_coo_maxval(a) result(res) class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='z_coo_maxval' logical, parameter :: debug=.false. @@ -1686,7 +1659,6 @@ function psb_z_coo_csnmi(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_coo_csnmi' logical, parameter :: debug=.false. @@ -1748,7 +1720,6 @@ function psb_z_coo_csnm1(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_coo_csnm1' logical, parameter :: debug=.false. @@ -1787,7 +1758,6 @@ subroutine psb_z_coo_rowsum(d,a) complex(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1795,10 +1765,10 @@ subroutine psb_z_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1836,7 +1806,6 @@ subroutine psb_z_coo_arwsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1846,8 +1815,7 @@ subroutine psb_z_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1884,7 +1852,6 @@ subroutine psb_z_coo_colsum(d,a) complex(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1894,8 +1861,7 @@ subroutine psb_z_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1933,7 +1899,6 @@ subroutine psb_z_coo_aclsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1943,11 +1908,11 @@ subroutine psb_z_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = done else @@ -2006,8 +1971,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2282,7 +2246,6 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2556,12 +2519,11 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2570,27 +2532,23 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2931,8 +2889,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2974,8 +2931,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3021,8 +2977,7 @@ subroutine psb_z_cp_coo_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3054,8 +3009,7 @@ subroutine psb_z_cp_coo_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3089,8 +3043,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3132,8 +3085,7 @@ subroutine psb_z_mv_coo_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3177,8 +3129,7 @@ subroutine psb_z_mv_coo_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3210,8 +3161,7 @@ subroutine psb_z_mv_coo_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3245,8 +3195,7 @@ subroutine psb_z_coo_cp_from(a,b) type(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3276,8 +3225,7 @@ subroutine psb_z_coo_mv_from(a,b) type(psb_z_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3314,7 +3262,6 @@ subroutine psb_z_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3379,7 +3326,6 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index 78fb97061..dc8a28738 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -61,7 +61,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) integer(psb_ipk_) :: counter,i,j,loc_row,err,loc_col,& & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, nlx integer(psb_lpk_) :: iglob - integer(psb_ipk_) :: int_err(5),exch(3) + integer(psb_ipk_) :: exch(3) integer(psb_ipk_), allocatable :: temp_ovrlap(:) integer(psb_lpk_), allocatable :: l_temp_ovrlap(:), loc_idx(:) integer(psb_ipk_), allocatable :: prc_v(:) @@ -87,14 +87,12 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (m < 1) then info = psb_err_iarg_neg_ err=info - int_err(1) = 1; int_err(2) = m; - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,l_err=(/lone,m/)) goto 9999 else if (n < 1) then info = psb_err_iarg_neg_ err=info - int_err(1) = 2 ; int_err(2) = n; - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,l_err=(/lone*2,n/)) goto 9999 endif @@ -108,13 +106,11 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psb_bcast(ictxt,exch(1:3),root=psb_root_) if (exch(1) /= m) then err=550 - int_err(1)=1 - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,m_err=(/1/)) goto 9999 else if (exch(2) /= n) then err=550 - int_err(1)=2 - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,m_err=(/2/)) goto 9999 endif call psb_cd_set_large_threshold(exch(3)) @@ -130,8 +126,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (info /= psb_success_) then info=psb_err_alloc_request_ err=info - int_err(1)=2*m+psb_mdata_size_+np - call psb_errpush(err,name,int_err,a_err='integer') + call psb_errpush(err,name,a_err='integer',l_err=(/2*m+psb_mdata_size_+np/)) goto 9999 endif @@ -168,8 +163,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err,a_err='integer') + call psb_errpush(info,name,i_err=(/loc_col/),a_err='integer') goto 9999 end if @@ -182,30 +176,17 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call parts(iglob,m,np,prc_v,nprocs) if (nprocs > np) then info=psb_err_partfunc_toomuchprocs_ - int_err(1)=3 - int_err(2)=np - int_err(3)=nprocs - int_err(4)=iglob - err=info - call psb_errpush(err,name,int_err) + call psb_errpush(info,name,l_err=(/3_psb_lpk_,np*lone,nprocs*lone,iglob/)) goto 9999 else if (nprocs <= 0) then info=psb_err_partfunc_toofewprocs_ - int_err(1)=3 - int_err(2)=nprocs - int_err(3)=iglob - err=info - call psb_errpush(err,name,int_err) + call psb_errpush(info,name,l_err=(/3_psb_lpk_,nprocs*lone,iglob/)) goto 9999 else do j=1,nprocs if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=prc_v(j) - int_err(3)=iglob - err=info - call psb_errpush(err,name,int_err) + call psb_errpush(info,name,l_err=(/3_psb_lpk_,prc_v(j)*lone,iglob/)) goto 9999 end if end do