diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index 1f9b07ed..a9b64204 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -127,7 +127,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,k,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -160,13 +160,8 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) 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_cgatherm @@ -298,21 +293,21 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - + globx(:)=czero do i=1,desc_a%get_local_rows() call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = locx(i) end do - + ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then @@ -321,19 +316,14 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) globx(idx) = czero end if end do - + call psb_sum(ictxt,globx(1:m),root=root) 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_cgatherv @@ -446,13 +436,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) 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_cgather_vect diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 index 88d63166..fe0f8d15 100644 --- a/base/comm/psb_chalo.f90 +++ b/base/comm/psb_chalo.f90 @@ -208,14 +208,9 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 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_chalom @@ -409,14 +404,9 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) 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_chalov @@ -560,12 +550,7 @@ subroutine psb_chalo_vect(x,desc_a,info,alpha,work,tran,mode,data) 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_chalo_vect diff --git a/base/comm/psb_covrl.f90 b/base/comm/psb_covrl.f90 index 6fee907b..970cea36 100644 --- a/base/comm/psb_covrl.f90 +++ b/base/comm/psb_covrl.f90 @@ -193,14 +193,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) 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_covrlm !!$ !!$ Parallel Sparse BLAS version 3.1 @@ -378,14 +373,9 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) 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_covrlv @@ -508,13 +498,8 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) 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_covrl_vect diff --git a/base/comm/psb_cscatter.F90 b/base/comm/psb_cscatter.F90 index cf8c372b..77085cd8 100644 --- a/base/comm/psb_cscatter.F90 +++ b/base/comm/psb_cscatter.F90 @@ -233,14 +233,9 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) 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_cscatterm @@ -468,13 +463,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) 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_cscatterv diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index 531bd4c6..018df291 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -149,12 +149,8 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return + call psb_error_handler(ictxt,err_act) + return end subroutine psb_csp_allgather diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index 7d62687c..2135402f 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -127,7 +127,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,k,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -160,13 +160,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) 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_dgatherm @@ -298,21 +293,21 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - + globx(:)=dzero do i=1,desc_a%get_local_rows() call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = locx(i) end do - + ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then @@ -321,19 +316,14 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) globx(idx) = dzero end if end do - + call psb_sum(ictxt,globx(1:m),root=root) 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_dgatherv @@ -446,13 +436,8 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) 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_dgather_vect diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index 8fd81d7d..4fa90665 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -208,14 +208,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 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_dhalom @@ -409,14 +404,9 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) 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_dhalov @@ -560,12 +550,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,alpha,work,tran,mode,data) 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_dhalo_vect diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index 54d325f9..5add77f2 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -193,14 +193,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) 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_dovrlm !!$ !!$ Parallel Sparse BLAS version 3.1 @@ -378,14 +373,9 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) 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_dovrlv @@ -508,13 +498,8 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) 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_dovrl_vect diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index e8652b78..886eff24 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -233,14 +233,9 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) 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_dscatterm @@ -468,13 +463,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) 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_dscatterv diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index c032874b..777fd4ac 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -149,12 +149,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return + call psb_error_handler(ictxt,err_act) + return end subroutine psb_dsp_allgather diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 5470c180..07b36c3f 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -160,14 +160,9 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) 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_igatherm @@ -319,14 +314,9 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) 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_igatherv @@ -437,13 +427,8 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) 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_igather_vect diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index 6b6cb3f8..20941096 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -212,14 +212,9 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 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_ihalom @@ -415,14 +410,9 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) 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_ihalov @@ -568,12 +558,7 @@ subroutine psb_ihalo_vect(x,desc_a,info,alpha,work,tran,mode,data) 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_ihalo_vect diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 index 1d72edbd..6b078287 100644 --- a/base/comm/psb_iovrl.f90 +++ b/base/comm/psb_iovrl.f90 @@ -191,14 +191,9 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) 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_iovrlm !!$ @@ -379,14 +374,9 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) 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_iovrlv subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) @@ -508,13 +498,8 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) 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_iovrl_vect diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index 9d9f5481..8adde4a7 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -217,14 +217,9 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) 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_iscatterm @@ -424,13 +419,8 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) 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_iscatterv diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 297cd81e..e825b16c 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -127,7 +127,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,k,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -160,13 +160,8 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) 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_sgatherm @@ -298,21 +293,21 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - + globx(:)=szero do i=1,desc_a%get_local_rows() call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = locx(i) end do - + ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then @@ -321,19 +316,14 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) globx(idx) = szero end if end do - + call psb_sum(ictxt,globx(1:m),root=root) 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_sgatherv @@ -446,13 +436,8 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) 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_sgather_vect diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 index de71fa4f..979cc83f 100644 --- a/base/comm/psb_shalo.f90 +++ b/base/comm/psb_shalo.f90 @@ -208,14 +208,9 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 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_shalom @@ -409,14 +404,9 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) 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_shalov @@ -560,12 +550,7 @@ subroutine psb_shalo_vect(x,desc_a,info,alpha,work,tran,mode,data) 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_shalo_vect diff --git a/base/comm/psb_sovrl.f90 b/base/comm/psb_sovrl.f90 index 968aaf68..bca23027 100644 --- a/base/comm/psb_sovrl.f90 +++ b/base/comm/psb_sovrl.f90 @@ -193,14 +193,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) 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_sovrlm !!$ !!$ Parallel Sparse BLAS version 3.1 @@ -378,14 +373,9 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) 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_sovrlv @@ -508,13 +498,8 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) 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_sovrl_vect diff --git a/base/comm/psb_sscatter.F90 b/base/comm/psb_sscatter.F90 index 35424a34..c977d2c0 100644 --- a/base/comm/psb_sscatter.F90 +++ b/base/comm/psb_sscatter.F90 @@ -233,14 +233,9 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) 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_sscatterm @@ -468,13 +463,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) 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_sscatterv diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index 231eda6a..5f68d2f0 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -149,12 +149,8 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return + call psb_error_handler(ictxt,err_act) + return end subroutine psb_ssp_allgather diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index c2759ea5..cb8564b3 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -127,7 +127,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,k,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ @@ -160,13 +160,8 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) 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_zgatherm @@ -298,21 +293,21 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) call psb_errpush(info,name) goto 9999 end if - + call psb_realloc(m,globx,info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - + globx(:)=zzero do i=1,desc_a%get_local_rows() call psb_loc_to_glob(i,idx,desc_a,info) globx(idx) = locx(i) end do - + ! adjust overlapped elements do i=1, size(desc_a%ovrlap_elem,1) if (me /= desc_a%ovrlap_elem(i,3)) then @@ -321,19 +316,14 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) globx(idx) = zzero end if end do - + call psb_sum(ictxt,globx(1:m),root=root) 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_zgatherv @@ -446,13 +436,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) 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_zgather_vect diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index 22b61a25..e9b5ac88 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -208,14 +208,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) 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_zhalom @@ -409,14 +404,9 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) 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_zhalov @@ -560,12 +550,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,alpha,work,tran,mode,data) 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_zhalo_vect diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index 70e3472f..b98d189c 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -193,14 +193,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) 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_zovrlm !!$ !!$ Parallel Sparse BLAS version 3.1 @@ -378,14 +373,9 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) 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_zovrlv @@ -508,13 +498,8 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) 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_zovrl_vect diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index 402dc218..33918793 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -233,14 +233,9 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) 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_zscatterm @@ -468,13 +463,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) 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_zscatterv diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index c74f1676..ec85c14b 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -149,12 +149,8 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep 9999 continue call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return + call psb_error_handler(ictxt,err_act) + return end subroutine psb_zsp_allgather diff --git a/base/modules/psb_c_base_mat_mod.f90 b/base/modules/psb_c_base_mat_mod.f90 index cffb6455..7c564b3a 100644 --- a/base/modules/psb_c_base_mat_mod.f90 +++ b/base/modules/psb_c_base_mat_mod.f90 @@ -153,7 +153,7 @@ module psb_c_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_c_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_c_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_c_mv_coo_from_fmt - procedure, pass(a) :: csput_a => psb_c_coo_csput_a + procedure, pass(a) :: csput_a => psb_c_coo_csput_a procedure, pass(a) :: get_diag => psb_c_coo_get_diag procedure, pass(a) :: csgetrow => psb_c_coo_csgetrow procedure, pass(a) :: csgetptn => psb_c_coo_csgetptn diff --git a/base/modules/psb_c_linmap_mod.f90 b/base/modules/psb_c_linmap_mod.f90 index 501552ee..d4045ee9 100644 --- a/base/modules/psb_c_linmap_mod.f90 +++ b/base/modules/psb_c_linmap_mod.f90 @@ -247,10 +247,9 @@ contains ierr(1) = 2 info = psb_err_missing_override_method_ call psb_errpush(info,name,i_err=ierr) - call psb_get_erraction(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_erractionsave(err_act) + + call psb_error_handler(err_act) end select diff --git a/base/modules/psb_check_mod.f90 b/base/modules/psb_check_mod.f90 index c3e41817..12fd8e24 100644 --- a/base/modules/psb_check_mod.f90 +++ b/base/modules/psb_check_mod.f90 @@ -162,13 +162,8 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_chkvect @@ -282,13 +277,8 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_chkglobvect @@ -423,13 +413,8 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_chkmat diff --git a/base/modules/psb_d_base_mat_mod.f90 b/base/modules/psb_d_base_mat_mod.f90 index 4cede13b..b208b97e 100644 --- a/base/modules/psb_d_base_mat_mod.f90 +++ b/base/modules/psb_d_base_mat_mod.f90 @@ -153,7 +153,7 @@ module psb_d_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_d_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_d_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_d_mv_coo_from_fmt - procedure, pass(a) :: csput_a => psb_d_coo_csput_a + procedure, pass(a) :: csput_a => psb_d_coo_csput_a procedure, pass(a) :: get_diag => psb_d_coo_get_diag procedure, pass(a) :: csgetrow => psb_d_coo_csgetrow procedure, pass(a) :: csgetptn => psb_d_coo_csgetptn diff --git a/base/modules/psb_d_linmap_mod.f90 b/base/modules/psb_d_linmap_mod.f90 index 8f92fe5c..8b7583ee 100644 --- a/base/modules/psb_d_linmap_mod.f90 +++ b/base/modules/psb_d_linmap_mod.f90 @@ -247,10 +247,9 @@ contains ierr(1) = 2 info = psb_err_missing_override_method_ call psb_errpush(info,name,i_err=ierr) - call psb_get_erraction(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_erractionsave(err_act) + + call psb_error_handler(err_act) end select diff --git a/base/modules/psb_desc_mod.F90 b/base/modules/psb_desc_mod.F90 index cd3db063..2e68b56a 100644 --- a/base/modules/psb_desc_mod.F90 +++ b/base/modules/psb_desc_mod.F90 @@ -672,15 +672,11 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if +9999 call psb_error_handler(err_act) + return + end subroutine psb_cd_get_list @@ -752,15 +748,10 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if return + end subroutine psb_cd_v_get_list ! @@ -792,18 +783,8 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_ret_) then - return - else - if (ictxt == -1) then - call psb_error() - else - call psb_error(ictxt) - end if - end if +9999 call psb_error_handler(err_act) return end subroutine psb_cdfree @@ -944,15 +925,10 @@ contains call psb_erractionrestore(err_act) return + -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_cdtransfer @@ -1053,14 +1029,8 @@ contains 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_ret_) then - return - else - call psb_error(ictxt) - end if return end subroutine psb_cd_clone @@ -1159,13 +1129,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - Return +9999 call psb_error_handler(ictxt,err_act) + + return end Subroutine psb_cd_get_recv_idx @@ -1208,14 +1174,11 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + + return + end subroutine cd_l2gs1 subroutine cd_l2gs2(idxin,idxout,desc,info,mask,owned) @@ -1248,14 +1211,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + return end subroutine cd_l2gs2 @@ -1288,13 +1246,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + + return end subroutine cd_l2gv1 @@ -1327,13 +1281,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + + return end subroutine cd_l2gv2 @@ -1366,13 +1316,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + + return end subroutine cd_g2ls1 @@ -1406,14 +1352,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + return end subroutine cd_g2ls2 @@ -1446,14 +1387,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + return end subroutine cd_g2lv1 @@ -1488,14 +1424,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + return end subroutine cd_g2lv2 @@ -1529,14 +1460,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + return end subroutine cd_g2ls1_ins @@ -1571,14 +1497,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return - +9999 call psb_error_handler(err_act) + + return end subroutine cd_g2ls2_ins @@ -1613,14 +1534,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + return end subroutine cd_g2lv1_ins @@ -1655,13 +1571,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + + return end subroutine cd_g2lv2_ins @@ -1694,13 +1606,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - Return +9999 call psb_error_handler(err_act) + + return end subroutine cd_fnd_owner diff --git a/base/modules/psb_gen_block_map_mod.f90 b/base/modules/psb_gen_block_map_mod.f90 index af956199..3387f5ae 100644 --- a/base/modules/psb_gen_block_map_mod.f90 +++ b/base/modules/psb_gen_block_map_mod.f90 @@ -1170,12 +1170,10 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + +9999 call psb_error_handler(err_act) + + return end subroutine block_clone @@ -1222,11 +1220,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) + return end subroutine block_reinit @@ -1270,11 +1266,9 @@ contains !!$ call psb_erractionrestore(err_act) !!$ return !!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act /= psb_act_ret_) then -!!$ call psb_error() -!!$ end if +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ !!$ return !!$ end subroutine block_reinit !!$ diff --git a/base/modules/psb_glist_map_mod.f90 b/base/modules/psb_glist_map_mod.f90 index ad9fc69e..4c1aa83f 100644 --- a/base/modules/psb_glist_map_mod.f90 +++ b/base/modules/psb_glist_map_mod.f90 @@ -241,11 +241,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) + return end subroutine glist_clone diff --git a/base/modules/psb_hash_map_mod.f90 b/base/modules/psb_hash_map_mod.f90 index 41723041..ebd4cd8f 100644 --- a/base/modules/psb_hash_map_mod.f90 +++ b/base/modules/psb_hash_map_mod.f90 @@ -715,14 +715,8 @@ contains 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_ret_) then - return - else - call psb_error(ictxt) - end if return end subroutine hash_g2lv1_ins @@ -1421,12 +1415,10 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + +9999 call psb_error_handler(err_act) + + return end subroutine hash_clone @@ -1485,7 +1477,7 @@ contains call idxmap%g2lip_ins(idx(nr+1:nc),info,lidx=lidx(nr+1:nc)) end if - + if (info /= psb_success_) then info = psb_err_from_subroutine_ call psb_errpush(info,name) @@ -1494,11 +1486,9 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) + return end subroutine hash_reinit diff --git a/base/modules/psb_indx_map_mod.f90 b/base/modules/psb_indx_map_mod.f90 index ebebba42..8cd47d71 100644 --- a/base/modules/psb_indx_map_mod.f90 +++ b/base/modules/psb_indx_map_mod.f90 @@ -462,9 +462,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_l2gs1 @@ -490,10 +488,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine base_l2gs2 @@ -517,9 +512,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_l2gv1 @@ -543,9 +536,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_l2gv2 @@ -570,9 +561,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_g2ls1 @@ -598,9 +587,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_g2ls2 @@ -625,9 +612,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_g2lv1 @@ -653,9 +638,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return @@ -682,9 +665,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_g2ls1_ins @@ -710,9 +691,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_g2ls2_ins @@ -738,9 +717,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_g2lv1_ins @@ -766,9 +743,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_g2lv2_ins @@ -791,9 +766,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_asb @@ -849,9 +822,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_init_vl @@ -875,9 +846,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_clone @@ -901,9 +870,7 @@ contains call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_error_handler(err_act) return end subroutine base_reinit diff --git a/base/modules/psb_list_map_mod.f90 b/base/modules/psb_list_map_mod.f90 index 14326d97..f1360182 100644 --- a/base/modules/psb_list_map_mod.f90 +++ b/base/modules/psb_list_map_mod.f90 @@ -698,11 +698,8 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if +9999 call psb_error_handler(err_act) + return end subroutine list_clone diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index 5a2e4a8e..e00e8176 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -32,7 +32,7 @@ module psb_realloc_mod use psb_const_mod implicit none - + ! ! psb_realloc will reallocate the input array to have exactly ! the size specified, possibly shortening it. @@ -86,7 +86,7 @@ module psb_realloc_mod module procedure psb_rp1p2z2 #endif - end Interface + end Interface psb_realloc interface psb_move_alloc module procedure psb_smove_alloc1d @@ -106,7 +106,7 @@ module psb_realloc_mod module procedure psb_cmove_alloc2d module procedure psb_zmove_alloc1d module procedure psb_zmove_alloc2d - end interface + end interface psb_move_alloc Interface psb_safe_ab_cpy module procedure psb_i_ab_cpy1d,psb_i_ab_cpy2d, & @@ -114,7 +114,7 @@ module psb_realloc_mod & psb_c_ab_cpy1d, psb_c_ab_cpy2d,& & psb_d_ab_cpy1d, psb_d_ab_cpy2d,& & psb_z_ab_cpy1d, psb_z_ab_cpy2d - end Interface + end Interface psb_safe_ab_cpy Interface psb_safe_cpy module procedure psb_i_cpy1d,psb_i_cpy2d, & @@ -122,7 +122,7 @@ module psb_realloc_mod & psb_c_cpy1d, psb_c_cpy2d,& & psb_d_cpy1d, psb_d_cpy2d,& & psb_z_cpy1d, psb_z_cpy2d - end Interface + end Interface psb_safe_cpy ! ! psb_ensure_size will reallocate the input array if necessary @@ -136,7 +136,7 @@ module psb_realloc_mod #endif & psb_scksz1d, psb_ccksz1d, & & psb_dcksz1d, psb_zcksz1d - end Interface + end Interface psb_ensure_size interface psb_size module procedure psb_isize1d, psb_isize2d,& @@ -147,9 +147,9 @@ module psb_realloc_mod & psb_csize1d, psb_csize2d,& & psb_dsize1d, psb_dsize2d,& & psb_zsize1d, psb_zsize2d - end interface - - + end interface psb_size + + Contains subroutine psb_i_ab_cpy1d(vin,vout,info) @@ -191,14 +191,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_i_ab_cpy1d @@ -243,18 +237,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_i_ab_cpy2d - + subroutine psb_s_ab_cpy1d(vin,vout,info) use psb_error_mod @@ -293,18 +281,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_s_ab_cpy1d - + subroutine psb_s_ab_cpy2d(vin,vout,info) use psb_error_mod @@ -345,14 +327,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_s_ab_cpy2d @@ -395,18 +371,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_d_ab_cpy1d - + subroutine psb_d_ab_cpy2d(vin,vout,info) use psb_error_mod @@ -447,18 +417,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_d_ab_cpy2d - + subroutine psb_c_ab_cpy1d(vin,vout,info) use psb_error_mod @@ -497,18 +461,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_c_ab_cpy1d - + subroutine psb_c_ab_cpy2d(vin,vout,info) use psb_error_mod @@ -549,18 +507,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_c_ab_cpy2d - + subroutine psb_z_ab_cpy1d(vin,vout,info) use psb_error_mod @@ -598,18 +550,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_z_ab_cpy1d - + subroutine psb_z_ab_cpy2d(vin,vout,info) use psb_error_mod @@ -649,14 +595,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_z_ab_cpy2d @@ -697,14 +637,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_i_cpy1d @@ -747,18 +681,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_i_cpy2d - + subroutine psb_s_cpy1d(vin,vout,info) use psb_error_mod @@ -795,18 +723,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_s_cpy1d - + subroutine psb_s_cpy2d(vin,vout,info) use psb_error_mod @@ -845,18 +767,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_s_cpy2d - + subroutine psb_d_cpy1d(vin,vout,info) use psb_error_mod @@ -892,18 +808,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_d_cpy1d - + subroutine psb_d_cpy2d(vin,vout,info) use psb_error_mod @@ -942,18 +852,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_d_cpy2d - + subroutine psb_c_cpy1d(vin,vout,info) use psb_error_mod @@ -990,18 +894,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_c_cpy1d - + subroutine psb_c_cpy2d(vin,vout,info) use psb_error_mod @@ -1040,18 +938,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_c_cpy2d - + subroutine psb_z_cpy1d(vin,vout,info) use psb_error_mod @@ -1087,18 +979,12 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_z_cpy1d - + subroutine psb_z_cpy2d(vin,vout,info) use psb_error_mod @@ -1137,23 +1023,17 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return end subroutine psb_z_cpy2d - + function psb_isize1d(vin) integer(psb_ipk_) :: psb_isize1d integer(psb_ipk_), allocatable, intent(in) :: vin(:) - + if (.not.allocated(vin)) then psb_isize1d = 0 else @@ -1178,12 +1058,12 @@ Contains end if end if end function psb_isize2d - + #if !defined(LONG_INTEGERS) function psb_i8size1d(vin) integer(psb_ipk_) :: psb_i8size1d integer(psb_long_int_k_), allocatable, intent(in) :: vin(:) - + if (.not.allocated(vin)) then psb_i8size1d = 0 else @@ -1209,11 +1089,11 @@ Contains end if end function psb_i8size2d #endif - + function psb_ssize1d(vin) integer(psb_ipk_) :: psb_ssize1d real(psb_spk_), allocatable, intent(in) :: vin(:) - + if (.not.allocated(vin)) then psb_ssize1d = 0 else @@ -1243,7 +1123,7 @@ Contains function psb_dsize1d(vin) integer(psb_ipk_) :: psb_dsize1d real(psb_dpk_), allocatable, intent(in) :: vin(:) - + if (.not.allocated(vin)) then psb_dsize1d = 0 else @@ -1270,11 +1150,11 @@ Contains end if end function psb_dsize2d - + function psb_csize1d(vin) integer(psb_ipk_) :: psb_csize1d complex(psb_spk_), allocatable, intent(in) :: vin(:) - + if (.not.allocated(vin)) then psb_csize1d = 0 else @@ -1299,11 +1179,11 @@ Contains end if end if end function psb_csize2d - + function psb_zsize1d(vin) integer(psb_ipk_) :: psb_zsize1d complex(psb_dpk_), allocatable, intent(in) :: vin(:) - + if (.not.allocated(vin)) then psb_zsize1d = 0 else @@ -1352,7 +1232,7 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - + If (len > psb_size(v)) Then if (present(newsz)) then isz = (max(len+1,newsz)) @@ -1364,7 +1244,7 @@ Contains endif endif call psb_realloc(isz,v,info,pad=pad) - + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1375,14 +1255,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return @@ -1411,7 +1285,7 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - + If (len > psb_size(v)) Then if (present(newsz)) then isz = (max(len+1,newsz)) @@ -1423,7 +1297,7 @@ Contains endif endif call psb_realloc(isz,v,info,pad=pad) - + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') @@ -1434,14 +1308,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return End Subroutine psb_i8cksz1d @@ -1469,7 +1337,7 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - + If (len > psb_size(v)) Then if (present(newsz)) then isz = (max(len+1,newsz)) @@ -1492,14 +1360,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return @@ -1527,7 +1389,7 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - + If (len > psb_size(v)) Then if (present(newsz)) then isz = (max(len+1,newsz)) @@ -1550,14 +1412,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return @@ -1586,7 +1442,7 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - + If (len > psb_size(v)) Then if (present(newsz)) then isz = (max(len+1,newsz)) @@ -1608,14 +1464,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return @@ -1644,7 +1494,7 @@ Contains info=psb_err_from_subroutine_ goto 9999 end if - + If (len > psb_size(v)) Then if (present(newsz)) then isz = (max(len+1,newsz)) @@ -1666,14 +1516,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return @@ -1754,15 +1598,10 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if - return + call psb_error_handler(err_act) + return End Subroutine psb_reallocate1i @@ -1832,13 +1671,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocate1s @@ -1909,13 +1742,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocate1d @@ -1986,13 +1813,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocate1c @@ -2062,13 +1883,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocate1z @@ -2159,13 +1974,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocates2 @@ -2255,13 +2064,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocated2 @@ -2352,13 +2155,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocatec2 @@ -2448,13 +2245,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocatez2 @@ -2543,13 +2334,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocatei2 @@ -2630,13 +2415,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return @@ -2725,13 +2504,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocatei8_2 @@ -2772,14 +2545,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return End Subroutine psb_reallocate2i @@ -2824,14 +2591,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return End Subroutine psb_reallocate2i1s @@ -2872,14 +2633,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return End Subroutine psb_reallocate2i1d @@ -2921,14 +2676,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return End Subroutine psb_reallocate2i1c @@ -2967,14 +2716,8 @@ Contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if return End Subroutine psb_reallocate2i1z @@ -2986,13 +2729,13 @@ Contains ! info=psb_success_ #ifdef HAVE_MOVE_ALLOC - - call move_alloc(vin,vout) + + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) if (info /= psb_success_) return @@ -3010,14 +2753,14 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return - + allocate(vout(lbound(vin,1):ubound(vin,1),& & lbound(vin,2):ubound(vin,2)),stat=info) if (info /= psb_success_) return @@ -3034,13 +2777,13 @@ Contains ! info=psb_success_ #ifdef HAVE_MOVE_ALLOC - - call move_alloc(vin,vout) + + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) if (info /= psb_success_) return @@ -3058,14 +2801,14 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return - + allocate(vout(lbound(vin,1):ubound(vin,1),& & lbound(vin,2):ubound(vin,2)),stat=info) if (info /= psb_success_) return @@ -3083,12 +2826,12 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) if (info /= psb_success_) return @@ -3106,14 +2849,14 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return - + allocate(vout(lbound(vin,1):ubound(vin,1),& & lbound(vin,2):ubound(vin,2)),stat=info) if (info /= psb_success_) return @@ -3131,12 +2874,12 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) if (info /= psb_success_) return @@ -3154,14 +2897,14 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return - + allocate(vout(lbound(vin,1):ubound(vin,1),& & lbound(vin,2):ubound(vin,2)),stat=info) if (info /= psb_success_) return @@ -3179,12 +2922,12 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) if (info /= psb_success_) return @@ -3202,14 +2945,14 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return - + allocate(vout(lbound(vin,1):ubound(vin,1),& & lbound(vin,2):ubound(vin,2)),stat=info) if (info /= psb_success_) return @@ -3228,12 +2971,12 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) if (info /= psb_success_) return @@ -3251,14 +2994,14 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return - + allocate(vout(lbound(vin,1):ubound(vin,1),& & lbound(vin,2):ubound(vin,2)),stat=info) if (info /= psb_success_) return @@ -3278,12 +3021,12 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) if (info /= psb_success_) return @@ -3301,14 +3044,14 @@ Contains info=psb_success_ #ifdef HAVE_MOVE_ALLOC - call move_alloc(vin,vout) + call move_alloc(vin,vout) #else if (allocated(vout)) then deallocate(vout,stat=info) - end if + end if if (.not.allocated(vin) ) return - + allocate(vout(lbound(vin,1):ubound(vin,1),& & lbound(vin,2):ubound(vin,2)),stat=info) if (info /= psb_success_) return @@ -3392,13 +3135,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return @@ -3484,13 +3221,7 @@ Contains 9999 continue info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if + call psb_error_handler(err_act) return End Subroutine psb_reallocatei4_2 @@ -3828,7 +3559,7 @@ Contains integer(psb_ipk_), allocatable, intent(out) :: at(:,:) integer(psb_ipk_) :: i,j,ib, ii integer(psb_ipk_), parameter :: nb=32 - + nr = size(a,1) nc = size(a,2) allocate(at(nc,nr)) @@ -3849,7 +3580,7 @@ Contains real(psb_dpk_), allocatable, intent(out) :: at(:,:) integer(psb_ipk_) :: i,j,ib, ii integer(psb_ipk_), parameter :: nb=32 - + nr = size(a,1) nc = size(a,2) allocate(at(nc,nr)) diff --git a/base/modules/psb_repl_map_mod.f90 b/base/modules/psb_repl_map_mod.f90 index 45d260d4..050ce3a5 100644 --- a/base/modules/psb_repl_map_mod.f90 +++ b/base/modules/psb_repl_map_mod.f90 @@ -798,11 +798,8 @@ contains call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if +9999 call psb_error_handler(err_act) + return end subroutine repl_clone diff --git a/base/modules/psb_s_base_mat_mod.f90 b/base/modules/psb_s_base_mat_mod.f90 index caccad77..377a168c 100644 --- a/base/modules/psb_s_base_mat_mod.f90 +++ b/base/modules/psb_s_base_mat_mod.f90 @@ -153,7 +153,7 @@ module psb_s_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_s_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_s_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_s_mv_coo_from_fmt - procedure, pass(a) :: csput_a => psb_s_coo_csput_a + procedure, pass(a) :: csput_a => psb_s_coo_csput_a procedure, pass(a) :: get_diag => psb_s_coo_get_diag procedure, pass(a) :: csgetrow => psb_s_coo_csgetrow procedure, pass(a) :: csgetptn => psb_s_coo_csgetptn diff --git a/base/modules/psb_s_linmap_mod.f90 b/base/modules/psb_s_linmap_mod.f90 index 0730fc11..341f3ac1 100644 --- a/base/modules/psb_s_linmap_mod.f90 +++ b/base/modules/psb_s_linmap_mod.f90 @@ -247,10 +247,9 @@ contains ierr(1) = 2 info = psb_err_missing_override_method_ call psb_errpush(info,name,i_err=ierr) - call psb_get_erraction(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_erractionsave(err_act) + + call psb_error_handler(err_act) end select diff --git a/base/modules/psb_serial_mod.f90 b/base/modules/psb_serial_mod.f90 index 3f6328ca..2adfcd36 100644 --- a/base/modules/psb_serial_mod.f90 +++ b/base/modules/psb_serial_mod.f90 @@ -325,7 +325,6 @@ contains end do end if return - return end subroutine zrot ! ! diff --git a/base/modules/psb_z_base_mat_mod.f90 b/base/modules/psb_z_base_mat_mod.f90 index 0ef6a021..b900bb94 100644 --- a/base/modules/psb_z_base_mat_mod.f90 +++ b/base/modules/psb_z_base_mat_mod.f90 @@ -153,7 +153,7 @@ module psb_z_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_z_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_z_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_z_mv_coo_from_fmt - procedure, pass(a) :: csput_a => psb_z_coo_csput_a + procedure, pass(a) :: csput_a => psb_z_coo_csput_a procedure, pass(a) :: get_diag => psb_z_coo_get_diag procedure, pass(a) :: csgetrow => psb_z_coo_csgetrow procedure, pass(a) :: csgetptn => psb_z_coo_csgetptn diff --git a/base/modules/psb_z_linmap_mod.f90 b/base/modules/psb_z_linmap_mod.f90 index 150bc99b..abe87ad7 100644 --- a/base/modules/psb_z_linmap_mod.f90 +++ b/base/modules/psb_z_linmap_mod.f90 @@ -247,10 +247,9 @@ contains ierr(1) = 2 info = psb_err_missing_override_method_ call psb_errpush(info,name,i_err=ierr) - call psb_get_erraction(err_act) - if (err_act /= psb_act_ret_) then - call psb_error() - end if + call psb_erractionsave(err_act) + + call psb_error_handler(err_act) end select diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index a35f5241..d08112f4 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -55,17 +55,14 @@ subroutine psb_c_base_cp_to_coo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_cp_to_coo @@ -83,17 +80,14 @@ subroutine psb_c_base_cp_from_coo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_cp_from_coo @@ -131,14 +125,8 @@ subroutine psb_c_base_cp_to_fmt(a,b,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return return end subroutine psb_c_base_cp_to_fmt @@ -177,13 +165,8 @@ subroutine psb_c_base_cp_from_fmt(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_cp_from_fmt @@ -221,13 +204,8 @@ subroutine psb_c_base_mv_to_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_mv_to_coo @@ -263,13 +241,8 @@ subroutine psb_c_base_mv_from_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_mv_from_coo @@ -342,17 +315,14 @@ subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) character(len=20) :: name='csput' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_csput_a @@ -394,13 +364,8 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_csput_v @@ -428,17 +393,14 @@ subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_csgetrow @@ -536,13 +498,8 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_csgetblk @@ -626,13 +583,8 @@ subroutine psb_c_base_csclip(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_csclip @@ -742,13 +694,8 @@ subroutine psb_c_base_tril(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_tril @@ -852,13 +799,8 @@ subroutine psb_c_base_triu(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_triu @@ -938,17 +880,14 @@ subroutine psb_c_base_mold(a,b,info) character(len=20) :: name='base_mold' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_mold @@ -984,10 +923,8 @@ subroutine psb_c_base_transp_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1024,10 +961,8 @@ subroutine psb_c_base_transc_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return end subroutine psb_c_base_transc_2mat @@ -1058,10 +993,8 @@ subroutine psb_c_base_transp_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1092,10 +1025,8 @@ subroutine psb_c_base_transc_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1131,17 +1062,14 @@ subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_csmm @@ -1161,17 +1089,14 @@ subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_base_csmv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_csmv @@ -1192,17 +1117,14 @@ subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_base_inner_cssm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_inner_cssm @@ -1222,17 +1144,14 @@ subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_base_inner_cssv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_inner_cssv @@ -1365,13 +1284,8 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return @@ -1501,13 +1415,8 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return contains subroutine inner_vscal(n,d,x,y) @@ -1551,17 +1460,14 @@ subroutine psb_c_base_scals(d,a,info) character(len=20) :: name='c_scals' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_scals @@ -1581,17 +1487,14 @@ subroutine psb_c_base_scal(d,a,info,side) character(len=20) :: name='c_scal' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_c_base_scal @@ -1611,19 +1514,15 @@ function psb_c_base_maxval(a) result(res) character(len=20) :: name='maxval' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) + res = szero ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = szero - - return + call psb_error_handler(err_act) end function psb_c_base_maxval @@ -1661,13 +1560,8 @@ function psb_c_base_csnmi(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_c_base_csnmi @@ -1705,13 +1599,8 @@ function psb_c_base_csnm1(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_c_base_csnm1 @@ -1728,18 +1617,14 @@ subroutine psb_c_base_rowsum(d,a) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_c_base_rowsum @@ -1755,18 +1640,14 @@ subroutine psb_c_base_arwsum(d,a) character(len=20) :: name='arwsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_c_base_arwsum @@ -1782,18 +1663,14 @@ subroutine psb_c_base_colsum(d,a) character(len=20) :: name='colsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_c_base_colsum @@ -1809,18 +1686,14 @@ subroutine psb_c_base_aclsum(d,a) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_c_base_aclsum @@ -1840,18 +1713,14 @@ subroutine psb_c_base_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_c_base_get_diag @@ -2029,13 +1898,8 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_vect_cssv @@ -2072,15 +1936,9 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return + +9999 call psb_error_handler(err_act) - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_c_base_inner_vect_sv diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index e4be86d7..716e4168 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -55,17 +55,14 @@ subroutine psb_d_base_cp_to_coo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_cp_to_coo @@ -83,17 +80,14 @@ subroutine psb_d_base_cp_from_coo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_cp_from_coo @@ -131,14 +125,8 @@ subroutine psb_d_base_cp_to_fmt(a,b,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return return end subroutine psb_d_base_cp_to_fmt @@ -177,13 +165,8 @@ subroutine psb_d_base_cp_from_fmt(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_cp_from_fmt @@ -221,13 +204,8 @@ subroutine psb_d_base_mv_to_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_mv_to_coo @@ -263,13 +241,8 @@ subroutine psb_d_base_mv_from_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_mv_from_coo @@ -342,17 +315,14 @@ subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) character(len=20) :: name='csput' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_csput_a @@ -394,13 +364,8 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_csput_v @@ -428,17 +393,14 @@ subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_csgetrow @@ -536,13 +498,8 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_csgetblk @@ -626,13 +583,8 @@ subroutine psb_d_base_csclip(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_csclip @@ -742,13 +694,8 @@ subroutine psb_d_base_tril(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_tril @@ -852,13 +799,8 @@ subroutine psb_d_base_triu(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_triu @@ -938,17 +880,14 @@ subroutine psb_d_base_mold(a,b,info) character(len=20) :: name='base_mold' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_mold @@ -984,10 +923,8 @@ subroutine psb_d_base_transp_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1024,10 +961,8 @@ subroutine psb_d_base_transc_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return end subroutine psb_d_base_transc_2mat @@ -1058,10 +993,8 @@ subroutine psb_d_base_transp_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1092,10 +1025,8 @@ subroutine psb_d_base_transc_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1131,17 +1062,14 @@ subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_base_csmm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_csmm @@ -1161,17 +1089,14 @@ subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_base_csmv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_csmv @@ -1192,17 +1117,14 @@ subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_base_inner_cssm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_inner_cssm @@ -1222,17 +1144,14 @@ subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_base_inner_cssv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_inner_cssv @@ -1365,13 +1284,8 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return @@ -1501,13 +1415,8 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return contains subroutine inner_vscal(n,d,x,y) @@ -1551,17 +1460,14 @@ subroutine psb_d_base_scals(d,a,info) character(len=20) :: name='d_scals' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_scals @@ -1581,17 +1487,14 @@ subroutine psb_d_base_scal(d,a,info,side) character(len=20) :: name='d_scal' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_d_base_scal @@ -1611,19 +1514,15 @@ function psb_d_base_maxval(a) result(res) character(len=20) :: name='maxval' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) + res = dzero ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = dzero - - return + call psb_error_handler(err_act) end function psb_d_base_maxval @@ -1661,13 +1560,8 @@ function psb_d_base_csnmi(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_d_base_csnmi @@ -1705,13 +1599,8 @@ function psb_d_base_csnm1(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_d_base_csnm1 @@ -1728,18 +1617,14 @@ subroutine psb_d_base_rowsum(d,a) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_d_base_rowsum @@ -1755,18 +1640,14 @@ subroutine psb_d_base_arwsum(d,a) character(len=20) :: name='arwsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_d_base_arwsum @@ -1782,18 +1663,14 @@ subroutine psb_d_base_colsum(d,a) character(len=20) :: name='colsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_d_base_colsum @@ -1809,18 +1686,14 @@ subroutine psb_d_base_aclsum(d,a) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_d_base_aclsum @@ -1840,18 +1713,14 @@ subroutine psb_d_base_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_d_base_get_diag @@ -2029,13 +1898,8 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_vect_cssv @@ -2072,15 +1936,9 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return + +9999 call psb_error_handler(err_act) - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_d_base_inner_vect_sv diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 1b37a541..238a2e65 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -55,17 +55,14 @@ subroutine psb_s_base_cp_to_coo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_cp_to_coo @@ -83,17 +80,14 @@ subroutine psb_s_base_cp_from_coo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_cp_from_coo @@ -131,14 +125,8 @@ subroutine psb_s_base_cp_to_fmt(a,b,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return return end subroutine psb_s_base_cp_to_fmt @@ -177,13 +165,8 @@ subroutine psb_s_base_cp_from_fmt(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_cp_from_fmt @@ -221,13 +204,8 @@ subroutine psb_s_base_mv_to_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_mv_to_coo @@ -263,13 +241,8 @@ subroutine psb_s_base_mv_from_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_mv_from_coo @@ -342,17 +315,14 @@ subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) character(len=20) :: name='csput' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_csput_a @@ -394,13 +364,8 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_csput_v @@ -428,17 +393,14 @@ subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_csgetrow @@ -536,13 +498,8 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_csgetblk @@ -626,13 +583,8 @@ subroutine psb_s_base_csclip(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_csclip @@ -742,13 +694,8 @@ subroutine psb_s_base_tril(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_tril @@ -852,13 +799,8 @@ subroutine psb_s_base_triu(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_triu @@ -938,17 +880,14 @@ subroutine psb_s_base_mold(a,b,info) character(len=20) :: name='base_mold' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_mold @@ -984,10 +923,8 @@ subroutine psb_s_base_transp_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1024,10 +961,8 @@ subroutine psb_s_base_transc_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return end subroutine psb_s_base_transc_2mat @@ -1058,10 +993,8 @@ subroutine psb_s_base_transp_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1092,10 +1025,8 @@ subroutine psb_s_base_transc_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1131,17 +1062,14 @@ subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_base_csmm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_csmm @@ -1161,17 +1089,14 @@ subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_base_csmv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_csmv @@ -1192,17 +1117,14 @@ subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_base_inner_cssm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_inner_cssm @@ -1222,17 +1144,14 @@ subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_base_inner_cssv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_inner_cssv @@ -1365,13 +1284,8 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return @@ -1501,13 +1415,8 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return contains subroutine inner_vscal(n,d,x,y) @@ -1551,17 +1460,14 @@ subroutine psb_s_base_scals(d,a,info) character(len=20) :: name='s_scals' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_scals @@ -1581,17 +1487,14 @@ subroutine psb_s_base_scal(d,a,info,side) character(len=20) :: name='s_scal' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_s_base_scal @@ -1611,19 +1514,15 @@ function psb_s_base_maxval(a) result(res) character(len=20) :: name='maxval' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) + res = szero ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = szero - - return + call psb_error_handler(err_act) end function psb_s_base_maxval @@ -1661,13 +1560,8 @@ function psb_s_base_csnmi(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_s_base_csnmi @@ -1705,13 +1599,8 @@ function psb_s_base_csnm1(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_s_base_csnm1 @@ -1728,18 +1617,14 @@ subroutine psb_s_base_rowsum(d,a) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_s_base_rowsum @@ -1755,18 +1640,14 @@ subroutine psb_s_base_arwsum(d,a) character(len=20) :: name='arwsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_s_base_arwsum @@ -1782,18 +1663,14 @@ subroutine psb_s_base_colsum(d,a) character(len=20) :: name='colsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_s_base_colsum @@ -1809,18 +1686,14 @@ subroutine psb_s_base_aclsum(d,a) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_s_base_aclsum @@ -1840,18 +1713,14 @@ subroutine psb_s_base_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_s_base_get_diag @@ -2029,13 +1898,8 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_vect_cssv @@ -2072,15 +1936,9 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return + +9999 call psb_error_handler(err_act) - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_s_base_inner_vect_sv diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index 727b3e0a..27db9345 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -55,17 +55,14 @@ subroutine psb_z_base_cp_to_coo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_cp_to_coo @@ -83,17 +80,14 @@ subroutine psb_z_base_cp_from_coo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_cp_from_coo @@ -131,14 +125,8 @@ subroutine psb_z_base_cp_to_fmt(a,b,info) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return return end subroutine psb_z_base_cp_to_fmt @@ -177,13 +165,8 @@ subroutine psb_z_base_cp_from_fmt(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_cp_from_fmt @@ -221,13 +204,8 @@ subroutine psb_z_base_mv_to_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_mv_to_coo @@ -263,13 +241,8 @@ subroutine psb_z_base_mv_from_coo(a,b,info) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_mv_from_coo @@ -342,17 +315,14 @@ subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) character(len=20) :: name='csput' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_csput_a @@ -394,13 +364,8 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_csput_v @@ -428,17 +393,14 @@ subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_csgetrow @@ -536,13 +498,8 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_csgetblk @@ -626,13 +583,8 @@ subroutine psb_z_base_csclip(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_csclip @@ -742,13 +694,8 @@ subroutine psb_z_base_tril(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_tril @@ -852,13 +799,8 @@ subroutine psb_z_base_triu(a,b,info,& call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_triu @@ -938,17 +880,14 @@ subroutine psb_z_base_mold(a,b,info) character(len=20) :: name='base_mold' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_mold @@ -984,10 +923,8 @@ subroutine psb_z_base_transp_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1024,10 +961,8 @@ subroutine psb_z_base_transc_2mat(a,b) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return end subroutine psb_z_base_transc_2mat @@ -1058,10 +993,8 @@ subroutine psb_z_base_transp_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1092,10 +1025,8 @@ subroutine psb_z_base_transc_1mat(a) call psb_erractionrestore(err_act) return -9999 continue - if (err_act /= psb_act_ret_) then - call psb_error() - end if + +9999 call psb_error_handler(err_act) return @@ -1131,17 +1062,14 @@ subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_csmm @@ -1161,17 +1089,14 @@ subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_base_csmv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_csmv @@ -1192,17 +1117,14 @@ subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_base_inner_cssm' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_inner_cssm @@ -1222,17 +1144,14 @@ subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_base_inner_cssv' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_inner_cssv @@ -1365,13 +1284,8 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return @@ -1501,13 +1415,8 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return contains subroutine inner_vscal(n,d,x,y) @@ -1551,17 +1460,14 @@ subroutine psb_z_base_scals(d,a,info) character(len=20) :: name='z_scals' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_scals @@ -1581,17 +1487,14 @@ subroutine psb_z_base_scal(d,a,info,side) character(len=20) :: name='z_scal' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return + call psb_error_handler(err_act) end subroutine psb_z_base_scal @@ -1611,19 +1514,15 @@ function psb_z_base_maxval(a) result(res) character(len=20) :: name='maxval' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) + res = dzero ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - res = dzero - - return + call psb_error_handler(err_act) end function psb_z_base_maxval @@ -1661,13 +1560,8 @@ function psb_z_base_csnmi(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_z_base_csnmi @@ -1705,13 +1599,8 @@ function psb_z_base_csnm1(a) result(res) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end function psb_z_base_csnm1 @@ -1728,18 +1617,14 @@ subroutine psb_z_base_rowsum(d,a) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_z_base_rowsum @@ -1755,18 +1640,14 @@ subroutine psb_z_base_arwsum(d,a) character(len=20) :: name='arwsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_z_base_arwsum @@ -1782,18 +1663,14 @@ subroutine psb_z_base_colsum(d,a) character(len=20) :: name='colsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_z_base_colsum @@ -1809,18 +1686,14 @@ subroutine psb_z_base_aclsum(d,a) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_z_base_aclsum @@ -1840,18 +1713,14 @@ subroutine psb_z_base_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - call psb_get_erraction(err_act) + call psb_erractionsave(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) - if (err_act /= psb_act_ret_) then - call psb_error() - end if - - return + call psb_error_handler(err_act) end subroutine psb_z_base_get_diag @@ -2029,13 +1898,8 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) return -9999 continue - call psb_erractionrestore(err_act) +9999 call psb_error_handler(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_vect_cssv @@ -2072,15 +1936,9 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return + +9999 call psb_error_handler(err_act) - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return end subroutine psb_z_base_inner_vect_sv