From 0d49855313fec5ba1456ae4772bd3899887cef5f Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 21 Dec 2014 09:17:20 +0000 Subject: [PATCH] psblas3: base/psblas/psb_camax.f90 base/psblas/psb_casum.f90 base/psblas/psb_caxpby.f90 base/psblas/psb_cdot.f90 base/psblas/psb_cnrm2.f90 base/psblas/psb_cnrmi.f90 base/psblas/psb_cspmm.f90 base/psblas/psb_cspnrm1.f90 base/psblas/psb_cspsm.f90 base/psblas/psb_damax.f90 base/psblas/psb_dasum.f90 base/psblas/psb_daxpby.f90 base/psblas/psb_ddot.f90 base/psblas/psb_dnrm2.f90 base/psblas/psb_dnrmi.f90 base/psblas/psb_dspmm.f90 base/psblas/psb_dspnrm1.f90 base/psblas/psb_dspsm.f90 base/psblas/psb_samax.f90 base/psblas/psb_sasum.f90 base/psblas/psb_saxpby.f90 base/psblas/psb_sdot.f90 base/psblas/psb_snrm2.f90 base/psblas/psb_snrmi.f90 base/psblas/psb_sspmm.f90 base/psblas/psb_sspnrm1.f90 base/psblas/psb_sspsm.f90 base/psblas/psb_zamax.f90 base/psblas/psb_zasum.f90 base/psblas/psb_zaxpby.f90 base/psblas/psb_zdot.f90 base/psblas/psb_znrm2.f90 base/psblas/psb_znrmi.f90 base/psblas/psb_zspmm.f90 base/psblas/psb_zspnrm1.f90 base/psblas/psb_zspsm.f90 New error handling. --- base/psblas/psb_camax.f90 | 115 ++++++++++++++---------------------- base/psblas/psb_casum.f90 | 28 ++------- base/psblas/psb_caxpby.f90 | 21 +------ base/psblas/psb_cdot.f90 | 35 ++--------- base/psblas/psb_cnrm2.f90 | 32 ++-------- base/psblas/psb_cnrmi.f90 | 7 +-- base/psblas/psb_cspmm.f90 | 33 +++-------- base/psblas/psb_cspnrm1.f90 | 9 +-- base/psblas/psb_cspsm.f90 | 29 +++------ base/psblas/psb_damax.f90 | 115 ++++++++++++++---------------------- base/psblas/psb_dasum.f90 | 28 ++------- base/psblas/psb_daxpby.f90 | 21 +------ base/psblas/psb_ddot.f90 | 35 ++--------- base/psblas/psb_dnrm2.f90 | 32 ++-------- base/psblas/psb_dnrmi.f90 | 7 +-- base/psblas/psb_dspmm.f90 | 33 +++-------- base/psblas/psb_dspnrm1.f90 | 9 +-- base/psblas/psb_dspsm.f90 | 29 +++------ base/psblas/psb_samax.f90 | 115 ++++++++++++++---------------------- base/psblas/psb_sasum.f90 | 28 ++------- base/psblas/psb_saxpby.f90 | 21 +------ base/psblas/psb_sdot.f90 | 35 ++--------- base/psblas/psb_snrm2.f90 | 32 ++-------- base/psblas/psb_snrmi.f90 | 7 +-- base/psblas/psb_sspmm.f90 | 33 +++-------- base/psblas/psb_sspnrm1.f90 | 9 +-- base/psblas/psb_sspsm.f90 | 29 +++------ base/psblas/psb_zamax.f90 | 115 ++++++++++++++---------------------- base/psblas/psb_zasum.f90 | 28 ++------- base/psblas/psb_zaxpby.f90 | 21 +------ base/psblas/psb_zdot.f90 | 35 ++--------- base/psblas/psb_znrm2.f90 | 32 ++-------- base/psblas/psb_znrmi.f90 | 7 +-- base/psblas/psb_zspmm.f90 | 33 +++-------- base/psblas/psb_zspnrm1.f90 | 9 +-- base/psblas/psb_zspsm.f90 | 29 +++------ 36 files changed, 328 insertions(+), 908 deletions(-) diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 index 19749dc1..6badf97f 100644 --- a/base/psblas/psb_camax.f90 +++ b/base/psblas/psb_camax.f90 @@ -74,12 +74,12 @@ function psb_camax(x,desc_a, info, jx) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -87,16 +87,16 @@ function psb_camax(x,desc_a, info, jx) result(res) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -105,20 +105,15 @@ function psb_camax(x,desc_a, info, jx) result(res) else res = szero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_camax @@ -197,7 +192,7 @@ function psb_camaxv (x,desc_a, info) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 jx = 1 @@ -206,16 +201,16 @@ function psb_camaxv (x,desc_a, info) result(res) call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -224,20 +219,15 @@ function psb_camaxv (x,desc_a, info) result(res) else res = szero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_camaxv @@ -312,13 +302,8 @@ function psb_camax_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_camax_vect @@ -407,16 +392,16 @@ subroutine psb_camaxvs(res,x,desc_a, info) ldx=size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -425,20 +410,15 @@ subroutine psb_camaxvs(res,x,desc_a, info) else res = szero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_camaxvs @@ -515,12 +495,12 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -528,16 +508,16 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if res(1:k) = szero @@ -547,19 +527,14 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) res(i) = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx+i-1)) end do end if - + ! compute global max call psb_amx(ictxt, res(1:k)) - + call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cmamaxs diff --git a/base/psblas/psb_casum.f90 b/base/psblas/psb_casum.f90 index df296991..b81fff87 100644 --- a/base/psblas/psb_casum.f90 +++ b/base/psblas/psb_casum.f90 @@ -119,13 +119,8 @@ function psb_casum (x,desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_casum @@ -197,13 +192,8 @@ function psb_casum_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_casum_vect @@ -322,13 +312,8 @@ function psb_casumv(x,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_casumv @@ -447,12 +432,7 @@ subroutine psb_casumvs(res,x,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_casumvs diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index 7cc80a24..82cb05df 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -105,13 +105,8 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_caxpby_vect @@ -229,13 +224,8 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_caxpby @@ -356,12 +346,7 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_caxpbyv diff --git a/base/psblas/psb_cdot.f90 b/base/psblas/psb_cdot.f90 index 0a34a067..bebc1beb 100644 --- a/base/psblas/psb_cdot.f90 +++ b/base/psblas/psb_cdot.f90 @@ -137,13 +137,8 @@ function psb_cdot_vect(x, y, desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cdot_vect @@ -238,13 +233,8 @@ function psb_cdot(x, y,desc_a, info, jx, jy) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cdot @@ -368,13 +358,8 @@ function psb_cdotv(x, y,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cdotv @@ -495,13 +480,8 @@ subroutine psb_cdotvs(res, x, y,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cdotvs @@ -636,12 +616,7 @@ subroutine psb_cmdots(res, x, y, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cmdots diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index d710c035..918b5798 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -119,13 +119,8 @@ function psb_cnrm2(x, desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cnrm2 @@ -237,20 +232,15 @@ function psb_cnrm2v(x, desc_a, info) result(res) else res = szero end if - + call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cnrm2v @@ -333,13 +323,8 @@ function psb_cnrm2_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cnrm2_vect @@ -442,7 +427,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = scnrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) - + ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -460,12 +445,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cnrm2vs diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 index 959903ed..15b2f94a 100644 --- a/base/psblas/psb_cnrmi.f90 +++ b/base/psblas/psb_cnrmi.f90 @@ -106,12 +106,7 @@ function psb_cnrmi(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cnrmi diff --git a/base/psblas/psb_cspmm.f90 b/base/psblas/psb_cspmm.f90 index 5636eb08..8d0a3c47 100644 --- a/base/psblas/psb_cspmm.f90 +++ b/base/psblas/psb_cspmm.f90 @@ -348,13 +348,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cspmm @@ -612,7 +607,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& call psi_ovrl_save(x,xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = czero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -626,13 +621,13 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & cone,yp,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -664,13 +659,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cspmv @@ -825,7 +815,7 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& !!! THIS SHOULD BE FIXED !!! But beta is almost never /= 0 !!$ yp(nrow+1:ncol) = czero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -839,13 +829,13 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & cone,y%v,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & cone,y%v,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -877,12 +867,7 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cspmv_vect diff --git a/base/psblas/psb_cspnrm1.f90 b/base/psblas/psb_cspnrm1.f90 index ec95af4d..bc095c41 100644 --- a/base/psblas/psb_cspnrm1.f90 +++ b/base/psblas/psb_cspnrm1.f90 @@ -102,7 +102,7 @@ function psb_cspnrm1(a,desc_a,info) result(res) !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if - + if ((m /= 0).and.(n /= 0)) then v = a%aclsum(info) if (info == psb_success_) & @@ -124,12 +124,7 @@ function psb_cspnrm1(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_cspnrm1 diff --git a/base/psblas/psb_cspsm.f90 b/base/psblas/psb_cspsm.f90 index af102d66..4a5a5aaa 100644 --- a/base/psblas/psb_cspsm.f90 +++ b/base/psblas/psb_cspsm.f90 @@ -276,16 +276,11 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cspsm - + !!$ !!$ Parallel Sparse BLAS version 3.1 !!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013 @@ -539,17 +534,12 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cspsv - - + + subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, work) use psb_base_mod, psb_protect_name => psb_cspsv_vect @@ -705,13 +695,8 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_cspsv_vect - + diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index b7a179cf..267f8329 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -74,12 +74,12 @@ function psb_damax(x,desc_a, info, jx) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -87,16 +87,16 @@ function psb_damax(x,desc_a, info, jx) result(res) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -105,20 +105,15 @@ function psb_damax(x,desc_a, info, jx) result(res) else res = dzero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_damax @@ -197,7 +192,7 @@ function psb_damaxv (x,desc_a, info) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 jx = 1 @@ -206,16 +201,16 @@ function psb_damaxv (x,desc_a, info) result(res) call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -224,20 +219,15 @@ function psb_damaxv (x,desc_a, info) result(res) else res = dzero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_damaxv @@ -312,13 +302,8 @@ function psb_damax_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_damax_vect @@ -407,16 +392,16 @@ subroutine psb_damaxvs(res,x,desc_a, info) ldx=size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -425,20 +410,15 @@ subroutine psb_damaxvs(res,x,desc_a, info) else res = dzero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_damaxvs @@ -515,12 +495,12 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -528,16 +508,16 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx) ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if res(1:k) = dzero @@ -547,19 +527,14 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx) res(i) = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx+i-1)) end do end if - + ! compute global max call psb_amx(ictxt, res(1:k)) - + call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dmamaxs diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index 2e03aa56..c4dc00c5 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -119,13 +119,8 @@ function psb_dasum (x,desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dasum @@ -197,13 +192,8 @@ function psb_dasum_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dasum_vect @@ -322,13 +312,8 @@ function psb_dasumv(x,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dasumv @@ -447,12 +432,7 @@ subroutine psb_dasumvs(res,x,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dasumvs diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 27631b21..2826420f 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -105,13 +105,8 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_daxpby_vect @@ -229,13 +224,8 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_daxpby @@ -356,12 +346,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_daxpbyv diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index 17098115..c7c3b2b9 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -137,13 +137,8 @@ function psb_ddot_vect(x, y, desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_ddot_vect @@ -238,13 +233,8 @@ function psb_ddot(x, y,desc_a, info, jx, jy) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_ddot @@ -368,13 +358,8 @@ function psb_ddotv(x, y,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_ddotv @@ -495,13 +480,8 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_ddotvs @@ -636,12 +616,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dmdots diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 6471170e..2fbf8da0 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -119,13 +119,8 @@ function psb_dnrm2(x, desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dnrm2 @@ -237,20 +232,15 @@ function psb_dnrm2v(x, desc_a, info) result(res) else res = dzero end if - + call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dnrm2v @@ -333,13 +323,8 @@ function psb_dnrm2_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dnrm2_vect @@ -442,7 +427,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dnrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) - + ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -460,12 +445,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dnrm2vs diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 8f4b09db..4f3a90ec 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -106,12 +106,7 @@ function psb_dnrmi(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dnrmi diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index ec34195e..e8eb3535 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -348,13 +348,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dspmm @@ -612,7 +607,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& call psi_ovrl_save(x,xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = dzero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -626,13 +621,13 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & done,yp,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -664,13 +659,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dspmv @@ -825,7 +815,7 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& !!! THIS SHOULD BE FIXED !!! But beta is almost never /= 0 !!$ yp(nrow+1:ncol) = dzero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -839,13 +829,13 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & done,y%v,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & done,y%v,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -877,12 +867,7 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dspmv_vect diff --git a/base/psblas/psb_dspnrm1.f90 b/base/psblas/psb_dspnrm1.f90 index 2ec5547a..64e35999 100644 --- a/base/psblas/psb_dspnrm1.f90 +++ b/base/psblas/psb_dspnrm1.f90 @@ -102,7 +102,7 @@ function psb_dspnrm1(a,desc_a,info) result(res) !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if - + if ((m /= 0).and.(n /= 0)) then v = a%aclsum(info) if (info == psb_success_) & @@ -124,12 +124,7 @@ function psb_dspnrm1(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_dspnrm1 diff --git a/base/psblas/psb_dspsm.f90 b/base/psblas/psb_dspsm.f90 index 9d2f6043..74def423 100644 --- a/base/psblas/psb_dspsm.f90 +++ b/base/psblas/psb_dspsm.f90 @@ -276,16 +276,11 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dspsm - + !!$ !!$ Parallel Sparse BLAS version 3.1 !!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013 @@ -539,17 +534,12 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dspsv - - + + subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, work) use psb_base_mod, psb_protect_name => psb_dspsv_vect @@ -705,13 +695,8 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_dspsv_vect - + diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 index e523f9fe..79a105ef 100644 --- a/base/psblas/psb_samax.f90 +++ b/base/psblas/psb_samax.f90 @@ -74,12 +74,12 @@ function psb_samax(x,desc_a, info, jx) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -87,16 +87,16 @@ function psb_samax(x,desc_a, info, jx) result(res) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -105,20 +105,15 @@ function psb_samax(x,desc_a, info, jx) result(res) else res = szero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_samax @@ -197,7 +192,7 @@ function psb_samaxv (x,desc_a, info) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 jx = 1 @@ -206,16 +201,16 @@ function psb_samaxv (x,desc_a, info) result(res) call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -224,20 +219,15 @@ function psb_samaxv (x,desc_a, info) result(res) else res = szero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_samaxv @@ -312,13 +302,8 @@ function psb_samax_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_samax_vect @@ -407,16 +392,16 @@ subroutine psb_samaxvs(res,x,desc_a, info) ldx=size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -425,20 +410,15 @@ subroutine psb_samaxvs(res,x,desc_a, info) else res = szero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_samaxvs @@ -515,12 +495,12 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -528,16 +508,16 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx) ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if res(1:k) = szero @@ -547,19 +527,14 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx) res(i) = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx+i-1)) end do end if - + ! compute global max call psb_amx(ictxt, res(1:k)) - + call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_smamaxs diff --git a/base/psblas/psb_sasum.f90 b/base/psblas/psb_sasum.f90 index 7182e0d7..3b629ad5 100644 --- a/base/psblas/psb_sasum.f90 +++ b/base/psblas/psb_sasum.f90 @@ -119,13 +119,8 @@ function psb_sasum (x,desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_sasum @@ -197,13 +192,8 @@ function psb_sasum_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_sasum_vect @@ -322,13 +312,8 @@ function psb_sasumv(x,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_sasumv @@ -447,12 +432,7 @@ subroutine psb_sasumvs(res,x,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sasumvs diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index 1af47f43..f491e0fa 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -105,13 +105,8 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_saxpby_vect @@ -229,13 +224,8 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_saxpby @@ -356,12 +346,7 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_saxpbyv diff --git a/base/psblas/psb_sdot.f90 b/base/psblas/psb_sdot.f90 index cec793b6..50208717 100644 --- a/base/psblas/psb_sdot.f90 +++ b/base/psblas/psb_sdot.f90 @@ -137,13 +137,8 @@ function psb_sdot_vect(x, y, desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_sdot_vect @@ -238,13 +233,8 @@ function psb_sdot(x, y,desc_a, info, jx, jy) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_sdot @@ -368,13 +358,8 @@ function psb_sdotv(x, y,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_sdotv @@ -495,13 +480,8 @@ subroutine psb_sdotvs(res, x, y,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sdotvs @@ -636,12 +616,7 @@ subroutine psb_smdots(res, x, y, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_smdots diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index b930d2d4..620493e9 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -119,13 +119,8 @@ function psb_snrm2(x, desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_snrm2 @@ -237,20 +232,15 @@ function psb_snrm2v(x, desc_a, info) result(res) else res = szero end if - + call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_snrm2v @@ -333,13 +323,8 @@ function psb_snrm2_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_snrm2_vect @@ -442,7 +427,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = snrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) - + ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -460,12 +445,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_snrm2vs diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 index af830f1c..8dfed849 100644 --- a/base/psblas/psb_snrmi.f90 +++ b/base/psblas/psb_snrmi.f90 @@ -106,12 +106,7 @@ function psb_snrmi(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_snrmi diff --git a/base/psblas/psb_sspmm.f90 b/base/psblas/psb_sspmm.f90 index 9e6523a5..e3a01b7a 100644 --- a/base/psblas/psb_sspmm.f90 +++ b/base/psblas/psb_sspmm.f90 @@ -348,13 +348,8 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sspmm @@ -612,7 +607,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& call psi_ovrl_save(x,xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = szero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -626,13 +621,13 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & sone,yp,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -664,13 +659,8 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sspmv @@ -825,7 +815,7 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& !!! THIS SHOULD BE FIXED !!! But beta is almost never /= 0 !!$ yp(nrow+1:ncol) = szero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -839,13 +829,13 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & sone,y%v,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & sone,y%v,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -877,12 +867,7 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sspmv_vect diff --git a/base/psblas/psb_sspnrm1.f90 b/base/psblas/psb_sspnrm1.f90 index 082f1993..a9acde80 100644 --- a/base/psblas/psb_sspnrm1.f90 +++ b/base/psblas/psb_sspnrm1.f90 @@ -102,7 +102,7 @@ function psb_sspnrm1(a,desc_a,info) result(res) !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if - + if ((m /= 0).and.(n /= 0)) then v = a%aclsum(info) if (info == psb_success_) & @@ -124,12 +124,7 @@ function psb_sspnrm1(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_sspnrm1 diff --git a/base/psblas/psb_sspsm.f90 b/base/psblas/psb_sspsm.f90 index be7cc6e4..a60509e2 100644 --- a/base/psblas/psb_sspsm.f90 +++ b/base/psblas/psb_sspsm.f90 @@ -276,16 +276,11 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sspsm - + !!$ !!$ Parallel Sparse BLAS version 3.1 !!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013 @@ -539,17 +534,12 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sspsv - - + + subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, work) use psb_base_mod, psb_protect_name => psb_sspsv_vect @@ -705,13 +695,8 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_sspsv_vect - + diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index dda0456c..b9034e1c 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -74,12 +74,12 @@ function psb_zamax(x,desc_a, info, jx) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -87,16 +87,16 @@ function psb_zamax(x,desc_a, info, jx) result(res) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -105,20 +105,15 @@ function psb_zamax(x,desc_a, info, jx) result(res) else res = dzero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zamax @@ -197,7 +192,7 @@ function psb_zamaxv (x,desc_a, info) result(res) call psb_errpush(info,name) goto 9999 endif - + ix = 1 jx = 1 @@ -206,16 +201,16 @@ function psb_zamaxv (x,desc_a, info) result(res) call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -224,20 +219,15 @@ function psb_zamaxv (x,desc_a, info) result(res) else res = dzero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zamaxv @@ -312,13 +302,8 @@ function psb_zamax_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zamax_vect @@ -407,16 +392,16 @@ subroutine psb_zamaxvs(res,x,desc_a, info) ldx=size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if ! compute local max @@ -425,20 +410,15 @@ subroutine psb_zamaxvs(res,x,desc_a, info) else res = dzero end if - + ! compute global max call psb_amx(ictxt, res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zamaxvs @@ -515,12 +495,12 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then - ijx = jx + ijx = jx else - ijx = 1 + ijx = 1 endif m = desc_a%get_global_rows() @@ -528,16 +508,16 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) ldx = size(x,1) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 end if res(1:k) = dzero @@ -547,19 +527,14 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) res(i) = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx+i-1)) end do end if - + ! compute global max call psb_amx(ictxt, res(1:k)) - + call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zmamaxs diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index 066636d1..9b44df54 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -119,13 +119,8 @@ function psb_zasum (x,desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zasum @@ -197,13 +192,8 @@ function psb_zasum_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zasum_vect @@ -322,13 +312,8 @@ function psb_zasumv(x,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zasumv @@ -447,12 +432,7 @@ subroutine psb_zasumvs(res,x,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zasumvs diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index 45dece41..f725a273 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -105,13 +105,8 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zaxpby_vect @@ -229,13 +224,8 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zaxpby @@ -356,12 +346,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zaxpbyv diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index 81ba44b5..87907712 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -137,13 +137,8 @@ function psb_zdot_vect(x, y, desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zdot_vect @@ -238,13 +233,8 @@ function psb_zdot(x, y,desc_a, info, jx, jy) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zdot @@ -368,13 +358,8 @@ function psb_zdotv(x, y,desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zdotv @@ -495,13 +480,8 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zdotvs @@ -636,12 +616,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zmdots diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index 02e55d4b..9b059a95 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -119,13 +119,8 @@ function psb_znrm2(x, desc_a, info, jx) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_znrm2 @@ -237,20 +232,15 @@ function psb_znrm2v(x, desc_a, info) result(res) else res = dzero end if - + call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_znrm2v @@ -333,13 +323,8 @@ function psb_znrm2_vect(x, desc_a, info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_znrm2_vect @@ -442,7 +427,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dznrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) - + ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -460,12 +445,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_znrm2vs diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index 7e298984..1cea3b27 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -106,12 +106,7 @@ function psb_znrmi(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_znrmi diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index 614c0339..4e8f700b 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -348,13 +348,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zspmm @@ -612,7 +607,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& call psi_ovrl_save(x,xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = zzero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -626,13 +621,13 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & zone,yp,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -664,13 +659,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zspmv @@ -825,7 +815,7 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& !!! THIS SHOULD BE FIXED !!! But beta is almost never /= 0 !!$ yp(nrow+1:ncol) = zzero - + ! local Matrix-vector product if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) @@ -839,13 +829,13 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & zone,y%v,desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & zone,y%v,desc_a,iwork,info,data=psb_comm_ovr_) - + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then @@ -877,12 +867,7 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& endif return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zspmv_vect diff --git a/base/psblas/psb_zspnrm1.f90 b/base/psblas/psb_zspnrm1.f90 index ee448632..cccf257e 100644 --- a/base/psblas/psb_zspnrm1.f90 +++ b/base/psblas/psb_zspnrm1.f90 @@ -102,7 +102,7 @@ function psb_zspnrm1(a,desc_a,info) result(res) !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if - + if ((m /= 0).and.(n /= 0)) then v = a%aclsum(info) if (info == psb_success_) & @@ -124,12 +124,7 @@ function psb_zspnrm1(a,desc_a,info) result(res) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end function psb_zspnrm1 diff --git a/base/psblas/psb_zspsm.f90 b/base/psblas/psb_zspsm.f90 index 363343af..6509058a 100644 --- a/base/psblas/psb_zspsm.f90 +++ b/base/psblas/psb_zspsm.f90 @@ -276,16 +276,11 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zspsm - + !!$ !!$ Parallel Sparse BLAS version 3.1 !!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013 @@ -539,17 +534,12 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zspsv - - + + subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, work) use psb_base_mod, psb_protect_name => psb_zspsv_vect @@ -705,13 +695,8 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(ictxt,err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if return end subroutine psb_zspsv_vect - +