diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index 4dfbded91..d5be12f6f 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -65,7 +65,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) name='psb_cgatherm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -73,7 +73,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,7 +81,7 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -117,17 +117,17 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -238,7 +238,7 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) name='psb_cgatherv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -246,7 +246,7 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -254,7 +254,7 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -280,17 +280,17 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 index 544c2a0e9..7bd859919 100644 --- a/base/comm/psb_chalo.f90 +++ b/base/comm/psb_chalo.f90 @@ -77,7 +77,7 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) name='psb_chalom' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -85,7 +85,7 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -132,14 +132,14 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -163,8 +163,8 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -174,8 +174,8 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -191,14 +191,14 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) call psi_swaptran(imode,k,cone,xp,& &desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_zswapdata' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if @@ -298,7 +298,7 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) name='psb_chalov' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -306,7 +306,7 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -337,14 +337,14 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -366,8 +366,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -376,8 +376,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -392,14 +392,14 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data) call psi_swaptran(imode,cone,x(iix:size(x)),& & desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_dSwap...' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if diff --git a/base/comm/psb_covrl.f90 b/base/comm/psb_covrl.f90 index 02b3fc75a..ea34edae5 100644 --- a/base/comm/psb_covrl.f90 +++ b/base/comm/psb_covrl.f90 @@ -86,7 +86,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) name='psb_covrlm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -94,7 +94,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -138,14 +138,14 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -166,8 +166,8 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -180,9 +180,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) call psi_swapdata(mode_,k,cone,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if @@ -285,7 +285,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) name='psb_covrlv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -293,7 +293,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -323,14 +323,14 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -351,8 +351,8 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -365,9 +365,9 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode) call psi_swapdata(mode_,cone,x(:),& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if diff --git a/base/comm/psb_cscatter.F90 b/base/comm/psb_cscatter.F90 index 3fdeb4a4b..7faf2fc1a 100644 --- a/base/comm/psb_cscatter.F90 +++ b/base/comm/psb_cscatter.F90 @@ -72,7 +72,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) name='psb_scatterm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -80,7 +80,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -88,7 +88,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -129,23 +129,23 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow=psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do j=1,k do i=1, nrow @@ -158,8 +158,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) ! root has to gather size information allocate(displ(np),all_dim(np),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -175,8 +175,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) ! root has to gather loc_glob from each process allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -208,7 +208,7 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot) end do - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) @@ -301,7 +301,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) name='psb_scatterv' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) debug_unit = psb_get_debug_unit() @@ -311,7 +311,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -319,7 +319,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -345,24 +345,24 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow idx=desc_a%idxmap%loc_to_glob(i) @@ -411,7 +411,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot) & mpi_complex,locx,nrow,& & mpi_complex,rootrank,icomm,info) - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index d587394a1..d95d7bf55 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -65,7 +65,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) name='psb_dgatherm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -73,7 +73,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,7 +81,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -89,7 +89,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) else root = -1 end if - if (root==-1) then + if (root == -1) then iiroot = psb_root_ else iiroot = root @@ -117,15 +117,15 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -235,7 +235,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) name='psb_dgatherv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -243,7 +243,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -251,7 +251,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -278,15 +278,15 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index 7c5a24bbf..5efbe6a8d 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -77,7 +77,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) name='psb_dhalom' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -85,7 +85,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -134,14 +134,14 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -165,8 +165,8 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -176,8 +176,8 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) aliw=.true. !!$ write(0,*) 'halom ',liwork allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -193,14 +193,14 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) call psi_swaptran(imode,k,done,xp,& &desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_dSwapdata' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if @@ -298,7 +298,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) name='psb_dhalov' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -306,7 +306,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -336,14 +336,14 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -365,8 +365,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -375,8 +375,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -391,14 +391,14 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data) call psi_swaptran(imode,done,x(iix:size(x)),& & desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_swapdata' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index 7a5407b15..442185bbd 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -85,7 +85,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) name='psb_dovrlm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -93,7 +93,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -137,14 +137,14 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -166,8 +166,8 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -180,9 +180,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) call psi_swapdata(mode_,k,done,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if @@ -287,7 +287,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) name='psb_dovrlv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -295,7 +295,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -325,14 +325,14 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -353,8 +353,8 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -367,9 +367,9 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode) call psi_swapdata(mode_,done,x(:),& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index a0293889f..563b24ab6 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -72,7 +72,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) name='psb_scatterm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -80,7 +80,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -88,7 +88,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -129,23 +129,23 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow=psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do j=1,k do i=1, nrow @@ -158,8 +158,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) ! root has to gather size information allocate(displ(np),all_dim(np),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -175,8 +175,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) ! root has to gather loc_glob from each process allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -208,7 +208,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) end do - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) @@ -302,7 +302,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) name='psb_scatterv' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) debug_unit = psb_get_debug_unit() @@ -312,7 +312,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -320,7 +320,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -346,24 +346,24 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow idx=desc_a%idxmap%loc_to_glob(i) @@ -412,7 +412,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) & mpi_double_precision,locx,nrow,& & mpi_double_precision,rootrank,icomm,info) - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index 3262f9e12..0546a2033 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -27,7 +27,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep name='psb_gather' if (psb_get_errstatus().ne.0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_a) @@ -50,8 +50,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep ncg = psb_cd_get_global_rows(desc_a) allocate(nzbr(np), idisp(np),stat=info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& & a_err='integer') goto 9999 @@ -61,8 +61,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = loc_coo%get_nzeros() call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) - if (info == 0) call glob_coo%allocate(nrg,ncg,nzg) - if (info /= 0) goto 9999 + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo @@ -70,15 +70,15 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep call mpi_allgatherv(loc_coo%val,ndx,mpi_double_precision,& & glob_coo%val,nzbr,idisp,& & mpi_double_precision,icomm,info) - if (info == 0) call mpi_allgatherv(loc_coo%ia,ndx,mpi_integer,& + if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,mpi_integer,& & glob_coo%ia,nzbr,idisp,& & mpi_integer,icomm,info) - if (info == 0) call mpi_allgatherv(loc_coo%ja,ndx,mpi_integer,& + if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,mpi_integer,& & glob_coo%ja,nzbr,idisp,& & mpi_integer,icomm,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err=' from mpi_allgatherv') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 end if diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 8cb9c72a2..34dbb361b 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -65,7 +65,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) name='psb_igatherm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -73,7 +73,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,7 +81,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -89,7 +89,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) else root = -1 end if - if (root==-1) then + if (root == -1) then iiroot = psb_root_ else iiroot = root @@ -117,15 +117,15 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -235,7 +235,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) name='psb_igatherv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -243,7 +243,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -251,7 +251,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -278,15 +278,15 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index bfdecb1a2..5fa99e6bf 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -78,7 +78,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) name='psb_ihalom' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -86,7 +86,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -135,14 +135,14 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -168,8 +168,8 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -178,8 +178,8 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -195,13 +195,13 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) call psi_swaptran(imode,k,ione,xp,& & desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then - call psb_errpush(4010,name,a_err='PSI_iSwap...') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='PSI_iSwap...') goto 9999 end if @@ -302,7 +302,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) name='psb_ihalov' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -310,7 +310,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -342,14 +342,14 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -371,8 +371,8 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -381,8 +381,8 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -397,13 +397,13 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data) call psi_swaptran(imode,ione,x(iix:size(x)),& & desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then - call psb_errpush(4010,name,a_err='PSI_iswapdata') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='PSI_iswapdata') goto 9999 end if diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 index 6d0650072..f44a20e6a 100644 --- a/base/comm/psb_iovrl.f90 +++ b/base/comm/psb_iovrl.f90 @@ -85,7 +85,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) name='psb_iovrlm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -93,7 +93,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -137,14 +137,14 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -165,8 +165,8 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -179,9 +179,9 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) call psi_swapdata(mode_,k,ione,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if @@ -286,7 +286,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) name='psb_iovrlv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -294,7 +294,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -324,14 +324,14 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -352,8 +352,8 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -366,9 +366,9 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode) call psi_swapdata(mode_,ione,x(:),& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index c4a7fb3b7..6d37c5f99 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -70,7 +70,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) name='psb_scatterm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -78,7 +78,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -86,7 +86,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -127,23 +127,23 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow=psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do j=1,k do i=1, nrow @@ -156,8 +156,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) ! root has to gather size information allocate(displ(np),all_dim(np),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -173,8 +173,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) ! root has to gather loc_glob from each process allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -206,7 +206,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) end do - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) @@ -299,7 +299,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) name='psb_scatterv' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) debug_unit = psb_get_debug_unit() @@ -309,7 +309,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -317,7 +317,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -343,24 +343,24 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow idx=desc_a%idxmap%loc_to_glob(i) @@ -409,7 +409,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot) & mpi_integer,locx,nrow,& & mpi_integer,rootrank,icomm,info) - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 4794e025d..45314fbcf 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -65,7 +65,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) name='psb_sgatherm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -73,7 +73,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,7 +81,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -89,7 +89,7 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) else root = -1 end if - if (root==-1) then + if (root == -1) then iiroot = psb_root_ else iiroot = root @@ -117,15 +117,15 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -235,7 +235,7 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) name='psb_sgatherv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -243,7 +243,7 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -251,7 +251,7 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -278,15 +278,15 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 index 0c0c340f9..9c87bca37 100644 --- a/base/comm/psb_shalo.f90 +++ b/base/comm/psb_shalo.f90 @@ -77,7 +77,7 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) name='psb_shalom' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -85,7 +85,7 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -134,14 +134,14 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -165,8 +165,8 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -176,8 +176,8 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) aliw=.true. !!$ write(0,*) 'halom ',liwork allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -193,14 +193,14 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) call psi_swaptran(imode,k,sone,xp,& &desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_dSwapdata' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if @@ -298,7 +298,7 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) name='psb_shalov' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -306,7 +306,7 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -336,14 +336,14 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -365,8 +365,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -375,8 +375,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -391,14 +391,14 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data) call psi_swaptran(imode,sone,x(iix:size(x)),& & desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_swapdata' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if diff --git a/base/comm/psb_sovrl.f90 b/base/comm/psb_sovrl.f90 index 8aa7e0e45..d6d36568e 100644 --- a/base/comm/psb_sovrl.f90 +++ b/base/comm/psb_sovrl.f90 @@ -85,7 +85,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) name='psb_sovrlm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -93,7 +93,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -137,14 +137,14 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -166,8 +166,8 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -180,9 +180,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) call psi_swapdata(mode_,k,sone,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if @@ -287,7 +287,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) name='psb_sovrlv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -295,7 +295,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -325,14 +325,14 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -353,8 +353,8 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -367,9 +367,9 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode) call psi_swapdata(mode_,sone,x(:),& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if diff --git a/base/comm/psb_sscatter.F90 b/base/comm/psb_sscatter.F90 index decbb3d40..5e91d6463 100644 --- a/base/comm/psb_sscatter.F90 +++ b/base/comm/psb_sscatter.F90 @@ -72,7 +72,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) name='psb_scatterm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -80,7 +80,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -88,7 +88,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -129,23 +129,23 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow=psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do j=1,k do i=1, nrow @@ -158,8 +158,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) ! root has to gather size information allocate(displ(np),all_dim(np),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -175,8 +175,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) ! root has to gather loc_glob from each process allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -208,7 +208,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) end do - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) @@ -301,7 +301,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) name='psb_scatterv' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) debug_unit = psb_get_debug_unit() @@ -311,7 +311,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -319,7 +319,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -345,24 +345,24 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow idx=desc_a%idxmap%loc_to_glob(i) @@ -411,7 +411,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot) & mpi_real,locx,nrow,& & mpi_real,rootrank,icomm,info) - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index 0541bb62e..06e3380b0 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -65,7 +65,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) name='psb_zgatherm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -73,7 +73,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,7 +81,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -117,17 +117,17 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -238,7 +238,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) name='psb_zgatherv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -246,7 +246,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -254,7 +254,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -280,17 +280,17 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index 3e710d49c..ea49f4136 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -77,7 +77,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) name='psb_zhalom' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -85,7 +85,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -132,14 +132,14 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -163,8 +163,8 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -174,8 +174,8 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -191,14 +191,14 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data) call psi_swaptran(imode,k,zone,xp,& &desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_zswapdata' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if @@ -298,7 +298,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) name='psb_zhalov' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -306,7 +306,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -337,14 +337,14 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -366,8 +366,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -376,8 +376,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) else aliw=.true. allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -392,14 +392,14 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data) call psi_swaptran(imode,zone,x(iix:size(x)),& & desc_a,iwork,info) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') goto 9999 end if - if(info /= 0) then + if(info /= psb_success_) then ch_err='PSI_dSwap...' - call psb_errpush(4010,name,a_err=ch_err) + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index 0b15b5cf4..4e4819642 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -86,7 +86,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) name='psb_zovrlm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -94,7 +94,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -138,14 +138,14 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -166,8 +166,8 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -180,9 +180,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) call psi_swapdata(mode_,k,zone,xp,& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if @@ -285,7 +285,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) name='psb_zovrlv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -293,7 +293,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -323,14 +323,14 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) ! check vector correctness call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if @@ -351,8 +351,8 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) end if if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -365,9 +365,9 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode) call psi_swapdata(mode_,zone,x(:),& & desc_a,iwork,info,data=psb_comm_ovr_) end if - if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index 1e8f9931f..0c0e967f3 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -71,7 +71,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) name='psb_scatterm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) @@ -79,7 +79,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -87,7 +87,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -128,23 +128,23 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow=psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do j=1,k do i=1, nrow @@ -157,8 +157,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) ! root has to gather size information allocate(displ(np),all_dim(np),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -174,8 +174,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) ! root has to gather loc_glob from each process allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -207,7 +207,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) end do - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) @@ -300,7 +300,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) name='psb_scatterv' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) debug_unit = psb_get_debug_unit() @@ -310,7 +310,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -318,7 +318,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) if (present(iroot)) then root = iroot if((root < -1).or.(root > np)) then - info=30 + info=psb_err_input_value_invalid_i_ int_err(1:2)=(/5,root/) call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -344,24 +344,24 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) ! there should be a global check on k here!!! call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chk(glob)vect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ilx /= 1).or.(iglobx /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) - if ((root == -1).or.(np==1)) then + if ((root == -1).or.(np == 1)) then ! extract my chunk do i=1, nrow idx=desc_a%idxmap%loc_to_glob(i) @@ -410,7 +410,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot) & mpi_double_complex,locx,nrow,& & mpi_double_complex,rootrank,icomm,info) - if (me==root) deallocate(all_dim, l_t_g_all, displ, scatterv) + if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv) end if call psb_erractionrestore(err_act) diff --git a/base/internals/psi_bld_g2lmap.f90 b/base/internals/psi_bld_g2lmap.f90 index 095065178..4f5e5158f 100644 --- a/base/internals/psi_bld_g2lmap.f90 +++ b/base/internals/psi_bld_g2lmap.f90 @@ -58,7 +58,7 @@ subroutine psi_bld_g2lmap(desc,info) integer :: ictxt,n_row character(len=20) :: name,ch_err - info = 0 + info = psb_success_ name = 'psi_bld_g2lmap' call psb_erractionsave(err_act) @@ -70,14 +70,14 @@ subroutine psi_bld_g2lmap(desc,info) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -104,8 +104,8 @@ subroutine psi_bld_g2lmap(desc,info) hmask = hsize - 1 desc%idxmap%hashvsize = hsize desc%idxmap%hashvmask = hmask - if (info ==0) call psb_realloc(hsize+1,desc%idxmap%hashv,info,lb=0) - if (info /= 0) then + if (info == psb_success_) call psb_realloc(hsize+1,desc%idxmap%hashv,info,lb=0) + if (info /= psb_success_) then ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/internals/psi_bld_tmphalo.f90 b/base/internals/psi_bld_tmphalo.f90 index fff63a3dc..4354fbe05 100644 --- a/base/internals/psi_bld_tmphalo.f90 +++ b/base/internals/psi_bld_tmphalo.f90 @@ -64,7 +64,7 @@ subroutine psi_bld_tmphalo(desc,info) integer :: ictxt,n_row character(len=20) :: name,ch_err - info = 0 + info = psb_success_ name = 'psi_bld_tmphalo' call psb_erractionsave(err_act) @@ -76,13 +76,13 @@ subroutine psi_bld_tmphalo(desc,info) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -91,8 +91,8 @@ subroutine psi_bld_tmphalo(desc,info) ! to call fnd_owner. nh = (n_col-n_row) Allocate(helem(max(1,nh)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -101,22 +101,22 @@ subroutine psi_bld_tmphalo(desc,info) end do call psb_map_l2g(helem(1:nh),desc%idxmap,info) - if (info == 0) & + if (info == psb_success_) & & call psi_fnd_owner(nh,helem,hproc,desc,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='fnd_owner') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='fnd_owner') goto 9999 endif if (nh > size(hproc)) then - info=4010 - call psb_errpush(4010,name,a_err='nh > size(hproc)') + info=psb_err_from_subroutine_ + call psb_errpush(psb_err_from_subroutine_,name,a_err='nh > size(hproc)') goto 9999 end if allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if j = 1 diff --git a/base/internals/psi_bld_tmpovrl.f90 b/base/internals/psi_bld_tmpovrl.f90 index 189932a3e..31039f98f 100644 --- a/base/internals/psi_bld_tmpovrl.f90 +++ b/base/internals/psi_bld_tmpovrl.f90 @@ -71,7 +71,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info) integer :: ictxt,n_row, debug_unit, debug_level character(len=20) :: name,ch_err - info = 0 + info = psb_success_ name = 'psi_bld_tmpovrl' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -82,7 +82,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -107,7 +107,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info) allocate(ov_idx(l_ov_ix),ov_el(l_ov_el,3), stat=info) if (info /= psb_no_err_) then - info=4010 + info=psb_err_from_subroutine_ err=info call psb_errpush(err,name,a_err='psb_realloc') goto 9999 @@ -137,7 +137,7 @@ subroutine psi_bld_tmpovrl(iv,desc,info) l_ov_ix = l_ov_ix + 1 ov_idx(l_ov_ix) = -1 call psb_move_alloc(ov_idx,desc%ovrlap_index,info) - if (info == 0) call psb_move_alloc(ov_el,desc%ovrlap_elem,info) + if (info == psb_success_) call psb_move_alloc(ov_el,desc%ovrlap_elem,info) call psb_erractionrestore(err_act) diff --git a/base/internals/psi_compute_size.f90 b/base/internals/psi_compute_size.f90 index 378355770..12ef98c4a 100644 --- a/base/internals/psi_compute_size.f90 +++ b/base/internals/psi_compute_size.f90 @@ -61,19 +61,19 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - info = 0 + info = psb_success_ ictxt = desc_data(psb_ctxt_) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif allocate(counter_dl(0:np-1),counter_recv(0:np-1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -88,7 +88,7 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info) do while (index_in(i) /= -1) proc=index_in(i) if ((proc > np-1).or.(proc < 0)) then - info = 115 + info = psb_err_invalid_pid_arg_ int_err(1) = 11 int_err(2) = proc call psb_errpush(info,name,i_err=int_err) diff --git a/base/internals/psi_crea_bnd_elem.f90 b/base/internals/psi_crea_bnd_elem.f90 index 8ef767e2b..0651122f0 100644 --- a/base/internals/psi_crea_bnd_elem.f90 +++ b/base/internals/psi_crea_bnd_elem.f90 @@ -59,13 +59,13 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info) integer :: i, j, nr, ns, k, err_act character(len=20) :: name - info = 0 + info = psb_success_ name='psi_crea_bnd_elem' call psb_erractionsave(err_act) allocate(work(size(desc_a%halo_index)),stat=info) - if (info /= 0 ) then - info = 4000 + if (info /= psb_success_ ) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -88,8 +88,8 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info) if (.true.) then if (j>=0) then call psb_realloc(j,bndel,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if bndel(1:j) = work(1:j) @@ -100,8 +100,8 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info) end if else call psb_realloc(j+1,bndel,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if bndel(1:j) = work(1:j) diff --git a/base/internals/psi_crea_index.f90 b/base/internals/psi_crea_index.f90 index a13c966b1..da6dc7cfc 100644 --- a/base/internals/psi_crea_index.f90 +++ b/base/internals/psi_crea_index.f90 @@ -75,7 +75,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ name='psi_crea_index' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -84,7 +84,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info ictxt = psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -95,8 +95,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info dl_lda=np+1 allocate(dep_list(max(1,dl_lda),0:np),length_dl(0:np),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -108,8 +108,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info call psi_extract_dep_list(desc_a%matrix_data,index_in,& & dep_list,length_dl,np,max(1,dl_lda),mode,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='extrct_dl') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='extrct_dl') goto 9999 end if @@ -124,8 +124,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info ! ....now i can sort dependency lists. call psi_sort_dl(dep_list,length_dl,np,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_sort_dl') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_sort_dl') goto 9999 end if @@ -139,8 +139,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info & write(debug_unit,*) me,' ',trim(name),': out of psi_desc_index',& & size(index_out) nxch = length_dl(me) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_desc_index') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_desc_index') goto 9999 end if diff --git a/base/internals/psi_crea_ovr_elem.f90 b/base/internals/psi_crea_ovr_elem.f90 index fa22fc00b..82ac130da 100644 --- a/base/internals/psi_crea_ovr_elem.f90 +++ b/base/internals/psi_crea_ovr_elem.f90 @@ -71,7 +71,7 @@ subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_crea_ovr_elem' @@ -85,8 +85,8 @@ subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info) insize = size(desc_overlap) insize = max(1,(insize+1)/2) allocate(telem(insize,3),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 index 4caf8e31b..2bb8f7e6a 100644 --- a/base/internals/psi_cswapdata.F90 +++ b/base/internals/psi_cswapdata.F90 @@ -107,7 +107,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -115,13 +115,13 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -133,14 +133,14 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -192,13 +192,13 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -218,8 +218,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -253,8 +253,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -267,8 +267,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -302,7 +302,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & brvidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -354,7 +354,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_complex,prcid(i),& @@ -379,7 +379,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) p2ptag=ksendid(ictxt,proc_to_comm,me) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& & mpi_complex,prcid(i),& @@ -392,7 +392,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -417,7 +417,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -597,20 +597,20 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -624,13 +624,13 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -684,13 +684,13 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -711,8 +711,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -745,8 +745,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -760,8 +760,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -794,7 +794,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & brvidx,mpi_complex,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -881,7 +881,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -904,7 +904,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -977,13 +977,13 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 index 4bb821a4d..34f91911d 100644 --- a/base/internals/psi_cswaptran.F90 +++ b/base/internals/psi_cswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -139,13 +139,13 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -197,13 +197,13 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -223,8 +223,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -258,8 +258,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -273,8 +273,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -313,7 +313,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -362,7 +362,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_complex,prcid(i),& @@ -385,7 +385,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& @@ -399,7 +399,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -423,7 +423,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -601,7 +601,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -627,13 +627,13 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -687,13 +687,13 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -713,8 +713,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -748,8 +748,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -763,8 +763,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -802,7 +802,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -851,7 +851,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_complex,prcid(i),& @@ -874,7 +874,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& @@ -888,7 +888,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -911,7 +911,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -988,13 +988,13 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_desc_index.F90 b/base/internals/psi_desc_index.F90 index e41ea528e..f2deabebe 100644 --- a/base/internals/psi_desc_index.F90 +++ b/base/internals/psi_desc_index.F90 @@ -136,7 +136,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,& integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ name='psi_desc_index' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -146,7 +146,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,& icomm = psb_cd_get_mpic(desc) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -163,8 +163,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& ! be careful of the inversion ! allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info) - if(info /= 0) then - info=4000 + if(info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -184,8 +184,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& end do ihinsz=i call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='mpi_alltoall') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoall') goto 9999 end if @@ -220,8 +220,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& endif !!$ call psb_ensure_size(ntot,desc_index,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_realloc') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc') goto 9999 end if @@ -230,8 +230,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& call psb_barrier(ictxt) endif allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) - if(info /= 0) then - info=4000 + if(info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -260,8 +260,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& call psb_map_l2g(index_in(i+1:i+nerv),& & sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& & desc%idxmap,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_map_l2g') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_map_l2g') goto 9999 end if @@ -289,8 +289,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& call mpi_alltoallv(sndbuf,sdsz,bsdindx,mpi_integer,& & rcvbuf,rvsz,brvindx,mpi_integer,icomm,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='mpi_alltoallv') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv') goto 9999 end if @@ -317,8 +317,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& desc_index(i) = - 1 deallocate(sdsz,rvsz,bsdindx,brvindx,sndbuf,rcvbuf,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 5f7ba115d..2ba4b4628 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -108,7 +108,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -116,13 +116,13 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -134,14 +134,14 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -193,13 +193,13 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -219,8 +219,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -254,8 +254,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -268,8 +268,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -303,7 +303,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & brvidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -355,7 +355,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_double_precision,prcid(i),& @@ -380,7 +380,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) p2ptag=ksendid(ictxt,proc_to_comm,me) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& & mpi_double_precision,prcid(i),& @@ -393,7 +393,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -418,7 +418,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -499,13 +499,13 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -597,20 +597,20 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -624,13 +624,13 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -684,13 +684,13 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -711,8 +711,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -745,8 +745,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -760,8 +760,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -794,7 +794,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & brvidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -881,7 +881,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -904,7 +904,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -977,13 +977,13 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 400d82878..1d68c7e8b 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -139,13 +139,13 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -197,13 +197,13 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -223,8 +223,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -258,8 +258,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -273,8 +273,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -313,7 +313,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -362,7 +362,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_double_precision,prcid(i),& @@ -385,7 +385,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& @@ -399,7 +399,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -423,7 +423,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -601,7 +601,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -627,13 +627,13 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -684,13 +684,13 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -710,8 +710,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -745,8 +745,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -760,8 +760,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -799,7 +799,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -848,7 +848,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_double_precision,prcid(i),& @@ -871,7 +871,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& @@ -885,7 +885,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -908,7 +908,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -985,13 +985,13 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_exist_ovr_elem.f b/base/internals/psi_exist_ovr_elem.f index 03b85180e..be8efc7ce 100644 --- a/base/internals/psi_exist_ovr_elem.f +++ b/base/internals/psi_exist_ovr_elem.f @@ -33,14 +33,14 @@ C + DIM_LIST,ELEM_SEARCHED) C PURPOSE: -C ======= +C == = ==== C C If ELEM_SEARCHED exist in the list OVR_ELEM returns its position in C the list, else returns -1 C C C INPUT -C ====== +C == = === C OVRLAP_ELEMENT_D.: Contains for all overlap points belonging to C the current process: C 1. overlap point index diff --git a/base/internals/psi_extrct_dl.F90 b/base/internals/psi_extrct_dl.F90 index 46d5f73e1..96c09ecea 100644 --- a/base/internals/psi_extrct_dl.F90 +++ b/base/internals/psi_extrct_dl.F90 @@ -33,19 +33,19 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& & length_dl,np,dl_lda,mode,info) ! internal routine - ! ================ + ! == = ============= ! ! _____called by psi_crea_halo and psi_crea_ovrlap ______ ! ! purpose - ! ======= + ! == = ==== ! process root (pid=0) extracts for each process "k" the ordered list of process ! to which "k" must communicate. this list with its order is extracted from ! desc_str list ! ! ! input - ! ======= + ! == = ==== ! desc_data :integer array ! explanation: ! name explanation @@ -110,7 +110,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& ! if mode =1 then not will be inserted duplicate element in ! a same dependence list ! output - ! ===== + ! == = == ! only for root (pid=0) process: ! dep_list integer array(dl_lda,0:np) ! dependence list dep_list(*,i) is the list of process identifiers to which process i @@ -150,7 +150,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - info = 0 + info = psb_success_ ictxt = desc_data(psb_ctxt_) @@ -199,7 +199,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& endif else if (mode == 0) then if (pointer_dep_list > dl_lda) then - info = 4000 + info = psb_err_alloc_dealloc_ goto 998 endif dep_list(pointer_dep_list,me)=proc @@ -230,7 +230,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& if (j == pointer_dep_list) then ! ...if not found..... if (pointer_dep_list > dl_lda) then - info = 4000 + info = psb_err_alloc_dealloc_ goto 998 endif dep_list(pointer_dep_list,me)=proc @@ -238,7 +238,7 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& endif else if (mode == 0) then if (pointer_dep_list > dl_lda) then - info = 4000 + info = psb_err_alloc_dealloc_ goto 998 endif dep_list(pointer_dep_list,me)=proc @@ -265,16 +265,16 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,& call psb_sum(ictxt,length_dl(0:np)) call psb_get_mpicomm(ictxt,icomm ) allocate(itmp(dl_lda),stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ goto 9999 endif itmp(1:dl_lda) = dep_list(1:dl_lda,me) call mpi_allgather(itmp,dl_lda,mpi_integer,& & dep_list,dl_lda,mpi_integer,icomm,info) deallocate(itmp,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ goto 9999 endif diff --git a/base/internals/psi_fnd_owner.F90 b/base/internals/psi_fnd_owner.F90 index 6086e6f70..a9fde4fc0 100644 --- a/base/internals/psi_fnd_owner.F90 +++ b/base/internals/psi_fnd_owner.F90 @@ -78,7 +78,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx character(len=20) :: name - info = 0 + info = psb_success_ name = 'psi_fnd_owner' call psb_erractionsave(err_act) @@ -92,19 +92,19 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (nv < 0 ) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.(psb_is_ok_desc(desc))) then - call psb_errpush(4010,name,a_err='invalid desc') + call psb_errpush(psb_err_from_subroutine_,name,a_err='invalid desc') goto 9999 end if @@ -118,8 +118,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) & sdsz(0:np-1),sdidx(0:np-1),& & rvsz(0:np-1),rvidx(0:np-1),& & stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -132,8 +132,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) end do hsize = hidx(np+1) Allocate(helem(hsize),hproc(hsize),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -158,9 +158,9 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) if (gettime) then tidx = psb_wtime()-t3 end if - if (info == 140) info = 0 - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_idx_cnv') + if (info == psb_err_iarray_outside_bounds_) info = psb_success_ + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_idx_cnv') goto 9999 end if @@ -190,8 +190,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) isz = sum(rvsz) allocate(answers(isz,2),idxsrch(nv,2),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if j = 0 @@ -221,8 +221,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) ! Now extract the answers for our local query call psb_realloc(nv,iprc,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_realloc') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc') goto 9999 end if last_ih = -1 @@ -241,8 +241,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) if (j == -1) then write(0,*) me,'psi_fnd_owner: searching for ',ih, & & 'not found : ',size(answers,1),':',answers(:,1) - info = 4001 - call psb_errpush(4001,name,a_err='out bounds srch ih') + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') goto 9999 end if end if @@ -253,8 +253,8 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) if (j == -1) then write(0,*) me,'psi_fnd_owner: searching for ',ih, & & 'not found : ',size(answers,1),':',answers(:,1) - info = 4001 - call psb_errpush(4001,name,a_err='out bounds srch ih') + info = psb_err_internal_error_ + call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') goto 9999 end if end if @@ -282,7 +282,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) call psb_amx(ictxt,tamx) call psb_amx(ictxt,tidx) call psb_amx(ictxt,t1) - if (me==psb_root_) then + if (me == psb_root_) then write(*,'(" fnd_owner idx time : ",es10.4)') tidx write(*,'(" fnd_owner amx time : ",es10.4)') tamx write(*,'(" fnd_owner remainedr : ",es10.4)') t1 diff --git a/base/internals/psi_idx_cnv.f90 b/base/internals/psi_idx_cnv.f90 index bb43b0cbd..0adada432 100644 --- a/base/internals/psi_idx_cnv.f90 +++ b/base/internals/psi_idx_cnv.f90 @@ -65,7 +65,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) character(len=20) :: name logical :: owned_ - info = 0 + info = psb_success_ name = 'psb_idx_cnv' call psb_erractionsave(err_act) @@ -78,7 +78,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -176,7 +176,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned) ! hence psi_inner_cnv does the hashing and binary search. ! if (.not.allocated(desc%idxmap%hashv)) then - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid hashv into inner_cnv') end if call psi_inner_cnv(nv,idxin,desc%idxmap%hashvmask,desc%idxmap%hashv,desc%idxmap%glb_lc,mask=mask) @@ -313,7 +313,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) logical, pointer :: mask_(:) logical :: owned_ - info = 0 + info = psb_success_ name = 'psb_idx_cnv' call psb_erractionsave(err_act) @@ -326,7 +326,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/internals/psi_idx_ins_cnv.f90 b/base/internals/psi_idx_ins_cnv.f90 index 30f6863fb..f880a2e15 100644 --- a/base/internals/psi_idx_ins_cnv.f90 +++ b/base/internals/psi_idx_ins_cnv.f90 @@ -69,7 +69,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) integer, parameter :: relocsz=200 character(len=20) :: name,ch_err - info = 0 + info = psb_success_ name = 'psb_idx_ins_cnv' call psb_erractionsave(err_act) @@ -82,7 +82,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) call psb_info(ictxt, me, np) if (.not.psb_is_bld_desc(desc)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -132,24 +132,24 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) if (ncol > isize) then nh = ncol + max(nv,relocsz) call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then + if (info /= psb_success_) then info=1 ch_err='psb_realloc' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if isize = nh endif desc%idxmap%loc_to_glob(nxt) = ip endif - info = 0 + info = psb_success_ else ch_err='SearchInsKeyVal' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if idxin(i) = lip - info = 0 + info = psb_success_ else idxin(i) = -1 end if @@ -175,24 +175,24 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) if (ncol > isize) then nh = ncol + max(nv,relocsz) call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then + if (info /= psb_success_) then info=1 ch_err='psb_realloc' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if isize = nh endif desc%idxmap%loc_to_glob(nxt) = ip endif - info = 0 + info = psb_success_ else ch_err='SearchInsKeyVal' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if idxin(i) = lip - info = 0 + info = psb_success_ enddo endif @@ -249,10 +249,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) if (ncol > isize) then nh = ncol + max(nv,relocsz) call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=3 + if (info /= psb_success_) then + info=psb_err_invalid_ovr_num_ ch_err='psb_realloc' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if isize = nh @@ -262,10 +262,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) if ((pnt_halo+3) > isize) then nh = isize + max(nv,relocsz) call psb_realloc(nh,desc%halo_index,info,pad=-1) - if (info /= 0) then + if (info /= psb_success_) then info=4 ch_err='psb_realloc' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if isize = nh @@ -302,10 +302,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) if (ncol > isize) then nh = ncol + max(nv,relocsz) call psb_realloc(nh,desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=3 + if (info /= psb_success_) then + info=psb_err_invalid_ovr_num_ ch_err='psb_realloc' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if isize = nh @@ -315,10 +315,10 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask) if ((pnt_halo+3) > isize) then nh = isize + max(nv,relocsz) call psb_realloc(nh,desc%halo_index,info,pad=-1) - if (info /= 0) then + if (info /= psb_success_) then info=4 ch_err='psb_realloc' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if isize = nh @@ -423,7 +423,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) integer, parameter :: relocsz=200 character(len=20) :: name,ch_err - info = 0 + info = psb_success_ name = 'psb_idx_ins_cnv' call psb_erractionsave(err_act) @@ -436,7 +436,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index 3cc6c218b..8f6fbbbaf 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -107,7 +107,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -115,13 +115,13 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -133,14 +133,14 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -192,13 +192,13 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -218,8 +218,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -253,8 +253,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -267,8 +267,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -302,7 +302,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & brvidx,mpi_integer,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -354,7 +354,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_integer,prcid(i),& @@ -379,7 +379,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) p2ptag=ksendid(ictxt,proc_to_comm,me) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& & mpi_integer,prcid(i),& @@ -392,7 +392,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -417,7 +417,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -597,20 +597,20 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -624,13 +624,13 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -684,13 +684,13 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -711,8 +711,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -745,8 +745,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -760,8 +760,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -794,7 +794,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & brvidx,mpi_integer,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -881,7 +881,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -904,7 +904,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -977,13 +977,13 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index aff641070..a88bd6ace 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -139,13 +139,13 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -197,13 +197,13 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -223,8 +223,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -258,8 +258,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -273,8 +273,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -313,7 +313,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & sndbuf,sdsz,bsdidx,mpi_integer,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -362,7 +362,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_integer,prcid(i),& @@ -385,7 +385,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& @@ -399,7 +399,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -423,7 +423,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -601,7 +601,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -627,13 +627,13 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -687,13 +687,13 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -713,8 +713,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -748,8 +748,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -763,8 +763,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -802,7 +802,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & sndbuf,sdsz,bsdidx,mpi_integer,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -851,7 +851,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_integer,prcid(i),& @@ -874,7 +874,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& @@ -888,7 +888,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -911,7 +911,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -988,13 +988,13 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_ldsc_pre_halo.f90 b/base/internals/psi_ldsc_pre_halo.f90 index 275f53a4d..80e1c4679 100644 --- a/base/internals/psi_ldsc_pre_halo.f90 +++ b/base/internals/psi_ldsc_pre_halo.f90 @@ -63,7 +63,7 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info) integer :: ictxt,n_row character(len=20) :: name,ch_err - info = 0 + info = psb_success_ name = 'psi_ldsc_pre_halo' call psb_erractionsave(err_act) @@ -75,35 +75,35 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.(psb_is_bld_desc(desc).and.psb_is_large_desc(desc))) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if call psi_bld_g2lmap(desc,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psi_bld_hash' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if ! We no longer need the inner hash structure. call psb_free(desc%idxmap%hash,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psi_bld_tmphalo' - info = 4010 + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (.not.ext_hv) then call psi_bld_tmphalo(desc,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psi_bld_tmphalo' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/internals/psi_sort_dl.f90 b/base/internals/psi_sort_dl.f90 index f07b22925..1f58b7340 100644 --- a/base/internals/psi_sort_dl.f90 +++ b/base/internals/psi_sort_dl.f90 @@ -48,12 +48,12 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info) name='psi_sort_dl' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - info = 0 + info = psb_success_ ndgmx = 0 do i=1,np ndgmx = ndgmx + l_dep_list(i) @@ -75,8 +75,8 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info) call srtlist(dep_list,size(dep_list,1),l_dep_list,np,work(idg),& & work(idgp),work(iupd),work(iedges),work(iidx),work(iich),info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='srtlist') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='srtlist') goto 9999 endif diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 index fbefada03..7668b3484 100644 --- a/base/internals/psi_sswapdata.F90 +++ b/base/internals/psi_sswapdata.F90 @@ -108,7 +108,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -116,13 +116,13 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -134,14 +134,14 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -193,13 +193,13 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -219,8 +219,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -254,8 +254,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -268,8 +268,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -303,7 +303,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & brvidx,mpi_real,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -355,7 +355,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_real,prcid(i),& @@ -380,7 +380,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) p2ptag=ksendid(ictxt,proc_to_comm,me) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& & mpi_real,prcid(i),& @@ -393,7 +393,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -418,7 +418,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -499,13 +499,13 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -597,20 +597,20 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -624,13 +624,13 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -684,13 +684,13 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -711,8 +711,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -745,8 +745,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -760,8 +760,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -794,7 +794,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & brvidx,mpi_real,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -881,7 +881,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -904,7 +904,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -977,13 +977,13 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 index 558796691..67c4617b2 100644 --- a/base/internals/psi_sswaptran.F90 +++ b/base/internals/psi_sswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -139,13 +139,13 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -197,13 +197,13 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -223,8 +223,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -258,8 +258,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -273,8 +273,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -313,7 +313,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -362,7 +362,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_real,prcid(i),& @@ -385,7 +385,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& @@ -399,7 +399,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -423,7 +423,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -601,7 +601,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -627,13 +627,13 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -684,13 +684,13 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -710,8 +710,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -745,8 +745,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -760,8 +760,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -799,7 +799,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -848,7 +848,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_real,prcid(i),& @@ -871,7 +871,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& @@ -885,7 +885,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -908,7 +908,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -985,13 +985,13 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index 53d4ce120..3f8ad7ce9 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -107,7 +107,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) @@ -115,13 +115,13 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -133,14 +133,14 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -192,13 +192,13 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_data' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -218,8 +218,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -253,8 +253,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -267,8 +267,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -302,7 +302,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & brvidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -354,7 +354,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & mpi_double_complex,prcid(i),& @@ -379,7 +379,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nesd = idx(pnti+nerv+psb_n_elem_send_) p2ptag=ksendid(ictxt,proc_to_comm,me) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then call mpi_rsend(sndbuf(snd_pt),n*nesd,& & mpi_double_complex,prcid(i),& @@ -392,7 +392,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -417,7 +417,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -597,20 +597,20 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) integer, pointer :: d_idx(:) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -624,13 +624,13 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -684,13 +684,13 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_datav' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -711,8 +711,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -745,8 +745,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -760,8 +760,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -794,7 +794,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & brvidx,mpi_double_complex,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -881,7 +881,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -904,7 +904,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -977,13 +977,13 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 29dfef0c9..056701396 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -112,7 +112,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) @@ -121,13 +121,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -139,13 +139,13 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -197,13 +197,13 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -223,8 +223,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -258,8 +258,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -273,8 +273,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -313,7 +313,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -362,7 +362,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),n*nesd,& & mpi_double_complex,prcid(i),& @@ -385,7 +385,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& @@ -399,7 +399,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -423,7 +423,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -498,13 +498,13 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -601,7 +601,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) integer :: int_err(5) character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tranv' call psb_erractionsave(err_act) @@ -609,13 +609,13 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) icomm = psb_cd_get_mpic(desc_a) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -627,13 +627,13 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) end if call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) - if (info /= 0) then - call psb_errpush(4001,name,a_err='psb_cd_get_list') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -687,13 +687,13 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i #endif character(len=20) :: name - info = 0 + info = psb_success_ name='psi_swap_tran' call psb_erractionsave(err_act) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -713,8 +713,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& & stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -748,8 +748,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if end if @@ -763,8 +763,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i albf=.false. else allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if albf=.true. @@ -802,7 +802,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -851,7 +851,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm/=me)) then + if ((nesd>0).and.(proc_to_comm /= me)) then p2ptag = krecvid(ictxt,proc_to_comm,me) call mpi_irecv(sndbuf(snd_pt),nesd,& & mpi_double_complex,prcid(i),& @@ -874,7 +874,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - if ((nerv>0).and.(proc_to_comm/=me)) then + if ((nerv>0).and.(proc_to_comm /= me)) then p2ptag=ksendid(ictxt,proc_to_comm,me) if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& @@ -888,7 +888,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -911,7 +911,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret - info=400 + info=psb_err_mpi_error_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -988,13 +988,13 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i else deallocate(rvhd,prcid,stat=info) end if - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if diff --git a/base/internals/srtlist.f b/base/internals/srtlist.f index 77dd7ab66..85df29336 100644 --- a/base/internals/srtlist.f +++ b/base/internals/srtlist.f @@ -155,7 +155,7 @@ c$$$ write(0,*) 'SRTLIST Input :',i,ip write(0,*) 'SRTLIST: Edge:',ix,edges(1,ix), + edges(2,ix),dgp(ix) enddo - info = 30 + info = psb_err_input_value_invalid_i_ return ENDIF call psb_msort(ich(1:nch)) diff --git a/base/modules/psb_base_mat_mod.f03 b/base/modules/psb_base_mat_mod.f03 index 315233d5f..7597e64e7 100644 --- a/base/modules/psb_base_mat_mod.f03 +++ b/base/modules/psb_base_mat_mod.f03 @@ -14,12 +14,12 @@ module psb_base_mat_mod integer, allocatable :: aux(:) contains - ! ==================================== + ! == = ================================= ! ! Getters ! ! - ! ==================================== + ! == = ================================= procedure, pass(a) :: get_nrows => psb_base_get_nrows procedure, pass(a) :: get_ncols => psb_base_get_ncols procedure, pass(a) :: get_nzeros => psb_base_get_nzeros @@ -39,11 +39,11 @@ module psb_base_mat_mod procedure, pass(a) :: is_triangle => psb_base_is_triangle procedure, pass(a) :: is_unit => psb_base_is_unit - ! ==================================== + ! == = ================================= ! ! Setters ! - ! ==================================== + ! == = ================================= procedure, pass(a) :: set_nrows => psb_base_set_nrows procedure, pass(a) :: set_ncols => psb_base_set_ncols procedure, pass(a) :: set_dupl => psb_base_set_dupl @@ -60,11 +60,11 @@ module psb_base_mat_mod procedure, pass(a) :: set_aux => psb_base_set_aux - ! ==================================== + ! == = ================================= ! ! Data management ! - ! ==================================== + ! == = ================================= procedure, pass(a) :: get_neigh => psb_base_get_neigh procedure, pass(a) :: free => psb_base_free procedure, pass(a) :: trim => psb_base_trim diff --git a/base/modules/psb_base_tools_mod.f90 b/base/modules/psb_base_tools_mod.f90 index c8b249be0..730f7412c 100644 --- a/base/modules/psb_base_tools_mod.f90 +++ b/base/modules/psb_base_tools_mod.f90 @@ -212,7 +212,7 @@ contains integer :: info call psb_owned_index(res,idx,desc,info) - if (info /= 0) res=.false. + if (info /= psb_success_) res=.false. psb_is_owned = res end function psb_is_owned @@ -226,7 +226,7 @@ contains integer :: info call psb_local_index(res,idx,desc,info) - if (info /= 0) res=.false. + if (info /= psb_success_) res=.false. psb_is_local = res end function psb_is_local @@ -256,7 +256,7 @@ contains allocate(lx(size(idx)),stat=info) res=.false. - if (info /= 0) return + if (info /= psb_success_) return call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.) res = (lx>0) @@ -288,7 +288,7 @@ contains allocate(lx(size(idx)),stat=info) res=.false. - if (info /= 0) return + if (info /= psb_success_) return call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.) res = (lx>0) @@ -533,7 +533,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_cdall' call psb_erractionsave(err_act) @@ -541,7 +541,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche if (count((/ present(vg),present(vl),& & present(parts),present(nl), present(repl) /)) /= 1) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name,a_err=" vg, vl, parts, nl, repl") goto 999 endif @@ -550,7 +550,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche if (present(parts)) then if (.not.present(mg)) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name) goto 999 end if @@ -563,12 +563,12 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche else if (present(repl)) then if (.not.present(mg)) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name) goto 999 end if if (.not.repl) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name) goto 999 end if @@ -587,8 +587,8 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche else if (present(nl)) then allocate(itmpsz(0:np-1),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 999 endif @@ -604,7 +604,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche endif - if (info /= 0) goto 999 + if (info /= psb_success_) goto 999 call psb_erractionrestore(err_act) return diff --git a/base/modules/psb_c_base_mat_mod.f03 b/base/modules/psb_c_base_mat_mod.f03 index a2224b793..9c1d1d6ca 100644 --- a/base/modules/psb_c_base_mat_mod.f03 +++ b/base/modules/psb_c_base_mat_mod.f03 @@ -102,11 +102,11 @@ module psb_c_base_mat_mod - !=================== + ! == ================= ! ! BASE interfaces ! - !=================== + ! == ================= interface @@ -374,11 +374,11 @@ module psb_c_base_mat_mod - !================= + ! == =============== ! ! COO interfaces ! - !================= + ! == =============== interface subroutine psb_c_coo_reallocate_nz(nz,a) @@ -697,7 +697,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -707,7 +707,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -763,7 +763,7 @@ contains end function c_coo_get_nzeros - !==================================== + ! == ================================== ! ! ! @@ -774,7 +774,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine c_coo_set_nzeros(nz,a) implicit none @@ -785,7 +785,7 @@ contains end subroutine c_coo_set_nzeros - !==================================== + ! == ================================== ! ! ! @@ -795,7 +795,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -818,7 +818,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -829,7 +829,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine c_coo_transp_1mat(a) implicit none diff --git a/base/modules/psb_c_csc_mat_mod.f03 b/base/modules/psb_c_csc_mat_mod.f03 index 2446f6ded..cd60d0095 100644 --- a/base/modules/psb_c_csc_mat_mod.f03 +++ b/base/modules/psb_c_csc_mat_mod.f03 @@ -318,7 +318,7 @@ module psb_c_csc_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -328,7 +328,7 @@ contains ! ! ! - !===================================== + ! == =================================== function c_csc_sizeof(a) result(res) @@ -400,7 +400,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -410,7 +410,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine c_csc_free(a) diff --git a/base/modules/psb_c_csr_mat_mod.f03 b/base/modules/psb_c_csr_mat_mod.f03 index f0efef1f6..e48a31b94 100644 --- a/base/modules/psb_c_csr_mat_mod.f03 +++ b/base/modules/psb_c_csr_mat_mod.f03 @@ -319,7 +319,7 @@ module psb_c_csr_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -329,7 +329,7 @@ contains ! ! ! - !===================================== + ! == =================================== function c_csr_sizeof(a) result(res) @@ -401,7 +401,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -411,7 +411,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine c_csr_free(a) implicit none diff --git a/base/modules/psb_c_mat_mod.f03 b/base/modules/psb_c_mat_mod.f03 index 60a174665..9fe964d6f 100644 --- a/base/modules/psb_c_mat_mod.f03 +++ b/base/modules/psb_c_mat_mod.f03 @@ -108,7 +108,7 @@ module psb_c_mat_mod end interface - !===================================== + ! == =================================== ! ! ! @@ -119,7 +119,7 @@ module psb_c_mat_mod ! ! ! - !===================================== + ! == =================================== interface @@ -506,7 +506,7 @@ module psb_c_mat_mod - !===================================== + ! == =================================== ! ! ! @@ -517,7 +517,7 @@ module psb_c_mat_mod ! ! ! - !===================================== + ! == =================================== interface psb_csmm subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) @@ -597,7 +597,7 @@ module psb_c_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -607,7 +607,7 @@ contains ! ! ! - !===================================== + ! == =================================== function psb_c_sizeof(a) result(res) diff --git a/base/modules/psb_c_tools_mod.f90 b/base/modules/psb_c_tools_mod.f90 index b6ecb1104..cfdfb21e6 100644 --- a/base/modules/psb_c_tools_mod.f90 +++ b/base/modules/psb_c_tools_mod.f90 @@ -235,8 +235,8 @@ Module psb_c_tools_mod !!$ ictxt = psb_cd_get_context(descin) !!$ !!$ call psb_cdcpy(descin,cd_xt,info) -!!$ if (info ==0) call psb_cd_reinit(cd_xt,info) -!!$ if (info /= 0) then +!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info) +!!$ if (info /= psb_success_) then !!$ write(0,*) 'Error on reinitialising the extension map' !!$ call psb_error(ictxt) !!$ call psb_abort(ictxt) diff --git a/base/modules/psb_check_mod.f90 b/base/modules/psb_check_mod.f90 index 0c94bd4a9..1cfed6dbd 100644 --- a/base/modules/psb_check_mod.f90 +++ b/base/modules/psb_check_mod.f90 @@ -82,74 +82,74 @@ contains character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_chkvect' call psb_erractionsave(err_act) if (m < 0) then - info=10 + info=psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m else if (n < 0) then - info=10 + info=psb_err_iarg_neg_ int_err(1) = 3 int_err(2) = n else if ((ix < 1) .and. (m /= 0)) then - info=20 + info=psb_err_iarg_pos_ int_err(1) = 4 int_err(2) = ix else if ((jx < 1) .and. (n /= 0)) then - info=20 + info=psb_err_iarg_pos_ int_err(1) = 5 int_err(2) = jx else if (psb_cd_get_local_cols(desc_dec) < 0) then - info=40 + info=psb_err_iarg_invalid_i_ int_err(1) = 6 int_err(2) = psb_n_col_ int_err(3) = psb_cd_get_local_cols(desc_dec) else if (psb_cd_get_local_rows(desc_dec) < 0) then - info=40 + info=psb_err_iarg_invalid_i_ int_err(1) = 6 int_err(2) = psb_n_row_ int_err(3) = psb_cd_get_local_cols(desc_dec) else if (lldx < psb_cd_get_local_cols(desc_dec)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1) = 3 int_err(2) = lldx int_err(3) = 6 int_err(4) = psb_n_col_ int_err(5) = psb_cd_get_local_cols(desc_dec) else if (psb_cd_get_global_cols(desc_dec) < m) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 1 int_err(2) = m int_err(3) = 6 int_err(4) = psb_n_ int_err(5) = psb_cd_get_global_cols(desc_dec) else if (psb_cd_get_global_cols(desc_dec) < ix) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 4 int_err(2) = ix int_err(3) = 6 int_err(4) = psb_n_ int_err(5) = psb_cd_get_global_cols(desc_dec) else if (psb_cd_get_global_rows(desc_dec) < jx) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 5 int_err(2) = jx int_err(3) = 6 int_err(4) = psb_m_ int_err(5) = psb_cd_get_global_rows(desc_dec) else if (psb_cd_get_global_cols(desc_dec) < (ix+m-1)) then - info=80 + info=psb_err_iarg2_neg_ int_err(1) = 1 int_err(2) = m int_err(3) = 4 int_err(4) = ix end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -207,74 +207,74 @@ contains character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_chkglobvect' call psb_erractionsave(err_act) if (m < 0) then - info=10 + info=psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m else if (n < 0) then - info=10 + info=psb_err_iarg_neg_ int_err(1) = 3 int_err(2) = n else if ((ix < 1) .and. (m /= 0)) then - info=20 + info=psb_err_iarg_pos_ int_err(1) = 4 int_err(2) = ix else if ((jx < 1) .and. (n /= 0)) then - info=20 + info=psb_err_iarg_pos_ int_err(1) = 5 int_err(2) = jx else if (psb_cd_get_local_cols(desc_dec) < 0) then - info=40 + info=psb_err_iarg_invalid_i_ int_err(1) = 6 int_err(2) = psb_n_col_ int_err(3) = psb_cd_get_local_cols(desc_dec) else if (psb_cd_get_local_rows(desc_dec) < 0) then - info=40 + info=psb_err_iarg_invalid_i_ int_err(1) = 6 int_err(2) = psb_n_row_ int_err(3) = psb_cd_get_local_rows(desc_dec) else if (lldx < psb_cd_get_global_rows(desc_dec)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1) = 3 int_err(2) = lldx int_err(3) = 6 int_err(4) = psb_n_col_ int_err(5) = psb_cd_get_global_rows(desc_dec) else if (psb_cd_get_global_cols(desc_dec) < m) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 1 int_err(2) = m int_err(3) = 6 int_err(4) = psb_n_ int_err(5) = psb_cd_get_global_cols(desc_dec) else if (psb_cd_get_global_cols(desc_dec) < ix) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 4 int_err(2) = ix int_err(3) = 6 int_err(4) = psb_n_ int_err(5) = psb_cd_get_global_cols(desc_dec) else if (psb_cd_get_global_rows(desc_dec) < jx) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 5 int_err(2) = jx int_err(3) = 6 int_err(4) = psb_m_ int_err(5) = psb_cd_get_global_rows(desc_dec) else if (psb_cd_get_global_cols(desc_dec) < (ix+m-1)) then - info=80 + info=psb_err_iarg2_neg_ int_err(1) = 1 int_err(2) = m int_err(3) = 4 int_err(4) = ix end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -331,79 +331,79 @@ contains character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_chkmat' call psb_erractionsave(err_act) if (m < 0) then - info=10 + info=psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m else if (n < 0) then - info=10 + info=psb_err_iarg_neg_ int_err(1) = 3 int_err(2) = n else if ((ia < 1) .and. (m /= 0)) then - info=20 + info=psb_err_iarg_pos_ int_err(1) = 4 int_err(2) = ia else if ((ja < 1) .and. (n /= 0)) then - info=20 + info=psb_err_iarg_pos_ int_err(1) = 5 int_err(2) = ja else if (psb_cd_get_local_cols(desc_dec) < 0) then - info=40 + info=psb_err_iarg_invalid_i_ int_err(1) = 6 int_err(2) = psb_n_col_ int_err(3) = psb_cd_get_local_cols(desc_dec) else if (psb_cd_get_local_rows(desc_dec) < 0) then - info=40 + info=psb_err_iarg_invalid_i_ int_err(1) = 6 int_err(2) = psb_n_row_ int_err(3) = psb_cd_get_local_rows(desc_dec) else if (psb_cd_get_global_rows(desc_dec) < m) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 1 int_err(2) = m int_err(3) = 5 int_err(4) = psb_m_ int_err(5) = psb_cd_get_global_rows(desc_dec) else if (psb_cd_get_global_rows(desc_dec) < m) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 2 int_err(2) = n int_err(3) = 5 int_err(4) = psb_m_ int_err(5) = psb_cd_get_global_rows(desc_dec) else if (psb_cd_get_global_rows(desc_dec) < ia) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 3 int_err(2) = ia int_err(3) = 5 int_err(4) = psb_m_ int_err(5) = psb_cd_get_global_rows(desc_dec) else if (psb_cd_get_global_cols(desc_dec) < ja) then - info=60 + info=psb_err_iarg_not_gteia_ii_ int_err(1) = 4 int_err(2) = ja int_err(3) = 5 int_err(4) = psb_n_ int_err(5) = psb_cd_get_global_cols(desc_dec) else if (psb_cd_get_global_rows(desc_dec) < (ia+m-1)) then - info=80 + info=psb_err_iarg2_neg_ int_err(1) = 1 int_err(2) = m int_err(3) = 3 int_err(4) = ia else if (psb_cd_get_global_cols(desc_dec) < (ja+n-1)) then - info=80 + info=psb_err_iarg2_neg_ int_err(1) = 2 int_err(2) = n int_err(3) = 4 int_err(4) = ja end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if diff --git a/base/modules/psb_const_mod.f90 b/base/modules/psb_const_mod.f90 index 38416cb00..886f56fd6 100644 --- a/base/modules/psb_const_mod.f90 +++ b/base/modules/psb_const_mod.f90 @@ -105,5 +105,71 @@ module psb_const_mod integer, parameter :: psb_dbleint_=2 character(len=5) :: psb_fidef_='CSR' + ! + ! + ! Error constants + integer, parameter, public :: psb_success_=0 + integer, parameter, public :: psb_err_pivot_too_small_=2 + integer, parameter, public :: psb_err_invalid_ovr_num_=3 + integer, parameter, public :: psb_err_invalid_input_=5 + integer, parameter, public :: psb_err_iarg_neg_=10 + integer, parameter, public :: psb_err_iarg_pos_=20 + integer, parameter, public :: psb_err_input_value_invalid_i_=30 + integer, parameter, public :: psb_err_input_asize_invalid_i_=35 + integer, parameter, public :: psb_err_iarg_invalid_i_=40 + integer, parameter, public :: psb_err_iarg_not_gtia_ii_=50 + integer, parameter, public :: psb_err_iarg_not_gteia_ii_=60 + integer, parameter, public :: psb_err_iarg_invalid_value_=70 + integer, parameter, public :: psb_err_asb_nrc_error_=71 + integer, parameter, public :: psb_err_iarg2_neg_=80 + integer, parameter, public :: psb_err_ia2_not_increasing_=90 + integer, parameter, public :: psb_err_ia1_not_increasing_=91 + integer, parameter, public :: psb_err_ia1_badindices_=100 + integer, parameter, public :: psb_err_invalid_args_combination_=110 + integer, parameter, public :: psb_err_invalid_pid_arg_=115 + integer, parameter, public :: psb_err_iarg_n_mbgtian_=120 + integer, parameter, public :: psb_err_duplicate_coo=130 + integer, parameter, public :: psb_err_invalid_input_format_=134 + integer, parameter, public :: psb_err_unsupported_format_=135 + integer, parameter, public :: psb_err_format_unknown_=136 + integer, parameter, public :: psb_err_iarray_outside_bounds_=140 + integer, parameter, public :: psb_err_iarray_outside_process_=150 + integer, parameter, public :: psb_err_forgot_geall_=290 + integer, parameter, public :: psb_err_forgot_spall_=295 + integer, parameter, public :: psb_err_iarg_mbeeiarra_i_=300 + integer, parameter, public :: psb_err_mpi_error_=400 + integer, parameter, public :: psb_err_parm_differs_among_procs_=550 + integer, parameter, public :: psb_err_entry_out_of_bounds_=551 + integer, parameter, public :: psb_err_inconsistent_index_lists_=552 + integer, parameter, public :: psb_err_partfunc_toomuchprocs_=570 + integer, parameter, public :: psb_err_partfunc_toofewprocs_=575 + integer, parameter, public :: psb_err_partfunc_wrong_pid_=580 + integer, parameter, public :: psb_err_no_optional_arg_=581 + integer, parameter, public :: psb_err_arg_m_required_=582 + integer, parameter, public :: psb_err_many_optional_arg_=583 + integer, parameter, public :: psb_err_spmat_invalid_state_=600 + integer, parameter, public :: psb_err_invalid_cd_state_=1122 + integer, parameter, public :: psb_err_invalid_a_and_cd_state_=1123 + integer, parameter, public :: psb_err_blacs_error_=2010 + integer, parameter, public :: psb_err_initerror_neugh_procs_=2011 + integer, parameter, public :: psb_err_blacs_err_gridcols_not_1_=2030 + integer, parameter, public :: psb_err_invalid_matrix_input_state_=2231 + integer, parameter, public :: psb_err_input_no_regen_=2232 + integer, parameter, public :: psb_err_lld_case_not_implemented_=3010 + integer, parameter, public :: psb_err_transpose_unsupported_=3015 + integer, parameter, public :: psb_err_transpose_c_unsupported_=3020 + integer, parameter, public :: psb_err_transpose_not_n_unsupported_=3021 + integer, parameter, public :: psb_err_only_unit_diag_=3022 + integer, parameter, public :: psb_err_ja_nix_ia_niy_unsupported_=3030 + integer, parameter, public :: psb_err_ix_n1_iy_n1_unsupported_=3040 + integer, parameter, public :: psb_err_input_matrix_unassembled_=3110 + integer, parameter, public :: psb_err_alloc_dealloc_=4000 + integer, parameter, public :: psb_err_internal_error_=4001 + integer, parameter, public :: psb_err_from_subroutine_=4010 + integer, parameter, public :: psb_err_from_subroutine_i_=4012 + integer, parameter, public :: psb_err_from_subroutine_ai_=4013 + integer, parameter, public :: psb_err_alloc_request_=4025 + integer, parameter, public :: psb_err_from_subroutine_non_=4011 + integer, parameter, public :: psb_err_invalid_istop_=5001 end module psb_const_mod diff --git a/base/modules/psb_d_base_mat_mod.f03 b/base/modules/psb_d_base_mat_mod.f03 index 1d3c473a2..d1406227a 100644 --- a/base/modules/psb_d_base_mat_mod.f03 +++ b/base/modules/psb_d_base_mat_mod.f03 @@ -102,11 +102,11 @@ module psb_d_base_mat_mod - !=================== + ! == ================= ! ! BASE interfaces ! - !=================== + ! == ================= interface @@ -374,11 +374,11 @@ module psb_d_base_mat_mod - !================= + ! == =============== ! ! COO interfaces ! - !================= + ! == =============== interface subroutine psb_d_coo_reallocate_nz(nz,a) @@ -697,7 +697,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -707,7 +707,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -763,7 +763,7 @@ contains end function d_coo_get_nzeros - !==================================== + ! == ================================== ! ! ! @@ -774,7 +774,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine d_coo_set_nzeros(nz,a) implicit none @@ -785,7 +785,7 @@ contains end subroutine d_coo_set_nzeros - !==================================== + ! == ================================== ! ! ! @@ -795,7 +795,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -818,7 +818,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -829,7 +829,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine d_coo_transp_1mat(a) implicit none diff --git a/base/modules/psb_d_csc_mat_mod.f03 b/base/modules/psb_d_csc_mat_mod.f03 index 7df12cae9..a74fd09ce 100644 --- a/base/modules/psb_d_csc_mat_mod.f03 +++ b/base/modules/psb_d_csc_mat_mod.f03 @@ -318,7 +318,7 @@ module psb_d_csc_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -328,7 +328,7 @@ contains ! ! ! - !===================================== + ! == =================================== function d_csc_sizeof(a) result(res) @@ -400,7 +400,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -410,7 +410,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine d_csc_free(a) diff --git a/base/modules/psb_d_csr_mat_mod.f03 b/base/modules/psb_d_csr_mat_mod.f03 index 89dea12dc..ccc4a9c09 100644 --- a/base/modules/psb_d_csr_mat_mod.f03 +++ b/base/modules/psb_d_csr_mat_mod.f03 @@ -319,7 +319,7 @@ module psb_d_csr_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -329,7 +329,7 @@ contains ! ! ! - !===================================== + ! == =================================== function d_csr_sizeof(a) result(res) @@ -401,7 +401,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -411,7 +411,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine d_csr_free(a) implicit none diff --git a/base/modules/psb_d_mat_mod.f03 b/base/modules/psb_d_mat_mod.f03 index e12953a24..8cdf9cd3d 100644 --- a/base/modules/psb_d_mat_mod.f03 +++ b/base/modules/psb_d_mat_mod.f03 @@ -108,7 +108,7 @@ module psb_d_mat_mod end interface - !===================================== + ! == =================================== ! ! ! @@ -119,7 +119,7 @@ module psb_d_mat_mod ! ! ! - !===================================== + ! == =================================== interface @@ -506,7 +506,7 @@ module psb_d_mat_mod - !===================================== + ! == =================================== ! ! ! @@ -517,7 +517,7 @@ module psb_d_mat_mod ! ! ! - !===================================== + ! == =================================== interface psb_csmm subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) @@ -597,7 +597,7 @@ module psb_d_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -607,7 +607,7 @@ contains ! ! ! - !===================================== + ! == =================================== function psb_d_sizeof(a) result(res) diff --git a/base/modules/psb_d_tools_mod.f90 b/base/modules/psb_d_tools_mod.f90 index 497a01be9..09ec4c313 100644 --- a/base/modules/psb_d_tools_mod.f90 +++ b/base/modules/psb_d_tools_mod.f90 @@ -234,8 +234,8 @@ Module psb_d_tools_mod !!$ !!$ ictxt = psb_cd_get_context(descin) !!$ call psb_cdcpy(descin,cd_xt,info) -!!$ if (info ==0) call psb_cd_reinit(cd_xt,info) -!!$ if (info /= 0) then +!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info) +!!$ if (info /= psb_success_) then !!$ write(0,*) 'Error on reinitialising the extension map' !!$ call psb_error(ictxt) !!$ call psb_abort(ictxt) diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 29c4b0ea5..7f3402d0b 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -474,7 +474,7 @@ contains logical function psb_is_large_desc(desc) type(psb_desc_type), intent(in) :: desc - psb_is_large_desc =(psb_desc_large_==psb_cd_get_size(desc)) + psb_is_large_desc =(psb_desc_large_ == psb_cd_get_size(desc)) end function psb_is_large_desc @@ -542,7 +542,7 @@ contains integer :: dectype psb_is_asb_dec = (dectype == psb_desc_asb_).or.& - & (dectype== psb_desc_repl_).or.(dectype == psb_cd_ovl_asb_) + & (dectype == psb_desc_repl_).or.(dectype == psb_cd_ovl_asb_) end function psb_is_asb_dec @@ -604,7 +604,7 @@ contains psb_cd_get_context = desc%matrix_data(psb_ctxt_) else psb_cd_get_context = -1 - call psb_errpush(1122,'psb_cd_get_context') + call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_context') call psb_error() end if end function psb_cd_get_context @@ -617,7 +617,7 @@ contains psb_cd_get_dectype = desc%matrix_data(psb_dec_type_) else psb_cd_get_dectype = -1 - call psb_errpush(1122,'psb_cd_get_dectype') + call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_dectype') call psb_error() end if @@ -631,7 +631,7 @@ contains psb_cd_get_size = desc%idxmap%state else psb_cd_get_size = -1 - call psb_errpush(1122,'psb_cd_get_size') + call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_size') call psb_error() end if @@ -645,7 +645,7 @@ contains psb_cd_get_mpic = desc%matrix_data(psb_mpi_c_) else psb_cd_get_mpic = -1 - call psb_errpush(1122,'psb_cd_get_mpic') + call psb_errpush(psb_err_invalid_cd_state_,'psb_cd_get_mpic') call psb_error() end if @@ -712,7 +712,7 @@ contains logical, parameter :: debug=.false.,debugprt=.false. character(len=20), parameter :: name='psb_cd_get_list' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -743,7 +743,7 @@ contains case(psb_comm_mov_) ipnt => desc%ovr_mst_idx case default - info=4010 + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='wrong Data selector') goto 9999 end select @@ -778,23 +778,23 @@ contains character(len=*), parameter :: name = 'psb_idxmap_free' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) if (allocated(map%loc_to_glob)) then deallocate(map%loc_to_glob,stat=info) end if - if ((info == 0).and.allocated(map%glob_to_loc)) then + if ((info == psb_success_).and.allocated(map%glob_to_loc)) then deallocate(map%glob_to_loc,stat=info) end if - if ((info == 0).and.allocated(map%hashv)) then + if ((info == psb_success_).and.allocated(map%hashv)) then deallocate(map%hashv,stat=info) end if - if ((info == 0).and.allocated(map%glb_lc)) then + if ((info == psb_success_).and.allocated(map%glb_lc)) then deallocate(map%glb_lc,stat=info) end if - if (info /= 0) call psb_free(map%hash, info) - if (info /= 0) then + if (info /= psb_success_) call psb_free(map%hash, info) + if (info /= psb_success_) then info=2052 call psb_errpush(info,name) goto 9999 @@ -838,13 +838,13 @@ contains character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_cdfree' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return end if @@ -854,7 +854,7 @@ contains call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -869,7 +869,7 @@ contains !deallocate halo_index field deallocate(desc_a%halo_index,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2053 call psb_errpush(info,name) goto 9999 @@ -883,7 +883,7 @@ contains else !deallocate halo_index field deallocate(desc_a%bnd_elem,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2054 call psb_errpush(info,name) goto 9999 @@ -898,7 +898,7 @@ contains !deallocate ovrlap_index field deallocate(desc_a%ovrlap_index,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2055 call psb_errpush(info,name) goto 9999 @@ -906,7 +906,7 @@ contains !deallocate ovrlap_elem field deallocate(desc_a%ovrlap_elem,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2056 call psb_errpush(info,name) goto 9999 @@ -914,7 +914,7 @@ contains !deallocate ovrlap_index field deallocate(desc_a%ovr_mst_idx,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2055 call psb_errpush(info,name) goto 9999 @@ -922,7 +922,7 @@ contains deallocate(desc_a%lprm,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2057 call psb_errpush(info,name) goto 9999 @@ -930,7 +930,7 @@ contains if (allocated(desc_a%idx_space)) then deallocate(desc_a%idx_space,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2056 call psb_errpush(info,name) goto 9999 @@ -985,8 +985,8 @@ contains integer :: debug_level, debug_unit character(len=20) :: name - if (psb_get_errstatus()/=0) return - info = 0 + if (psb_get_errstatus() /= 0) return + info = psb_success_ call psb_erractionsave(err_act) name = 'psb_cdtransfer' debug_unit = psb_get_debug_unit() @@ -997,26 +997,26 @@ contains ! empty. call psb_move_alloc( desc_in%matrix_data , desc_out%matrix_data , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%halo_index , desc_out%halo_index , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%bnd_elem , desc_out%bnd_elem , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%ovrlap_elem , desc_out%ovrlap_elem , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%ovrlap_index, desc_out%ovrlap_index , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%ovr_mst_idx , desc_out%ovr_mst_idx , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%ext_index , desc_out%ext_index , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%lprm , desc_out%lprm , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( desc_in%idx_space , desc_out%idx_space , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc(desc_in%idxmap, desc_out%idxmap,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name) goto 9999 endif @@ -1057,8 +1057,8 @@ contains integer :: debug_level, debug_unit character(len=*), parameter :: name = 'psb_idxmap_transfer' - if (psb_get_errstatus()/=0) return - info = 0 + if (psb_get_errstatus() /= 0) return + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -1068,19 +1068,19 @@ contains map_out%hashvsize = map_in%hashvsize map_out%hashvmask = map_in%hashvmask - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( map_in%loc_to_glob , map_out%loc_to_glob , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( map_in%glob_to_loc , map_out%glob_to_loc , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( map_in%hashv , map_out%hashv , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( map_in%glb_lc , map_out%glb_lc , info) - if (info == 0) & + if (info == psb_success_) & & call psb_move_alloc( map_in%hash , map_out%hash , info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name) goto 9999 endif @@ -1121,8 +1121,8 @@ contains integer :: debug_level, debug_unit character(len=*), parameter :: name = 'psb_idxmap_transfer' - if (psb_get_errstatus()/=0) return - info = 0 + if (psb_get_errstatus() /= 0) return + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -1133,17 +1133,17 @@ contains map_out%hashvmask = map_in%hashvmask call psb_safe_ab_cpy( map_in%loc_to_glob , map_out%loc_to_glob , info) - if (info == 0) & + if (info == psb_success_) & & call psb_safe_ab_cpy( map_in%glob_to_loc , map_out%glob_to_loc , info) - if (info == 0) & + if (info == psb_success_) & & call psb_safe_ab_cpy( map_in%hashv , map_out%hashv , info) - if (info == 0) & + if (info == psb_success_) & & call psb_safe_ab_cpy( map_in%glb_lc , map_out%glb_lc , info) - if (info == 0) & + if (info == psb_success_) & & call psb_hash_copy( map_in%hash , map_out%hash , info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name) goto 9999 endif @@ -1172,15 +1172,15 @@ contains type(psb_idxmap_type) :: map integer :: nc - info = 0 + info = psb_success_ if (.not.allocated(map%loc_to_glob)) then - info = 140 + info = psb_err_iarray_outside_bounds_ idx = -1 return end if nc = size(map%loc_to_glob) if ((idx < 1).or.(idx>nc)) then - info = 140 + info = psb_err_iarray_outside_bounds_ idx = -1 return end if @@ -1195,15 +1195,15 @@ contains type(psb_idxmap_type) :: map integer :: nc - info = 0 + info = psb_success_ if (.not.allocated(map%loc_to_glob)) then - info = 140 + info = psb_err_iarray_outside_bounds_ gidx = -1 return end if nc = size(map%loc_to_glob) if ((idx < 1).or.(idx>nc)) then - info = 140 + info = psb_err_iarray_outside_bounds_ gidx = -1 return end if @@ -1218,10 +1218,10 @@ contains type(psb_idxmap_type) :: map integer :: nc, i, ix - info = 0 - if (size(idx)==0) return + info = psb_success_ + if (size(idx) == 0) return if (.not.allocated(map%loc_to_glob)) then - info = 140 + info = psb_err_iarray_outside_bounds_ idx = -1 return end if @@ -1229,7 +1229,7 @@ contains do i=1, size(idx) ix = idx(i) if ((ix < 1).or.(ix>nc)) then - info = 140 + info = psb_err_iarray_outside_bounds_ idx(i) = -1 else idx(i) = map%loc_to_glob(ix) @@ -1245,11 +1245,11 @@ contains type(psb_idxmap_type) :: map integer :: nc, i, ix - info = 0 - if (size(idx)==0) return + info = psb_success_ + if (size(idx) == 0) return if ((.not.allocated(map%loc_to_glob)).or.& & (size(gidx)nc)) then - info = 140 + info = psb_err_iarray_outside_bounds_ gidx(i) = -1 else gidx(i) = map%loc_to_glob(ix) @@ -1288,7 +1288,7 @@ contains character(len=20) :: name name = 'psb_cd_get_recv_idx' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -1307,7 +1307,7 @@ contains idxlist => desc%ovr_mst_idx write(0,*) 'Warning: unusual request getidx on ovr_mst_idx' case default - info=4010 + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='wrong Data selector') goto 9999 end select @@ -1315,9 +1315,9 @@ contains l_tmp = 3*size(idxlist) allocate(tmp(l_tmp),stat=info) - if (info /= 0) then - info = 4010 - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -1332,8 +1332,8 @@ contains Do j=0,n_elem_recv-1 idx = idxlist(incnt+psb_elem_recv_+j) call psb_ensure_size((outcnt+3),tmp,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index 15bae8ffc..f35b9f4be 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -523,7 +523,7 @@ contains case(3024) write (0,'("Cases DESCRA(1:1)=G not yet implemented. ")') case(3030) - write (0,'("Case ja/=ix or ia/=iy is not yet implemented.")') + write (0,'("Case ja /= ix or ia/=iy is not yet implemented.")') case(3040) write (0,'("Case ix /= 1 or iy /= 1 is not yet implemented.")') case(3050) diff --git a/base/modules/psb_gps_mod.f90 b/base/modules/psb_gps_mod.f90 index b43a6c5c3..705703282 100644 --- a/base/modules/psb_gps_mod.f90 +++ b/base/modules/psb_gps_mod.f90 @@ -122,13 +122,13 @@ CONTAINS idpth = 0 ALLOCATE(SIZEG(NR),STPT(NR), STAT=INFO) - IF(INFO /= 0) THEN + IF(INFO /= psb_success_) THEN WRITE(*,*) 'ERROR! MEMORY ALLOCATION # 1 FAILED IN GPS' STOP END IF ! ALLOCATE(NHIGH(INIT), NLOW(INIT), NACUM(INIT), AUX(INIT), STAT=INFO) - IF(INFO /= 0) THEN + IF(INFO /= psb_success_) THEN WRITE(*,*) 'ERROR! MEMORY ALLOCATION # 2 FAILED IN GPS' STOP END IF @@ -747,7 +747,7 @@ CONTAINS INTEGER :: SZ1,SZ2,INFO call psb_realloc(sz2,vet,info) - IF(INFO /= 0) THEN + IF(INFO /= psb_success_) THEN WRITE(*,*) 'Error! Memory allocation failure in REALLOC' STOP END IF diff --git a/base/modules/psb_hash_mod.f90 b/base/modules/psb_hash_mod.f90 index edc56acca..b4c1c4a42 100644 --- a/base/modules/psb_hash_mod.f90 +++ b/base/modules/psb_hash_mod.f90 @@ -126,7 +126,7 @@ contains use psb_realloc_mod type(psb_hash_type) :: hashin - info = 0 + info = psb_success_ if (allocated(hashin%table)) then deallocate(hashin%table,stat=info) end if @@ -177,11 +177,11 @@ contains if (associated(hashout)) then deallocate(hashout,stat=info) - !if (info /= 0) return + !if (info /= psb_success_) return end if if (associated(hashin)) then allocate(hashout,stat=info) - if (info /= 0) return + if (info /= psb_success_) return call HashCopy(hashin,hashout,info) end if @@ -194,10 +194,10 @@ contains integer :: i,j,k,hsize,nbits, nv - info = 0 + info = psb_success_ nv = size(v) call psb_hash_init(nv,hash,info) - if (info /= 0) return + if (info /= psb_success_) return do i=1,nv call psb_hash_searchinskey(v(i),j,i,hash,info) if ((j /= i).or.(info /= HashOK)) then @@ -215,7 +215,7 @@ contains integer :: i,j,k,hsize,nbits - info = 0 + info = psb_success_ nbits = 12 hsize = 2**nbits ! @@ -238,7 +238,7 @@ contains hash%nsrch = 0 hash%nacc = 0 allocate(hash%table(0:hsize-1,2),stat=info) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Error: memory allocation failure ',hsize info = HashOutOfMemory return @@ -267,7 +267,7 @@ contains nextval = hash%table(i,2) if (key /= HashFreeEntry) then call psb_hash_searchinskey(key,val,nextval,nhash,info) - if (info /= 0) then + if (info /= psb_success_) then info = HashOutOfMemory return end if diff --git a/base/modules/psb_ip_reord_mod.f90 b/base/modules/psb_ip_reord_mod.f90 index 92a417e13..48147439d 100644 --- a/base/modules/psb_ip_reord_mod.f90 +++ b/base/modules/psb_ip_reord_mod.f90 @@ -67,7 +67,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -96,7 +96,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -124,7 +124,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -154,7 +154,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -182,7 +182,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -212,7 +212,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -246,7 +246,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -278,7 +278,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -312,7 +312,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -344,7 +344,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -378,7 +378,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -414,7 +414,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -450,7 +450,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -486,7 +486,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -523,7 +523,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -562,7 +562,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -601,7 +601,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) @@ -640,7 +640,7 @@ contains lp = iaux(0) k = 1 do - if ((lp==0).or.(k>n)) exit + if ((lp == 0).or.(k>n)) exit do if (lp >= k) exit lp = iaux(lp) diff --git a/base/modules/psb_penv_mod.F90 b/base/modules/psb_penv_mod.F90 index 09b2ef763..f5912dc46 100644 --- a/base/modules/psb_penv_mod.F90 +++ b/base/modules/psb_penv_mod.F90 @@ -207,7 +207,7 @@ contains #endif if (present(np)) then if (np_ < np) then - info = 2011 + info = psb_err_initerror_neugh_procs_ call psb_errpush(info,name) call psb_error(ictxt) endif @@ -305,7 +305,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -329,7 +329,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -353,7 +353,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -378,7 +378,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -403,7 +403,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -427,7 +427,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -453,7 +453,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -478,7 +478,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -502,7 +502,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -527,7 +527,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -551,7 +551,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -575,7 +575,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -599,7 +599,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -623,7 +623,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -647,7 +647,7 @@ contains call psb_info(ictxt,iam,np) - if (iam==root_) then + if (iam == root_) then call gebs2d(ictxt,'A',dat) else call gebr2d(ictxt,'A',dat,rrt=root_) @@ -837,9 +837,9 @@ contains if (root_ == -1) then call psb_realloc(size(dat),dat_,info) dat_=dat - if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info) + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat),dat_,info) dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_max,root_,icomm,info) @@ -878,9 +878,9 @@ contains if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_=dat - if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info) + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_max,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_max,root_,icomm,info) @@ -953,10 +953,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat),dat_,info) dat_ = dat - if (info ==0) & + if (info == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info) @@ -995,10 +995,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat - if (info ==0)& + if (info == psb_success_)& & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,icomm,info) @@ -1070,10 +1070,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat),dat_,info) dat_ = dat - if (info ==0) & + if (info == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,icomm,info) @@ -1112,10 +1112,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat - if (info ==0)& + if (info == psb_success_)& & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,icomm,info) @@ -1188,9 +1188,9 @@ contains if (root_ == -1) then call psb_realloc(size(dat),dat_,info) dat_=dat - if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info) + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat),dat_,info) dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_min,root_,icomm,info) @@ -1229,9 +1229,9 @@ contains if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_=dat - if (info ==0) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info) + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),mpi_integer,mpi_min,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_=dat call mpi_reduce(dat_,dat,size(dat),mpi_integer,mpi_min,root_,icomm,info) @@ -1304,10 +1304,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat),dat_,info) dat_ = dat - if (info ==0) & + if (info == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info) @@ -1346,10 +1346,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat - if (info ==0) & + if (info == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,icomm,info) @@ -1423,10 +1423,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat),dat_,info) dat_ = dat - if (info ==0) & + if (info == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,icomm,info) @@ -1465,10 +1465,10 @@ contains if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat - if (info ==0) & + if (info == psb_success_) & & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,icomm,info) else - if (iam==root_) then + if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,info) dat_ = dat call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,icomm,info) @@ -2366,7 +2366,7 @@ contains dat_=dat call mpi_allreduce(dat_,dat,isz,mpi_int8_type,mpi_sum,icomm,info) else - if (iam==root_) then + if (iam == root_) then dat_=dat call mpi_reduce(dat_,dat,isz,mpi_int8_type,mpi_sum,root_,icomm,info) else @@ -2406,7 +2406,7 @@ contains dat_=dat call mpi_allreduce(dat_,dat,1,mpi_int8_type,mpi_sum,icomm,info) else - if (iam==root_) then + if (iam == root_) then dat_=dat call mpi_reduce(dat_,dat,1,mpi_int8_type,mpi_sum,root_,icomm,info) else diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index d80835c1c..d1366d630 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -121,10 +121,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -132,8 +132,8 @@ Contains isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -172,10 +172,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if if (allocated(vin)) then @@ -184,8 +184,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -224,9 +224,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -234,8 +234,8 @@ Contains isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -274,9 +274,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -286,8 +286,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -326,9 +326,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -336,8 +336,8 @@ Contains isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -376,9 +376,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -388,8 +388,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -428,9 +428,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -438,8 +438,8 @@ Contains isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -478,9 +478,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -490,8 +490,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -530,17 +530,17 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -579,9 +579,9 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if if (allocated(vin)) then @@ -590,8 +590,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -631,16 +631,16 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -678,9 +678,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -689,8 +689,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -728,17 +728,17 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -776,9 +776,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -787,8 +787,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -826,16 +826,16 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -873,9 +873,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -884,8 +884,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -923,17 +923,17 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -971,9 +971,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -982,8 +982,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -1021,16 +1021,16 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -1069,9 +1069,9 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if isz1 = size(vin,1) @@ -1079,8 +1079,8 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 @@ -1268,10 +1268,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - info=0 + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -1287,8 +1287,8 @@ Contains endif call psb_realloc(isz,v,info,pad=pad) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 end if @@ -1327,10 +1327,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - info=0 + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -1346,8 +1346,8 @@ Contains endif call psb_realloc(isz,v,info,pad=pad) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 End If @@ -1385,10 +1385,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - info=0 + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -1404,8 +1404,8 @@ Contains endif call psb_realloc(isz,v,info,pad=pad) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 End If @@ -1444,10 +1444,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - info=0 + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -1462,8 +1462,8 @@ Contains endif endif call psb_realloc(isz,v,info,pad=pad) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 end if @@ -1502,10 +1502,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - info=0 + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -1520,8 +1520,8 @@ Contains endif endif call psb_realloc(isz,v,info,pad=pad) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 end if @@ -1561,12 +1561,12 @@ Contains name='psb_dreallocate1i' call psb_erractionsave(err_act) - info=0 + info=psb_success_ if (debug) write(0,*) 'reallocate I',len if (psb_get_errstatus() /= 0) then if (debug) write(0,*) 'reallocate errstatus /= 0' - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if @@ -1587,7 +1587,7 @@ Contains lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then Allocate(tmp(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer') goto 9999 @@ -1600,7 +1600,7 @@ Contains else dim = 0 allocate(rrax(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='integer') goto 9999 @@ -1646,7 +1646,7 @@ Contains name='psb_dreallocate1s' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (debug) write(0,*) 'reallocate S',len if (present(lb)) then @@ -1666,7 +1666,7 @@ Contains lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then Allocate(tmp(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_spk_)') goto 9999 @@ -1677,7 +1677,7 @@ Contains else dim = 0 Allocate(rrax(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_spk_)') goto 9999 @@ -1720,7 +1720,7 @@ Contains name='psb_dreallocate1d' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (debug) write(0,*) 'reallocate D',len if (present(lb)) then @@ -1740,7 +1740,7 @@ Contains lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then Allocate(tmp(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_dpk_)') goto 9999 @@ -1751,7 +1751,7 @@ Contains else dim = 0 Allocate(rrax(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='real(psb_dpk_)') goto 9999 @@ -1795,7 +1795,7 @@ Contains name='psb_dreallocate1c' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (debug) write(0,*) 'reallocate C',len if (present(lb)) then lb_ = lb @@ -1814,7 +1814,7 @@ Contains lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then Allocate(tmp(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_spk_)') goto 9999 @@ -1825,7 +1825,7 @@ Contains else dim = 0 Allocate(rrax(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_spk_)') goto 9999 @@ -1868,7 +1868,7 @@ Contains name='psb_dreallocate1z' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (debug) write(0,*) 'reallocate Z',len if (present(lb)) then lb_ = lb @@ -1887,7 +1887,7 @@ Contains lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then Allocate(tmp(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_dpk_)') goto 9999 @@ -1898,7 +1898,7 @@ Contains else dim = 0 Allocate(rrax(lb_:ub_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len,0,0,0,0/),a_err='complex(psb_dpk_)') goto 9999 @@ -1943,7 +1943,7 @@ Contains name='psb_dreallocates2' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -1977,7 +1977,7 @@ Contains If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& & .or.(lbi2 /= lb2_)) Then Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_spk_)') goto 9999 @@ -1990,7 +1990,7 @@ Contains dim = 0 dim2 = 0 Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_spk_)') goto 9999 @@ -2035,7 +2035,7 @@ Contains name='psb_dreallocated2' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2069,7 +2069,7 @@ Contains If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& & .or.(lbi2 /= lb2_)) Then Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_dpk_)') goto 9999 @@ -2082,7 +2082,7 @@ Contains dim = 0 dim2 = 0 Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='real(psb_dpk_)') goto 9999 @@ -2127,7 +2127,7 @@ Contains name='psb_dreallocatec2' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2161,7 +2161,7 @@ Contains If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& & .or.(lbi2 /= lb2_)) Then Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_spk_)') goto 9999 @@ -2174,7 +2174,7 @@ Contains dim = 0 dim2 = 0 Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_spk_)') goto 9999 @@ -2219,7 +2219,7 @@ Contains name='psb_dreallocatez2' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2253,7 +2253,7 @@ Contains If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& & .or.(lbi2 /= lb2_)) Then Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_dpk_)') goto 9999 @@ -2266,7 +2266,7 @@ Contains dim = 0 dim2 = 0 Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='complex(psb_dpk_)') goto 9999 @@ -2311,7 +2311,7 @@ Contains name='psb_dreallocatei2' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(lb1)) then lb1_ = lb1 else @@ -2344,7 +2344,7 @@ Contains If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& & .or.(lbi2 /= lb2_)) Then Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer') goto 9999 @@ -2357,7 +2357,7 @@ Contains dim = 0 dim2 = 0 Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= 0) then + if (info /= psb_success_) then err=4025 call psb_errpush(err,name,i_err=(/len1*len2,0,0,0,0/),a_err='integer') goto 9999 @@ -2397,21 +2397,21 @@ Contains name='psb_dreallocate2i' call psb_erractionsave(err_act) - info=0 + info=psb_success_ if(psb_get_errstatus() /= 0) then - info = 4010 + info = psb_err_from_subroutine_ goto 9999 end if call psb_dreallocate1i(len,rrax,info,pad=pad) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_dreallocate1i(len,y,info,pad=pad) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 @@ -2449,21 +2449,21 @@ Contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(len,rrax,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,y,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,z,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 @@ -2496,22 +2496,22 @@ Contains name='psb_dreallocate2i1d' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(len,rrax,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,y,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,z,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 @@ -2546,21 +2546,21 @@ Contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(len,rrax,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,y,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,z,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 @@ -2592,21 +2592,21 @@ Contains name='psb_dreallocate2i1z' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(len,rrax,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,y,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 end if call psb_realloc(len,z,info) - if (info /= 0) then + if (info /= psb_success_) then err=4000 call psb_errpush(err,name) goto 9999 @@ -2631,7 +2631,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_smove_alloc1d @@ -2642,7 +2642,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_smove_alloc2d @@ -2653,7 +2653,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_dmove_alloc1d @@ -2664,7 +2664,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_dmove_alloc2d @@ -2675,7 +2675,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_cmove_alloc1d @@ -2686,7 +2686,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_cmove_alloc2d @@ -2697,7 +2697,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_zmove_alloc1d @@ -2708,7 +2708,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_zmove_alloc2d @@ -2719,7 +2719,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_imove_alloc1d @@ -2729,7 +2729,7 @@ Contains integer, intent(out) :: info ! ! - info = 0 + info = psb_success_ call move_alloc(vin,vout) end Subroutine psb_imove_alloc2d diff --git a/base/modules/psb_s_base_mat_mod.f03 b/base/modules/psb_s_base_mat_mod.f03 index b07ed0015..30ce05be5 100644 --- a/base/modules/psb_s_base_mat_mod.f03 +++ b/base/modules/psb_s_base_mat_mod.f03 @@ -102,11 +102,11 @@ module psb_s_base_mat_mod - !=================== + ! == ================= ! ! BASE interfaces ! - !=================== + ! == ================= interface @@ -374,11 +374,11 @@ module psb_s_base_mat_mod - !================= + ! == =============== ! ! COO interfaces ! - !================= + ! == =============== interface subroutine psb_s_coo_reallocate_nz(nz,a) @@ -697,7 +697,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -707,7 +707,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -763,7 +763,7 @@ contains end function s_coo_get_nzeros - !==================================== + ! == ================================== ! ! ! @@ -774,7 +774,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine s_coo_set_nzeros(nz,a) implicit none @@ -785,7 +785,7 @@ contains end subroutine s_coo_set_nzeros - !==================================== + ! == ================================== ! ! ! @@ -795,7 +795,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -818,7 +818,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -829,7 +829,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine s_coo_transp_1mat(a) implicit none diff --git a/base/modules/psb_s_csc_mat_mod.f03 b/base/modules/psb_s_csc_mat_mod.f03 index 0c9064dd5..1ccc36b77 100644 --- a/base/modules/psb_s_csc_mat_mod.f03 +++ b/base/modules/psb_s_csc_mat_mod.f03 @@ -318,7 +318,7 @@ module psb_s_csc_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -328,7 +328,7 @@ contains ! ! ! - !===================================== + ! == =================================== function s_csc_sizeof(a) result(res) @@ -400,7 +400,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -410,7 +410,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine s_csc_free(a) diff --git a/base/modules/psb_s_csr_mat_mod.f03 b/base/modules/psb_s_csr_mat_mod.f03 index 529beb339..5bbbc732e 100644 --- a/base/modules/psb_s_csr_mat_mod.f03 +++ b/base/modules/psb_s_csr_mat_mod.f03 @@ -319,7 +319,7 @@ module psb_s_csr_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -329,7 +329,7 @@ contains ! ! ! - !===================================== + ! == =================================== function s_csr_sizeof(a) result(res) @@ -401,7 +401,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -411,7 +411,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine s_csr_free(a) implicit none diff --git a/base/modules/psb_s_mat_mod.f03 b/base/modules/psb_s_mat_mod.f03 index e70c43c3c..c0a50377c 100644 --- a/base/modules/psb_s_mat_mod.f03 +++ b/base/modules/psb_s_mat_mod.f03 @@ -108,7 +108,7 @@ module psb_s_mat_mod end interface - !===================================== + ! == =================================== ! ! ! @@ -119,7 +119,7 @@ module psb_s_mat_mod ! ! ! - !===================================== + ! == =================================== interface @@ -506,7 +506,7 @@ module psb_s_mat_mod - !===================================== + ! == =================================== ! ! ! @@ -517,7 +517,7 @@ module psb_s_mat_mod ! ! ! - !===================================== + ! == =================================== interface psb_csmm subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) @@ -597,7 +597,7 @@ module psb_s_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -607,7 +607,7 @@ contains ! ! ! - !===================================== + ! == =================================== function psb_s_sizeof(a) result(res) diff --git a/base/modules/psb_s_tools_mod.f90 b/base/modules/psb_s_tools_mod.f90 index 10eb96b4b..353ba4d65 100644 --- a/base/modules/psb_s_tools_mod.f90 +++ b/base/modules/psb_s_tools_mod.f90 @@ -236,8 +236,8 @@ Module psb_s_tools_mod !!$ !!$ ictxt = psb_cd_get_context(descin) !!$ call psb_cdcpy(descin,cd_xt,info) -!!$ if (info ==0) call psb_cd_reinit(cd_xt,info) -!!$ if (info /= 0) then +!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info) +!!$ if (info /= psb_success_) then !!$ write(0,*) 'Error on reinitialising the extension map' !!$ call psb_error(ictxt) !!$ call psb_abort(ictxt) diff --git a/base/modules/psb_z_base_mat_mod.f03 b/base/modules/psb_z_base_mat_mod.f03 index 46c9f138e..a50dc93a7 100644 --- a/base/modules/psb_z_base_mat_mod.f03 +++ b/base/modules/psb_z_base_mat_mod.f03 @@ -102,11 +102,11 @@ module psb_z_base_mat_mod - !=================== + ! == ================= ! ! BASE interfaces ! - !=================== + ! == ================= interface @@ -374,11 +374,11 @@ module psb_z_base_mat_mod - !================= + ! == =============== ! ! COO interfaces ! - !================= + ! == =============== interface subroutine psb_z_coo_reallocate_nz(nz,a) @@ -697,7 +697,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -707,7 +707,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -763,7 +763,7 @@ contains end function z_coo_get_nzeros - !==================================== + ! == ================================== ! ! ! @@ -774,7 +774,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine z_coo_set_nzeros(nz,a) implicit none @@ -785,7 +785,7 @@ contains end subroutine z_coo_set_nzeros - !==================================== + ! == ================================== ! ! ! @@ -795,7 +795,7 @@ contains ! ! ! - !==================================== + ! == ================================== @@ -818,7 +818,7 @@ contains - !==================================== + ! == ================================== ! ! ! @@ -829,7 +829,7 @@ contains ! ! ! - !==================================== + ! == ================================== subroutine z_coo_transp_1mat(a) implicit none diff --git a/base/modules/psb_z_csc_mat_mod.f03 b/base/modules/psb_z_csc_mat_mod.f03 index c9e5bf06c..fc1c960a3 100644 --- a/base/modules/psb_z_csc_mat_mod.f03 +++ b/base/modules/psb_z_csc_mat_mod.f03 @@ -318,7 +318,7 @@ module psb_z_csc_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -328,7 +328,7 @@ contains ! ! ! - !===================================== + ! == =================================== function z_csc_sizeof(a) result(res) @@ -400,7 +400,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -410,7 +410,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine z_csc_free(a) diff --git a/base/modules/psb_z_csr_mat_mod.f03 b/base/modules/psb_z_csr_mat_mod.f03 index 26a89f1bb..0c2feb6ec 100644 --- a/base/modules/psb_z_csr_mat_mod.f03 +++ b/base/modules/psb_z_csr_mat_mod.f03 @@ -319,7 +319,7 @@ module psb_z_csr_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -329,7 +329,7 @@ contains ! ! ! - !===================================== + ! == =================================== function z_csr_sizeof(a) result(res) @@ -401,7 +401,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -411,7 +411,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine z_csr_free(a) implicit none diff --git a/base/modules/psb_z_mat_mod.f03 b/base/modules/psb_z_mat_mod.f03 index a24c37b87..2858ba2f8 100644 --- a/base/modules/psb_z_mat_mod.f03 +++ b/base/modules/psb_z_mat_mod.f03 @@ -108,7 +108,7 @@ module psb_z_mat_mod end interface - !===================================== + ! == =================================== ! ! ! @@ -119,7 +119,7 @@ module psb_z_mat_mod ! ! ! - !===================================== + ! == =================================== interface @@ -506,7 +506,7 @@ module psb_z_mat_mod - !===================================== + ! == =================================== ! ! ! @@ -517,7 +517,7 @@ module psb_z_mat_mod ! ! ! - !===================================== + ! == =================================== interface psb_csmm subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) @@ -597,7 +597,7 @@ module psb_z_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -607,7 +607,7 @@ contains ! ! ! - !===================================== + ! == =================================== function psb_z_sizeof(a) result(res) diff --git a/base/modules/psb_z_tools_mod.f90 b/base/modules/psb_z_tools_mod.f90 index 7234cd028..b72992ecf 100644 --- a/base/modules/psb_z_tools_mod.f90 +++ b/base/modules/psb_z_tools_mod.f90 @@ -237,8 +237,8 @@ Module psb_z_tools_mod !!$ ictxt = psb_cd_get_context(descin) !!$ !!$ call psb_cdcpy(descin,cd_xt,info) -!!$ if (info ==0) call psb_cd_reinit(cd_xt,info) -!!$ if (info /= 0) then +!!$ if (info == psb_success_) call psb_cd_reinit(cd_xt,info) +!!$ if (info /= psb_success_) then !!$ write(0,*) 'Error on reinitialising the extension map' !!$ call psb_error(ictxt) !!$ call psb_abort(ictxt) diff --git a/base/psblas/pdtreecomb.F b/base/psblas/pdtreecomb.F index 59640e741..107662d55 100644 --- a/base/psblas/pdtreecomb.F +++ b/base/psblas/pdtreecomb.F @@ -53,14 +53,14 @@ C * .. * * Purpose -* ======= +* == = ==== * * PDTREECOMB does a 1-tree parallel combine operation on scalars, * using the subroutine indicated by SUBPTR to perform the required * computation. * * Arguments -* ========= +* == = ====== * * ICTXT (global input) INTEGER * The BLACS context handle, indicating the global context of @@ -89,7 +89,7 @@ C * SUBPTR (local input) Pointer to the subroutine to call to perform * the required combine. * -* ===================================================================== +* == = ================================================================== * * .. Local Scalars .. LOGICAL BCAST, RSCOPE, CSCOPE @@ -259,13 +259,13 @@ C * .. * * Purpose -* ======= +* == = ==== * * DCOMBAMAX finds the element having max. absolute value as well * as its corresponding globl index. * * Arguments -* ========= +* == = ====== * * V1 (local input/local output) DOUBLE PRECISION array of * dimension 2. The first maximum absolute value element and @@ -275,7 +275,7 @@ C * The second maximum absolute value element and its global * index. V2(1) = AMAX, V2(2) = INDX. * -* ===================================================================== +* == = ================================================================== * * .. Intrinsic Functions .. INTRINSIC ABS @@ -305,12 +305,12 @@ C * .. * * Purpose -* ======= +* == = ==== * * DCOMBSSQ does a scaled sum of squares on two scalars. * * Arguments -* ========= +* == = ====== * * V1 (local input/local output) DOUBLE PRECISION array of * dimension 2. The first scaled sum. V1(1) = SCALE, @@ -319,7 +319,7 @@ C * V2 (local input) DOUBLE PRECISION array of dimension 2. * The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ. * -* ===================================================================== +* == = ================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO @@ -353,20 +353,20 @@ C * .. * * Purpose -* ======= +* == = ==== * * DCOMBNRM2 combines local norm 2 results, taking care not to cause * unnecessary overflow. * * Arguments -* ========= +* == = ====== * * X (local input) DOUBLE PRECISION * Y (local input) DOUBLE PRECISION * X and Y specify the values x and y. X and Y are supposed to * be >= 0. * -* ===================================================================== +* == = ================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 index 28f3a37f7..1ed2838ae 100644 --- a/base/psblas/psb_camax.f90 +++ b/base/psblas/psb_camax.f90 @@ -66,7 +66,7 @@ function psb_camax(x,desc_a, info, jx) name='psb_camax' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -75,7 +75,7 @@ function psb_camax(x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -90,15 +90,15 @@ function psb_camax(x,desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -196,7 +196,7 @@ function psb_camaxv (x,desc_a, info) name='psb_camaxv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -205,7 +205,7 @@ function psb_camaxv (x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -216,15 +216,15 @@ function psb_camaxv (x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -324,7 +324,7 @@ subroutine psb_camaxvs(res,x,desc_a, info) name='psb_camaxvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -333,7 +333,7 @@ subroutine psb_camaxvs(res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -343,15 +343,15 @@ subroutine psb_camaxvs(res,x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -450,7 +450,7 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) name='psb_cmamaxs' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -459,7 +459,7 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -475,15 +475,15 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx) k = min(size(x,2),size(res,1)) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_casum.f90 b/base/psblas/psb_casum.f90 index 8731cc733..5f9a3858f 100644 --- a/base/psblas/psb_casum.f90 +++ b/base/psblas/psb_casum.f90 @@ -67,7 +67,7 @@ function psb_casum (x,desc_a, info, jx) name='psb_casum' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -76,7 +76,7 @@ function psb_casum (x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -92,15 +92,15 @@ function psb_casum (x,desc_a, info, jx) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -208,7 +208,7 @@ function psb_casumv(x,desc_a, info) name='psb_casumv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -217,7 +217,7 @@ function psb_casumv(x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -229,15 +229,15 @@ function psb_casumv(x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -346,7 +346,7 @@ subroutine psb_casumvs(res,x,desc_a, info) name='psb_casumvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -355,7 +355,7 @@ subroutine psb_casumvs(res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -367,15 +367,15 @@ subroutine psb_casumvs(res,x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index 88b6cc092..eef939a19 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -69,13 +69,13 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) name='psb_geaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -115,17 +115,17 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -219,14 +219,14 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) name='psb_geaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -238,22 +238,22 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) ! check vector correctness call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if diff --git a/base/psblas/psb_cdot.f90 b/base/psblas/psb_cdot.f90 index 8e47483ad..be31c1aa2 100644 --- a/base/psblas/psb_cdot.f90 +++ b/base/psblas/psb_cdot.f90 @@ -67,13 +67,13 @@ function psb_cdot(x, y,desc_a, info, jx, jy) name='psb_cdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -102,17 +102,17 @@ function psb_cdot(x, y,desc_a, info, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -216,14 +216,14 @@ function psb_cdotv(x, y,desc_a, info) name='psb_cdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -236,17 +236,17 @@ function psb_cdotv(x, y,desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -350,14 +350,14 @@ subroutine psb_cdotvs(res, x, y,desc_a, info) name='psb_cdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -367,17 +367,17 @@ subroutine psb_cdotvs(res, x, y,desc_a, info) m = psb_cd_get_global_rows(desc_a) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -482,14 +482,14 @@ subroutine psb_cmdots(res, x, y, desc_a, info) name='psb_cmdots' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -501,22 +501,22 @@ subroutine psb_cmdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ix /= ione).or.(iy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index 6b7ec38cf..e73be1035 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -64,14 +64,14 @@ function psb_cnrm2(x, desc_a, info, jx) name='psb_cnrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -85,14 +85,14 @@ function psb_cnrm2(x, desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -196,14 +196,14 @@ function psb_cnrm2v(x, desc_a, info) name='psb_cnrm2v' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -213,14 +213,14 @@ function psb_cnrm2v(x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -325,14 +325,14 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) name='psb_cnrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -342,14 +342,14 @@ subroutine psb_cnrm2vs(res, x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 index 9364d0ee9..f870f55b6 100644 --- a/base/psblas/psb_cnrmi.f90 +++ b/base/psblas/psb_cnrmi.f90 @@ -58,14 +58,14 @@ function psb_cnrmi(a,desc_a,info) name='psb_cnrmi' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -76,23 +76,23 @@ function psb_cnrmi(a,desc_a,info) n = psb_cd_get_global_cols(desc_a) call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iia /= 1).or.(jja /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if if ((m /= 0).and.(n /= 0)) then nrmi = a%csnmi() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_csnmi' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_cspmm.f90 b/base/psblas/psb_cspmm.f90 index 987f69fcb..bcf20512f 100644 --- a/base/psblas/psb_cspmm.f90 +++ b/base/psblas/psb_cspmm.f90 @@ -94,7 +94,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& name='psb_cspmm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -103,7 +103,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -146,7 +146,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -173,8 +173,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -187,8 +187,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -199,17 +199,17 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -217,7 +217,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -239,28 +239,28 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& & call psi_swapdata(psb_swap_send_,ib1,& & czero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk ! local Matrix-vector product call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i-1+ib-1),& & beta,y(:,jjy+i-1:jjy+i-1+ib-1),info,trans=trans_) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk if((ib1 > 0).and.(doswap_))& & call psi_swapdata(psb_swap_recv_,ib1,& & czero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk end do blk else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,czero,x(:,1:ik),desc_a,iwork,info) - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) end if - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -270,7 +270,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -278,10 +278,10 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -289,7 +289,7 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -301,30 +301,30 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) y(nrow+1:ncol,1:ik) = czero - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) if (doswap_)then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,cone,y(:,1:ik),desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ik,cone,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -336,8 +336,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -445,7 +445,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& name='psb_cspmv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -453,7 +453,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -481,7 +481,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -509,8 +509,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -523,8 +523,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -536,17 +536,17 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -554,7 +554,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -566,8 +566,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& call psb_csmm(alpha,a,x,beta,y,info) - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -576,17 +576,17 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -594,7 +594,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -609,18 +609,18 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x,xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = czero ! local Matrix-vector product - if (info == 0) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (info /= 0) then - info = 4010 + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -629,13 +629,13 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & cone,yp,desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -647,8 +647,8 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_cspsm.f90 b/base/psblas/psb_cspsm.f90 index 11349f670..70a1cd852 100644 --- a/base/psblas/psb_cspsm.f90 +++ b/base/psblas/psb_cspsm.f90 @@ -106,14 +106,14 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& name='psb_cspsm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -160,7 +160,7 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then ! OK else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -175,7 +175,7 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& lldy = size(y,1) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -195,8 +195,8 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -219,12 +219,12 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -232,15 +232,15 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -250,8 +250,8 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy,jjy:jjy+ik-1) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='cssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -263,9 +263,9 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if @@ -384,14 +384,14 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& name='psb_cspsv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -422,7 +422,7 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then ! Ok else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -437,7 +437,7 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& lldy = size(y) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -458,8 +458,8 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -482,12 +482,12 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -495,15 +495,15 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -513,8 +513,8 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='dcssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -526,9 +526,9 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index 6996b1303..2a48c2154 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -66,7 +66,7 @@ function psb_damax (x,desc_a, info, jx) name='psb_damax' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -75,7 +75,7 @@ function psb_damax (x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -90,15 +90,15 @@ function psb_damax (x,desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -195,7 +195,7 @@ function psb_damaxv (x,desc_a, info) name='psb_damaxv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -204,7 +204,7 @@ function psb_damaxv (x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -215,15 +215,15 @@ function psb_damaxv (x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -317,7 +317,7 @@ subroutine psb_damaxvs (res,x,desc_a, info) name='psb_damaxvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -326,7 +326,7 @@ subroutine psb_damaxvs (res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -337,15 +337,15 @@ subroutine psb_damaxvs (res,x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -438,7 +438,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx) name='psb_dmamaxs' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -447,7 +447,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -463,15 +463,15 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx) k = min(size(x,2),size(res,1)) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index 93a6bfa6d..36ff400db 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -67,7 +67,7 @@ function psb_dasum (x,desc_a, info, jx) name='psb_dasum' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -76,7 +76,7 @@ function psb_dasum (x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -92,15 +92,15 @@ function psb_dasum (x,desc_a, info, jx) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -209,7 +209,7 @@ function psb_dasumv (x,desc_a, info) name='psb_dasumv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -218,7 +218,7 @@ function psb_dasumv (x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -230,15 +230,15 @@ function psb_dasumv (x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -342,7 +342,7 @@ subroutine psb_dasumvs(res,x,desc_a, info) name='psb_dasumvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -351,7 +351,7 @@ subroutine psb_dasumvs(res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -363,15 +363,15 @@ subroutine psb_dasumvs(res,x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 2f66474c7..cb8824859 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -68,14 +68,14 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) name='psb_dgeaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -115,17 +115,17 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -218,14 +218,14 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) name='psb_dgeaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -237,22 +237,22 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) ! check vector correctness call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index 63b468e79..72b1d787e 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -70,13 +70,13 @@ function psb_ddot(x, y,desc_a, info, jx, jy) name='psb_ddot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -105,17 +105,17 @@ function psb_ddot(x, y,desc_a, info, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -222,14 +222,14 @@ function psb_ddotv(x, y,desc_a, info) name='psb_ddot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -242,17 +242,17 @@ function psb_ddotv(x, y,desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -357,14 +357,14 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) name='psb_ddot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -374,17 +374,17 @@ subroutine psb_ddotvs(res, x, y,desc_a, info) m = psb_cd_get_global_rows(desc_a) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -489,14 +489,14 @@ subroutine psb_dmdots(res, x, y, desc_a, info) name='psb_dmdots' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -508,22 +508,22 @@ subroutine psb_dmdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ix /= ione).or.(iy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 7a0b10efd..5bbc57da3 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -66,14 +66,14 @@ function psb_dnrm2(x, desc_a, info, jx) name='psb_dnrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -87,14 +87,14 @@ function psb_dnrm2(x, desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -200,14 +200,14 @@ function psb_dnrm2v(x, desc_a, info) name='psb_dnrm2v' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -217,14 +217,14 @@ function psb_dnrm2v(x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -328,14 +328,14 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) name='psb_dnrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -345,14 +345,14 @@ subroutine psb_dnrm2vs(res, x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 123016b95..8d6990427 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -63,14 +63,14 @@ function psb_dnrmi(a,desc_a,info) name='psb_dnrmi' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,23 +81,23 @@ function psb_dnrmi(a,desc_a,info) n = psb_cd_get_global_cols(desc_a) call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iia /= 1).or.(jja /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if if ((m /= 0).and.(n /= 0)) then nrmi = a%csnmi() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_csnmi' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index baceb6a8e..92c2de42c 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -94,7 +94,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& name='psb_dspmm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -103,7 +103,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -146,7 +146,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -173,8 +173,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -187,8 +187,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -199,17 +199,17 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -217,7 +217,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -239,28 +239,28 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& & call psi_swapdata(psb_swap_send_,ib1,& & dzero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk ! local Matrix-vector product call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i-1+ib-1),& & beta,y(:,jjy+i-1:jjy+i-1+ib-1),info,trans=trans_) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk if((ib1 > 0).and.(doswap_))& & call psi_swapdata(psb_swap_recv_,ib1,& & dzero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk end do blk else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,dzero,x(:,1:ik),desc_a,iwork,info) - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) end if - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -270,7 +270,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -278,10 +278,10 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -289,7 +289,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -301,30 +301,30 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) y(nrow+1:ncol,1:ik) = dzero - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) if (doswap_)then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,done,y(:,1:ik),desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ik,done,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -336,8 +336,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -445,7 +445,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& name='psb_dspmv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -453,7 +453,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -481,7 +481,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -509,8 +509,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -523,8 +523,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -536,17 +536,17 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -554,7 +554,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -566,8 +566,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& call psb_csmm(alpha,a,x,beta,y,info) - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -576,17 +576,17 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -594,7 +594,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -609,18 +609,18 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x,xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = dzero ! local Matrix-vector product - if (info == 0) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (info /= 0) then - info = 4010 + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -629,13 +629,13 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & done,yp,desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -647,8 +647,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_dspsm.f90 b/base/psblas/psb_dspsm.f90 index dce4151b9..59f2242cb 100644 --- a/base/psblas/psb_dspsm.f90 +++ b/base/psblas/psb_dspsm.f90 @@ -107,14 +107,14 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& name='psb_dspsm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -161,7 +161,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then ! OK else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -176,7 +176,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& lldy = size(y,1) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -196,8 +196,8 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -220,12 +220,12 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -233,15 +233,15 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -251,8 +251,8 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy,jjy:jjy+ik-1) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='cssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -264,9 +264,9 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if @@ -385,14 +385,14 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& name='psb_dspsv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -423,7 +423,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then ! Ok else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -438,7 +438,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& lldy = size(y) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -459,8 +459,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -483,12 +483,12 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -496,15 +496,15 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -514,8 +514,8 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='dcssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -527,9 +527,9 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 index 37d631c0c..2157018dd 100644 --- a/base/psblas/psb_samax.f90 +++ b/base/psblas/psb_samax.f90 @@ -66,7 +66,7 @@ function psb_samax (x,desc_a, info, jx) name='psb_samax' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -75,7 +75,7 @@ function psb_samax (x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -90,15 +90,15 @@ function psb_samax (x,desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -195,7 +195,7 @@ function psb_samaxv (x,desc_a, info) name='psb_samaxv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -204,7 +204,7 @@ function psb_samaxv (x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -215,15 +215,15 @@ function psb_samaxv (x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -317,7 +317,7 @@ subroutine psb_samaxvs (res,x,desc_a, info) name='psb_samaxvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -326,7 +326,7 @@ subroutine psb_samaxvs (res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -337,15 +337,15 @@ subroutine psb_samaxvs (res,x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -438,7 +438,7 @@ subroutine psb_smamaxs (res,x,desc_a, info,jx) name='psb_smamaxs' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -447,7 +447,7 @@ subroutine psb_smamaxs (res,x,desc_a, info,jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -463,15 +463,15 @@ subroutine psb_smamaxs (res,x,desc_a, info,jx) k = min(size(x,2),size(res,1)) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_sasum.f90 b/base/psblas/psb_sasum.f90 index e9399d868..0c943b7bc 100644 --- a/base/psblas/psb_sasum.f90 +++ b/base/psblas/psb_sasum.f90 @@ -67,7 +67,7 @@ function psb_sasum (x,desc_a, info, jx) name='psb_sasum' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.0 @@ -76,7 +76,7 @@ function psb_sasum (x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -92,15 +92,15 @@ function psb_sasum (x,desc_a, info, jx) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -209,7 +209,7 @@ function psb_sasumv (x,desc_a, info) name='psb_sasumv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.0 @@ -218,7 +218,7 @@ function psb_sasumv (x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -230,15 +230,15 @@ function psb_sasumv (x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -342,7 +342,7 @@ subroutine psb_sasumvs(res,x,desc_a, info) name='psb_sasumvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.0 @@ -351,7 +351,7 @@ subroutine psb_sasumvs(res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -363,15 +363,15 @@ subroutine psb_sasumvs(res,x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index f4f6d9e40..d7a0db92e 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -68,14 +68,14 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) name='psb_sgeaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -115,17 +115,17 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -218,14 +218,14 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) name='psb_sgeaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -237,22 +237,22 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) ! check vector correctness call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if diff --git a/base/psblas/psb_sdot.f90 b/base/psblas/psb_sdot.f90 index ff7d65e0b..2f0647704 100644 --- a/base/psblas/psb_sdot.f90 +++ b/base/psblas/psb_sdot.f90 @@ -70,13 +70,13 @@ function psb_sdot(x, y,desc_a, info, jx, jy) name='psb_sdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -105,17 +105,17 @@ function psb_sdot(x, y,desc_a, info, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -222,14 +222,14 @@ function psb_sdotv(x, y,desc_a, info) name='psb_sdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -242,17 +242,17 @@ function psb_sdotv(x, y,desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -356,14 +356,14 @@ subroutine psb_sdotvs(res, x, y,desc_a, info) name='psb_sdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -373,17 +373,17 @@ subroutine psb_sdotvs(res, x, y,desc_a, info) m = psb_cd_get_global_rows(desc_a) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -488,14 +488,14 @@ subroutine psb_smdots(res, x, y, desc_a, info) name='psb_smdots' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -507,22 +507,22 @@ subroutine psb_smdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ix /= ione).or.(iy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index 774144162..1388b327f 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -66,14 +66,14 @@ function psb_snrm2(x, desc_a, info, jx) name='psb_snrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -87,14 +87,14 @@ function psb_snrm2(x, desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -200,14 +200,14 @@ function psb_snrm2v(x, desc_a, info) name='psb_snrm2v' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -217,14 +217,14 @@ function psb_snrm2v(x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -328,14 +328,14 @@ subroutine psb_snrm2vs(res, x, desc_a, info) name='psb_snrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -345,14 +345,14 @@ subroutine psb_snrm2vs(res, x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 index 82316789d..539883951 100644 --- a/base/psblas/psb_snrmi.f90 +++ b/base/psblas/psb_snrmi.f90 @@ -63,14 +63,14 @@ function psb_snrmi(a,desc_a,info) name='psb_snrmi' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,23 +81,23 @@ function psb_snrmi(a,desc_a,info) n = psb_cd_get_global_cols(desc_a) call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iia /= 1).or.(jja /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if if ((m /= 0).and.(n /= 0)) then nrmi = a%csnmi() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_csnmi' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_sspmm.f90 b/base/psblas/psb_sspmm.f90 index e2cabfdc0..f5e2d0694 100644 --- a/base/psblas/psb_sspmm.f90 +++ b/base/psblas/psb_sspmm.f90 @@ -94,7 +94,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& name='psb_sspmm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -103,7 +103,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -146,7 +146,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -173,8 +173,8 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -187,8 +187,8 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -199,17 +199,17 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -217,7 +217,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -239,28 +239,28 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& & call psi_swapdata(psb_swap_send_,ib1,& & szero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk ! local Matrix-vector product call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i-1+ib-1),& & beta,y(:,jjy+i-1:jjy+i-1+ib-1),info,trans=trans_) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk if((ib1 > 0).and.(doswap_))& & call psi_swapdata(psb_swap_recv_,ib1,& & szero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk end do blk else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,szero,x(:,1:ik),desc_a,iwork,info) - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) end if - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -270,7 +270,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -278,10 +278,10 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -289,7 +289,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -301,30 +301,30 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) y(nrow+1:ncol,1:ik) = szero - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) if (doswap_)then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,sone,y(:,1:ik),desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ik,sone,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -336,8 +336,8 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -445,7 +445,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& name='psb_sspmv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -453,7 +453,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -481,7 +481,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -509,8 +509,8 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -523,8 +523,8 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -536,17 +536,17 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -554,7 +554,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -566,8 +566,8 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& call psb_csmm(alpha,a,x,beta,y,info) - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -576,17 +576,17 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -594,7 +594,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -609,18 +609,18 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x,xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = szero ! local Matrix-vector product - if (info == 0) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (info /= 0) then - info = 4010 + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -629,13 +629,13 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & sone,yp,desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -647,8 +647,8 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_sspsm.f90 b/base/psblas/psb_sspsm.f90 index e4ce6a25a..a10f5694c 100644 --- a/base/psblas/psb_sspsm.f90 +++ b/base/psblas/psb_sspsm.f90 @@ -107,14 +107,14 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& name='psb_sspsm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -161,7 +161,7 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then ! OK else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -176,7 +176,7 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& lldy = size(y,1) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -196,8 +196,8 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -220,12 +220,12 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -233,15 +233,15 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -251,8 +251,8 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy,jjy:jjy+ik-1) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='cssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -264,9 +264,9 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if @@ -385,14 +385,14 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& name='psb_sspsv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -423,7 +423,7 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then ! Ok else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -438,7 +438,7 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& lldy = size(y) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -459,8 +459,8 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -483,12 +483,12 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -496,15 +496,15 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -514,8 +514,8 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='dcssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -527,9 +527,9 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if diff --git a/base/psblas/psb_sxdot.f90 b/base/psblas/psb_sxdot.f90 index 9e1adfd03..8e7982ac0 100644 --- a/base/psblas/psb_sxdot.f90 +++ b/base/psblas/psb_sxdot.f90 @@ -70,13 +70,13 @@ function psb_sxdot(x, y,desc_a, info, jx, jy) name='psb_sdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -105,17 +105,17 @@ function psb_sxdot(x, y,desc_a, info, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -222,14 +222,14 @@ function psb_sxdotv(x, y,desc_a, info) name='psb_sdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -242,17 +242,17 @@ function psb_sxdotv(x, y,desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -377,14 +377,14 @@ subroutine psb_sxdotvs(res, x, y,desc_a, info) name='psb_sdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -394,17 +394,17 @@ subroutine psb_sxdotvs(res, x, y,desc_a, info) m = psb_cd_get_global_rows(desc_a) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -509,14 +509,14 @@ subroutine psb_sxmdots(res, x, y, desc_a, info) name='psb_smdots' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -528,22 +528,22 @@ subroutine psb_sxmdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ix /= ione).or.(iy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index 3c1a69d23..6158c503d 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -69,7 +69,7 @@ function psb_zamax (x,desc_a, info, jx) name='psb_zamax' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -78,7 +78,7 @@ function psb_zamax (x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -93,15 +93,15 @@ function psb_zamax (x,desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -202,7 +202,7 @@ function psb_zamaxv (x,desc_a, info) name='psb_zamaxv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -211,7 +211,7 @@ function psb_zamaxv (x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -222,15 +222,15 @@ function psb_zamaxv (x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -329,7 +329,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info) name='psb_zamaxvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -338,7 +338,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -348,15 +348,15 @@ subroutine psb_zamaxvs(res,x,desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -454,7 +454,7 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) name='psb_zmamaxs' if (psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) amax=0.d0 @@ -463,7 +463,7 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -479,15 +479,15 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx) k = min(size(x,2),size(res,1)) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index a2b2fe595..999695da9 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -71,7 +71,7 @@ function psb_zasum (x,desc_a, info, jx) name='psb_zasum' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -80,7 +80,7 @@ function psb_zasum (x,desc_a, info, jx) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -96,15 +96,15 @@ function psb_zasum (x,desc_a, info, jx) ! check vector correctness call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -218,7 +218,7 @@ function psb_zasumv(x,desc_a, info) name='psb_zasumv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -227,7 +227,7 @@ function psb_zasumv(x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -239,15 +239,15 @@ function psb_zasumv(x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -357,7 +357,7 @@ subroutine psb_zasumvs(res,x,desc_a, info) name='psb_zasumvs' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) asum=0.d0 @@ -366,7 +366,7 @@ subroutine psb_zasumvs(res,x,desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -378,15 +378,15 @@ subroutine psb_zasumvs(res,x,desc_a, info) ! check vector correctness call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index eb5fc4826..b0d2901bf 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -68,13 +68,13 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) name='psb_geaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -114,17 +114,17 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -218,14 +218,14 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) name='psb_geaxpby' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -237,22 +237,22 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) ! check vector correctness call psb_chkvect(m,ione,size(x),ix,ione,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y),iy,ione,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) end if diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index 4ff77f6dd..6836ecdba 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -70,13 +70,13 @@ function psb_zdot(x, y,desc_a, info, jx, jy) name='psb_zdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -105,17 +105,17 @@ function psb_zdot(x, y,desc_a, info, jx, jy) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -222,14 +222,14 @@ function psb_zdotv(x, y,desc_a, info) name='psb_zdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -242,17 +242,17 @@ function psb_zdotv(x, y,desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(m,ione,size(y,1),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -356,14 +356,14 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) name='psb_zdot' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -373,17 +373,17 @@ subroutine psb_zdotvs(res, x, y,desc_a, info) m = psb_cd_get_global_rows(desc_a) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iix /= ione).or.(iiy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -488,14 +488,14 @@ subroutine psb_zmdots(res, x, y, desc_a, info) name='psb_zmdots' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -ione) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -507,22 +507,22 @@ subroutine psb_zmdots(res, x, y, desc_a, info) ! check vector correctness call psb_chkvect(m,ione,size(x,1),ix,ix,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_chkvect(m,ione,size(y,1),iy,iy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((ix /= ione).or.(iy /= ione)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index 3ad200adc..9b18045af 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -67,14 +67,14 @@ function psb_znrm2(x, desc_a, info, jx) name='psb_znrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -88,14 +88,14 @@ function psb_znrm2(x, desc_a, info, jx) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -202,14 +202,14 @@ function psb_znrm2v(x, desc_a, info) name='psb_znrm2v' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -219,14 +219,14 @@ function psb_znrm2v(x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -331,14 +331,14 @@ subroutine psb_znrm2vs(res, x, desc_a, info) name='psb_znrm2' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -348,14 +348,14 @@ subroutine psb_znrm2vs(res, x, desc_a, info) m = psb_cd_get_global_rows(desc_a) call psb_chkvect(m,1,size(x),ix,jx,desc_a,info,iix,jjx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) end if if (iix /= 1) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index 2fdc0cdc9..77c2106c8 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -63,14 +63,14 @@ function psb_znrmi(a,desc_a,info) name='psb_znrmi' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -81,23 +81,23 @@ function psb_znrmi(a,desc_a,info) n = psb_cd_get_global_cols(desc_a) call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if ((iia /= 1).or.(jja /= 1)) then - info=3040 + info=psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if if ((m /= 0).and.(n /= 0)) then nrmi = a%csnmi() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_csnmi' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index b3e713bbd..693b2afbf 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -94,7 +94,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& name='psb_zspmm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -103,7 +103,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -146,7 +146,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -173,8 +173,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -187,8 +187,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -199,17 +199,17 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -217,7 +217,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -239,28 +239,28 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& & call psi_swapdata(psb_swap_send_,ib1,& & zzero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk ! local Matrix-vector product call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i-1+ib-1),& & beta,y(:,jjy+i-1:jjy+i-1+ib-1),info,trans=trans_) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk if((ib1 > 0).and.(doswap_))& & call psi_swapdata(psb_swap_recv_,ib1,& & zzero,xp,desc_a,iwork,info) - if(info /= 0) exit blk + if(info /= psb_success_) exit blk end do blk else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,zzero,x(:,1:ik),desc_a,iwork,info) - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) end if - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -270,7 +270,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -278,10 +278,10 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(n,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -289,7 +289,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -301,30 +301,30 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) y(nrow+1:ncol,1:ik) = zzero - if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) if (doswap_)then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,zone,y(:,1:ik),desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ik,zone,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -336,8 +336,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -445,7 +445,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& name='psb_zspmv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -453,7 +453,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -481,7 +481,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& if ( (trans_ == 'N').or.(trans_ == 'T')& & .or.(trans_ == 'C')) then else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -509,8 +509,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -523,8 +523,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info ! checking for matrix correctness call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkmat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -536,17 +536,17 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is not transposed if((ja /= ix).or.(ia /= iy)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -554,7 +554,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -566,8 +566,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& call psb_csmm(alpha,a,x,beta,y,info) - if(info /= 0) then - info = 4011 + if(info /= psb_success_) then + info = psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -576,17 +576,17 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! Matrix is transposed if((ja /= iy).or.(ia /= ix)) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ call psb_errpush(info,name) goto 9999 end if ! checking for vectors correctness call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0)& + if (info == psb_success_)& & call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -594,7 +594,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ call psb_errpush(info,name) goto 9999 end if @@ -609,18 +609,18 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! with a proper scale factor (1/np) to the overall product. ! call psi_ovrl_save(x,xvsave,desc_a,info) - if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info) + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) yp(nrow+1:ncol) = zzero ! local Matrix-vector product - if (info == 0) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) + if (info == psb_success_) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info - if (info == 0) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (info /= 0) then - info = 4010 + if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -629,13 +629,13 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& if (doswap_) then call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & zone,yp,desc_a,iwork,info) - if (info == 0) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='PSI_dSwapTran' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -647,8 +647,8 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& if (aliw) deallocate(iwork,stat=info) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='Deallocate iwork' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/psblas/psb_zspsm.f90 b/base/psblas/psb_zspsm.f90 index 2ad835468..c0e593908 100644 --- a/base/psblas/psb_zspsm.f90 +++ b/base/psblas/psb_zspsm.f90 @@ -106,14 +106,14 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& name='psb_zspsm' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -160,7 +160,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or. (itrans == 'C')) then ! OK else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -175,7 +175,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& lldy = size(y,1) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -195,8 +195,8 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -219,12 +219,12 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x,1),ix,ijx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y,1),iy,ijy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -232,15 +232,15 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -250,8 +250,8 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy,jjy:jjy+ik-1) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='cssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -263,9 +263,9 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if @@ -384,14 +384,14 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& name='psb_zspsv' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) ictxt=psb_cd_get_context(desc_a) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -422,7 +422,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then ! Ok else - info = 70 + info = psb_err_iarg_invalid_value_ call psb_errpush(info,name) goto 9999 end if @@ -437,7 +437,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& lldy = size(y) if((lldx < ncol).or.(lldy < ncol)) then - info=3010 + info=psb_err_lld_case_not_implemented_ call psb_errpush(info,name) goto 9999 end if @@ -458,8 +458,8 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& if (aliw) then allocate(iwork(liwork),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -482,12 +482,12 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& ! checking for matrix correctness call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) - if (info == 0) & + if (info == psb_success_) & & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -495,15 +495,15 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& if(ja /= ix) then ! this case is not yet implemented - info = 3030 + info = psb_err_ja_nix_ia_niy_unsupported_ end if if((iix /= 1).or.(iiy /= 1)) then ! this case is not yet implemented - info = 3040 + info = psb_err_ix_n1_iy_n1_unsupported_ end if - if(info /= 0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -513,8 +513,8 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& yp => y(iiy:lldy) call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans) - if(info /= 0) then - info = 4010 + if(info /= psb_success_) then + info = psb_err_from_subroutine_ ch_err='dcssm' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -526,9 +526,9 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) - if (info == 0) call psi_ovrl_upd(yp,desc_a,choice_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Inner updates') + if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if end if diff --git a/base/psblas/pstreecomb.F b/base/psblas/pstreecomb.F index 31ba0b8cd..683b804d6 100644 --- a/base/psblas/pstreecomb.F +++ b/base/psblas/pstreecomb.F @@ -53,14 +53,14 @@ C * .. * * Purpose -* ======= +* == = ==== * * PSTREECOMB does a 1-tree parallel combine operation on scalars, * using the subroutine indicated by SUBPTR to perform the required * computation. * * Arguments -* ========= +* == = ====== * * ICTXT (global input) INTEGER * The BLACS context handle, indicating the global context of @@ -89,7 +89,7 @@ C * SUBPTR (local input) Pointer to the subroutine to call to perform * the required combine. * -* ===================================================================== +* == = ================================================================== * * .. Local Scalars .. LOGICAL BCAST, RSCOPE, CSCOPE @@ -259,13 +259,13 @@ C * .. * * Purpose -* ======= +* == = ==== * * SCOMBAMAX finds the element having max. absolute value as well * as its corresponding globl index. * * Arguments -* ========= +* == = ====== * * V1 (local input/local output) REAL array of * dimension 2. The first maximum absolute value element and @@ -275,7 +275,7 @@ C * The second maximum absolute value element and its global * index. V2(1) = AMAX, V2(2) = INDX. * -* ===================================================================== +* == = ================================================================== * * .. Intrinsic Functions .. INTRINSIC ABS @@ -305,12 +305,12 @@ C * .. * * Purpose -* ======= +* == = ==== * * SCOMBSSQ does a scaled sum of squares on two scalars. * * Arguments -* ========= +* == = ====== * * V1 (local input/local output) REAL array of * dimension 2. The first scaled sum. V1(1) = SCALE, @@ -319,7 +319,7 @@ C * V2 (local input) REAL array of dimension 2. * The second scaled sum. V2(1) = SCALE, V2(2) = SUMSQ. * -* ===================================================================== +* == = ================================================================== * * .. Parameters .. REAL ZERO @@ -353,20 +353,20 @@ C * .. * * Purpose -* ======= +* == = ==== * * SCOMBNRM2 combines local norm 2 results, taking care not to cause * unnecessary overflow. * * Arguments -* ========= +* == = ====== * * X (local input) REAL * Y (local input) REAL * X and Y specify the values x and y. X and Y are supposed to * be >= 0. * -* ===================================================================== +* == = ================================================================== * * .. Parameters .. REAL ONE, ZERO diff --git a/base/serial/aux/calcmp_mod.f90 b/base/serial/aux/calcmp_mod.f90 index 21e5348b8..8a2abb303 100644 --- a/base/serial/aux/calcmp_mod.f90 +++ b/base/serial/aux/calcmp_mod.f90 @@ -52,7 +52,7 @@ contains logical :: callt callt = (abs(real(a))abs(real(b))).or. & - & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>abs(aimag(b)))) + & ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>abs(aimag(b)))) end function calgt function calge(a,b) use psb_const_mod @@ -77,7 +77,7 @@ contains logical :: calge calge = (abs(real(a))>abs(real(b))).or. & - & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b)))) + & ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b)))) end function calge end module calcmp_mod diff --git a/base/serial/aux/calsr.f90 b/base/serial/aux/calsr.f90 index 1df09b352..8279c0056 100644 --- a/base/serial/aux/calsr.f90 +++ b/base/serial/aux/calsr.f90 @@ -135,7 +135,7 @@ subroutine calsr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='calsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='calsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -259,7 +259,7 @@ subroutine calsr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='calsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='calsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -304,7 +304,7 @@ subroutine calsr(n,x,dir) endif case default - call psb_errpush(4001,r_name='calsr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='calsr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/calsrx.f90 b/base/serial/aux/calsrx.f90 index f52ab42b2..cb8a116da 100644 --- a/base/serial/aux/calsrx.f90 +++ b/base/serial/aux/calsrx.f90 @@ -59,7 +59,7 @@ subroutine calsrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='calsrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='wrong flag') call psb_error() end select ! @@ -163,7 +163,7 @@ subroutine calsrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='calsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine calsrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='calsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -348,7 +348,7 @@ subroutine calsrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='calsrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='calsrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/camsort_dw.f90 b/base/serial/aux/camsort_dw.f90 index ec9b98370..2fa89ebee 100644 --- a/base/serial/aux/camsort_dw.f90 +++ b/base/serial/aux/camsort_dw.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/camsort_up.f90 b/base/serial/aux/camsort_up.f90 index db36fe3f6..95f8fb0bb 100644 --- a/base/serial/aux/camsort_up.f90 +++ b/base/serial/aux/camsort_up.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/camsr.f90 b/base/serial/aux/camsr.f90 index f3c5448ba..967ca4d23 100644 --- a/base/serial/aux/camsr.f90 +++ b/base/serial/aux/camsr.f90 @@ -53,12 +53,12 @@ subroutine camsr(n,x,idir) if (n<=1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='camsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='camsr') call psb_error() endif - if (idir==psb_asort_up_) then + if (idir == psb_asort_up_) then call camsort_up(n,x,iaux,iret) else call camsort_dw(n,x,iaux,iret) @@ -67,8 +67,8 @@ subroutine camsr(n,x,idir) if (iret == 0) call psb_ip_reord(n,x,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='camsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='camsr') call psb_error() endif return diff --git a/base/serial/aux/camsrx.f90 b/base/serial/aux/camsrx.f90 index 5a5f9150d..407de4d39 100644 --- a/base/serial/aux/camsrx.f90 +++ b/base/serial/aux/camsrx.f90 @@ -49,7 +49,7 @@ subroutine camsrx(n,x,indx,idir,flag) return endif - if (n==0) return + if (n == 0) return if (flag == psb_sort_ovw_idx_) then do k=1,n @@ -57,11 +57,11 @@ subroutine camsrx(n,x,indx,idir,flag) enddo end if - if (n==1) return + if (n == 1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='camsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='camsrx') call psb_error() endif @@ -74,8 +74,8 @@ subroutine camsrx(n,x,indx,idir,flag) if (iret == 0) call psb_ip_reord(n,x,indx,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='camsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='camsrx') call psb_error() endif return diff --git a/base/serial/aux/casr.f90 b/base/serial/aux/casr.f90 index d40efb1f6..ef1ba4583 100644 --- a/base/serial/aux/casr.f90 +++ b/base/serial/aux/casr.f90 @@ -135,7 +135,7 @@ subroutine casr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='casr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='casr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -259,7 +259,7 @@ subroutine casr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='casr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='casr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -304,7 +304,7 @@ subroutine casr(n,x,dir) endif case default - call psb_errpush(4001,r_name='casr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='casr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/casrx.f90 b/base/serial/aux/casrx.f90 index bfc40c440..30d12396d 100644 --- a/base/serial/aux/casrx.f90 +++ b/base/serial/aux/casrx.f90 @@ -59,7 +59,7 @@ subroutine casrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='casrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='wrong flag') call psb_error() end select ! @@ -163,7 +163,7 @@ subroutine casrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='casrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine casrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='casrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -348,7 +348,7 @@ subroutine casrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='casrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='casrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/clcmp_mod.f90 b/base/serial/aux/clcmp_mod.f90 index 086e08cfa..e52f10cdc 100644 --- a/base/serial/aux/clcmp_mod.f90 +++ b/base/serial/aux/clcmp_mod.f90 @@ -51,14 +51,14 @@ contains complex(psb_spk_), intent(in) :: a,b logical :: cllt - cllt = (real(a)real(b)).or.((real(a)==real(b)).and.(aimag(a)>aimag(b))) + clgt = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>aimag(b))) end function clgt function clge(a,b) use psb_const_mod complex(psb_spk_), intent(in) :: a,b logical :: clge - clge = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>=aimag(b))) + clge = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>=aimag(b))) end function clge end module clcmp_mod diff --git a/base/serial/aux/clsr.f90 b/base/serial/aux/clsr.f90 index 3fa475b0d..e8dc3aebc 100644 --- a/base/serial/aux/clsr.f90 +++ b/base/serial/aux/clsr.f90 @@ -135,7 +135,7 @@ subroutine clsr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='clsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='clsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -259,7 +259,7 @@ subroutine clsr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='clsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='clsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -304,7 +304,7 @@ subroutine clsr(n,x,dir) endif case default - call psb_errpush(4001,r_name='clsr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='clsr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/clsrx.f90 b/base/serial/aux/clsrx.f90 index 00446412f..c006e0751 100644 --- a/base/serial/aux/clsrx.f90 +++ b/base/serial/aux/clsrx.f90 @@ -59,7 +59,7 @@ subroutine clsrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='clsrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='wrong flag') call psb_error() end select ! @@ -163,7 +163,7 @@ subroutine clsrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='clsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine clsrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='clsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -348,7 +348,7 @@ subroutine clsrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='clsrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='clsrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/dasr.f90 b/base/serial/aux/dasr.f90 index 2bd3960ef..c8051ebdd 100644 --- a/base/serial/aux/dasr.f90 +++ b/base/serial/aux/dasr.f90 @@ -134,7 +134,7 @@ subroutine dasr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -258,7 +258,7 @@ subroutine dasr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine dasr(n,x,dir) endif case default - call psb_errpush(4001,r_name='dasr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='dasr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/dasrx.f90 b/base/serial/aux/dasrx.f90 index ab44a8b41..feebee5d1 100644 --- a/base/serial/aux/dasrx.f90 +++ b/base/serial/aux/dasrx.f90 @@ -160,7 +160,7 @@ subroutine dasrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -298,7 +298,7 @@ subroutine dasrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -343,7 +343,7 @@ subroutine dasrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='dasrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='dasrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/dmsort_dw.f90 b/base/serial/aux/dmsort_dw.f90 index c69171fdc..32177d377 100644 --- a/base/serial/aux/dmsort_dw.f90 +++ b/base/serial/aux/dmsort_dw.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/dmsort_up.f90 b/base/serial/aux/dmsort_up.f90 index e831ef2ac..2a858d36b 100644 --- a/base/serial/aux/dmsort_up.f90 +++ b/base/serial/aux/dmsort_up.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/dmsr.f90 b/base/serial/aux/dmsr.f90 index ab32c77a6..a47425312 100644 --- a/base/serial/aux/dmsr.f90 +++ b/base/serial/aux/dmsr.f90 @@ -54,12 +54,12 @@ subroutine dmsr(n,x,idir) if (n<=1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='dmsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsr') call psb_error() endif - if (idir==psb_sort_up_) then + if (idir == psb_sort_up_) then call dmsort_up(n,x,iaux,iret) else call dmsort_dw(n,x,iaux,iret) @@ -68,8 +68,8 @@ subroutine dmsr(n,x,idir) if (iret == 0) call psb_ip_reord(n,x,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='dmsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsr') call psb_error() endif return diff --git a/base/serial/aux/dmsrx.f90 b/base/serial/aux/dmsrx.f90 index adf0fccc7..a3bd7b713 100644 --- a/base/serial/aux/dmsrx.f90 +++ b/base/serial/aux/dmsrx.f90 @@ -50,7 +50,7 @@ subroutine dmsrx(n,x,indx,idir,flag) return endif - if (n==0) return + if (n == 0) return if (flag == psb_sort_ovw_idx_) then do k=1,n @@ -58,11 +58,11 @@ subroutine dmsrx(n,x,indx,idir,flag) enddo end if - if (n==1) return + if (n == 1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='dmsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsrx') call psb_error() endif @@ -75,8 +75,8 @@ subroutine dmsrx(n,x,indx,idir,flag) if (iret == 0) call psb_ip_reord(n,x,indx,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='dmsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='dmsrx') call psb_error() endif return diff --git a/base/serial/aux/dsr.f90 b/base/serial/aux/dsr.f90 index e2473bb1f..e3a6d4085 100644 --- a/base/serial/aux/dsr.f90 +++ b/base/serial/aux/dsr.f90 @@ -134,7 +134,7 @@ subroutine dsr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -258,7 +258,7 @@ subroutine dsr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine dsr(n,x,dir) endif case default - call psb_errpush(4001,r_name='dsr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='dsr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/dsrx.f90 b/base/serial/aux/dsrx.f90 index 90b89e85d..8e2ddb9f1 100644 --- a/base/serial/aux/dsrx.f90 +++ b/base/serial/aux/dsrx.f90 @@ -58,7 +58,7 @@ subroutine dsrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='isrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='wrong flag') call psb_error() end select ! @@ -162,7 +162,7 @@ subroutine dsrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -301,7 +301,7 @@ subroutine dsrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='dsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='dsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -346,7 +346,7 @@ subroutine dsrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='dsrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='dsrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/iasr.f90 b/base/serial/aux/iasr.f90 index e31399ff3..98109f893 100644 --- a/base/serial/aux/iasr.f90 +++ b/base/serial/aux/iasr.f90 @@ -134,7 +134,7 @@ subroutine iasr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='iasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='iasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -258,7 +258,7 @@ subroutine iasr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='iasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='iasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine iasr(n,x,dir) endif case default - call psb_errpush(4001,r_name='iasr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='iasr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/iasrx.f90 b/base/serial/aux/iasrx.f90 index bf7eca48b..159d15a95 100644 --- a/base/serial/aux/iasrx.f90 +++ b/base/serial/aux/iasrx.f90 @@ -58,7 +58,7 @@ subroutine iasrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='iasrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='wrong flag') call psb_error() end select ! @@ -161,7 +161,7 @@ subroutine iasrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='iasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -299,7 +299,7 @@ subroutine iasrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='iasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -344,7 +344,7 @@ subroutine iasrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='iasrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='iasrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/imsr.f90 b/base/serial/aux/imsr.f90 index 2610fec00..80997aea2 100644 --- a/base/serial/aux/imsr.f90 +++ b/base/serial/aux/imsr.f90 @@ -53,12 +53,12 @@ subroutine imsr(n,x,idir) if (n<=1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='imsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='imsr') call psb_error() endif - if (idir==psb_sort_up_) then + if (idir == psb_sort_up_) then call msort_up(n,x,iaux,iret) else call msort_dw(n,x,iaux,iret) @@ -67,8 +67,8 @@ subroutine imsr(n,x,idir) if (iret == 0) call psb_ip_reord(n,x,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='imsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='imsr') call psb_error() endif return diff --git a/base/serial/aux/imsrx.f90 b/base/serial/aux/imsrx.f90 index fc846c4c7..416bcb7a5 100644 --- a/base/serial/aux/imsrx.f90 +++ b/base/serial/aux/imsrx.f90 @@ -49,7 +49,7 @@ subroutine imsrx(n,x,indx,idir,flag) return endif - if (n==0) return + if (n == 0) return if (flag == psb_sort_ovw_idx_) then do k=1,n @@ -57,11 +57,11 @@ subroutine imsrx(n,x,indx,idir,flag) enddo end if - if (n==1) return + if (n == 1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='imsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='imsrx') call psb_error() endif @@ -74,8 +74,8 @@ subroutine imsrx(n,x,indx,idir,flag) if (iret == 0) call psb_ip_reord(n,x,indx,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='imsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='imsrx') call psb_error() endif return diff --git a/base/serial/aux/isr.f90 b/base/serial/aux/isr.f90 index 880a28a49..620fcb3cd 100644 --- a/base/serial/aux/isr.f90 +++ b/base/serial/aux/isr.f90 @@ -134,7 +134,7 @@ subroutine isr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='isr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='isr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -258,7 +258,7 @@ subroutine isr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='isr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='isr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine isr(n,x,dir) endif case default - call psb_errpush(4001,r_name='isr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='isr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/isrx.f90 b/base/serial/aux/isrx.f90 index cba556991..49354530e 100644 --- a/base/serial/aux/isrx.f90 +++ b/base/serial/aux/isrx.f90 @@ -57,7 +57,7 @@ subroutine isrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='isrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='wrong flag') call psb_error() end select ! @@ -161,7 +161,7 @@ subroutine isrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='isrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -301,7 +301,7 @@ subroutine isrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='isrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -346,7 +346,7 @@ subroutine isrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='isrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='isrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/msort_dw.f90 b/base/serial/aux/msort_dw.f90 index c68dbf4b3..416817286 100644 --- a/base/serial/aux/msort_dw.f90 +++ b/base/serial/aux/msort_dw.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/msort_up.f90 b/base/serial/aux/msort_up.f90 index 3ebf27bb9..5c17016d2 100644 --- a/base/serial/aux/msort_up.f90 +++ b/base/serial/aux/msort_up.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/sasr.f90 b/base/serial/aux/sasr.f90 index 53b89aff0..4b8221cb0 100644 --- a/base/serial/aux/sasr.f90 +++ b/base/serial/aux/sasr.f90 @@ -134,7 +134,7 @@ subroutine sasr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='sasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='sasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -258,7 +258,7 @@ subroutine sasr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='sasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='sasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine sasr(n,x,dir) endif case default - call psb_errpush(4001,r_name='sasr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='sasr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/sasrx.f90 b/base/serial/aux/sasrx.f90 index 40826bfed..6457ce33b 100644 --- a/base/serial/aux/sasrx.f90 +++ b/base/serial/aux/sasrx.f90 @@ -58,7 +58,7 @@ subroutine sasrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='sasrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='wrong flag') call psb_error() end select ! @@ -161,7 +161,7 @@ subroutine sasrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='sasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -299,7 +299,7 @@ subroutine sasrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='sasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -344,7 +344,7 @@ subroutine sasrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='sasrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='sasrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/smsort_dw.f90 b/base/serial/aux/smsort_dw.f90 index 8968c2a70..e431667c0 100644 --- a/base/serial/aux/smsort_dw.f90 +++ b/base/serial/aux/smsort_dw.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/smsort_up.f90 b/base/serial/aux/smsort_up.f90 index 11676dcf9..9ca519142 100644 --- a/base/serial/aux/smsort_up.f90 +++ b/base/serial/aux/smsort_up.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/smsr.f90 b/base/serial/aux/smsr.f90 index b16f75494..9815ac4cb 100644 --- a/base/serial/aux/smsr.f90 +++ b/base/serial/aux/smsr.f90 @@ -53,12 +53,12 @@ subroutine smsr(n,x,idir) if (n<=1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='smsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='smsr') call psb_error() endif - if (idir==psb_sort_up_) then + if (idir == psb_sort_up_) then call smsort_up(n,x,iaux,iret) else call smsort_dw(n,x,iaux,iret) @@ -67,8 +67,8 @@ subroutine smsr(n,x,idir) if (iret == 0) call psb_ip_reord(n,x,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='smsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='smsr') call psb_error() endif return diff --git a/base/serial/aux/smsrx.f90 b/base/serial/aux/smsrx.f90 index 0f56aa957..4a8fadad6 100644 --- a/base/serial/aux/smsrx.f90 +++ b/base/serial/aux/smsrx.f90 @@ -49,7 +49,7 @@ subroutine smsrx(n,x,indx,idir,flag) return endif - if (n==0) return + if (n == 0) return if (flag == psb_sort_ovw_idx_) then do k=1,n @@ -57,11 +57,11 @@ subroutine smsrx(n,x,indx,idir,flag) enddo end if - if (n==1) return + if (n == 1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='smsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='smsrx') call psb_error() endif @@ -74,8 +74,8 @@ subroutine smsrx(n,x,indx,idir,flag) if (iret == 0) call psb_ip_reord(n,x,indx,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='smsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='smsrx') call psb_error() endif return diff --git a/base/serial/aux/ssr.f90 b/base/serial/aux/ssr.f90 index 70ffc81ce..cda0b96fd 100644 --- a/base/serial/aux/ssr.f90 +++ b/base/serial/aux/ssr.f90 @@ -134,7 +134,7 @@ subroutine ssr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='ssr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='ssr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -258,7 +258,7 @@ subroutine ssr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='ssr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='ssr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine ssr(n,x,dir) endif case default - call psb_errpush(4001,r_name='ssr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='ssr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/ssrx.f90 b/base/serial/aux/ssrx.f90 index 1373e2157..464bbbdb5 100644 --- a/base/serial/aux/ssrx.f90 +++ b/base/serial/aux/ssrx.f90 @@ -58,7 +58,7 @@ subroutine ssrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='ssrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='wrong flag') call psb_error() end select ! @@ -162,7 +162,7 @@ subroutine ssrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='ssrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -301,7 +301,7 @@ subroutine ssrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='ssrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -346,7 +346,7 @@ subroutine ssrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='ssrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='ssrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/zalcmp_mod.f90 b/base/serial/aux/zalcmp_mod.f90 index 150b86db8..0e3f8eb1c 100644 --- a/base/serial/aux/zalcmp_mod.f90 +++ b/base/serial/aux/zalcmp_mod.f90 @@ -52,7 +52,7 @@ contains logical :: zallt zallt = (abs(real(a))abs(real(b))).or. & - & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>abs(aimag(b)))) + & ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>abs(aimag(b)))) end function zalgt function zalge(a,b) use psb_const_mod @@ -77,7 +77,7 @@ contains logical :: zalge zalge = (abs(real(a))>abs(real(b))).or. & - & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b)))) + & ((abs(real(a)) == abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b)))) end function zalge end module zalcmp_mod diff --git a/base/serial/aux/zalsr.f90 b/base/serial/aux/zalsr.f90 index 8081c8716..39ae73596 100644 --- a/base/serial/aux/zalsr.f90 +++ b/base/serial/aux/zalsr.f90 @@ -135,7 +135,7 @@ subroutine zalsr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zalsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zalsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -259,7 +259,7 @@ subroutine zalsr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zalsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zalsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -304,7 +304,7 @@ subroutine zalsr(n,x,dir) endif case default - call psb_errpush(4001,r_name='zalsr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='zalsr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/zalsrx.f90 b/base/serial/aux/zalsrx.f90 index d3911d998..2ee41ce2e 100644 --- a/base/serial/aux/zalsrx.f90 +++ b/base/serial/aux/zalsrx.f90 @@ -59,7 +59,7 @@ subroutine zalsrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='zalsrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='wrong flag') call psb_error() end select ! @@ -163,7 +163,7 @@ subroutine zalsrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zalsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine zalsrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zalsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -348,7 +348,7 @@ subroutine zalsrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='zalsrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='zalsrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/zamsort_dw.f90 b/base/serial/aux/zamsort_dw.f90 index 8053314d0..c4fa1cb99 100644 --- a/base/serial/aux/zamsort_dw.f90 +++ b/base/serial/aux/zamsort_dw.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/zamsort_up.f90 b/base/serial/aux/zamsort_up.f90 index 5fd0f2c0e..5caa4635b 100644 --- a/base/serial/aux/zamsort_up.f90 +++ b/base/serial/aux/zamsort_up.f90 @@ -50,7 +50,7 @@ ! lp = iaux(0) ! k = 1 ! do -! if ((lp==0).or.(k>n)) exit +! if ((lp == 0).or.(k>n)) exit ! do ! if (lp >= k) exit ! lp = iaux(lp) diff --git a/base/serial/aux/zamsr.f90 b/base/serial/aux/zamsr.f90 index c6d3baa1f..2b0cd3715 100644 --- a/base/serial/aux/zamsr.f90 +++ b/base/serial/aux/zamsr.f90 @@ -54,12 +54,12 @@ subroutine zamsr(n,x,idir) if (n<=1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='zamsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsr') call psb_error() endif - if (idir==psb_asort_up_) then + if (idir == psb_asort_up_) then call zamsort_up(n,x,iaux,iret) else call zamsort_dw(n,x,iaux,iret) @@ -68,8 +68,8 @@ subroutine zamsr(n,x,idir) if (iret == 0) call psb_ip_reord(n,x,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='zamsr') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsr') call psb_error() endif return diff --git a/base/serial/aux/zamsrx.f90 b/base/serial/aux/zamsrx.f90 index 12409f056..77b56791a 100644 --- a/base/serial/aux/zamsrx.f90 +++ b/base/serial/aux/zamsrx.f90 @@ -49,7 +49,7 @@ subroutine zamsrx(n,x,indx,idir,flag) return endif - if (n==0) return + if (n == 0) return if (flag == psb_sort_ovw_idx_) then do k=1,n @@ -57,11 +57,11 @@ subroutine zamsrx(n,x,indx,idir,flag) enddo end if - if (n==1) return + if (n == 1) return allocate(iaux(0:n+1),stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='zamsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsrx') call psb_error() endif @@ -74,8 +74,8 @@ subroutine zamsrx(n,x,indx,idir,flag) if (iret == 0) call psb_ip_reord(n,x,indx,iaux) deallocate(iaux,stat=info) - if (info/=0) then - call psb_errpush(4000,r_name='zamsrx') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='zamsrx') call psb_error() endif return diff --git a/base/serial/aux/zasr.f90 b/base/serial/aux/zasr.f90 index c274f902b..d99884a9d 100644 --- a/base/serial/aux/zasr.f90 +++ b/base/serial/aux/zasr.f90 @@ -135,7 +135,7 @@ subroutine zasr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -259,7 +259,7 @@ subroutine zasr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zasr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zasr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -304,7 +304,7 @@ subroutine zasr(n,x,dir) endif case default - call psb_errpush(4001,r_name='zasr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='zasr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/zasrx.f90 b/base/serial/aux/zasrx.f90 index 8a6c28baa..bb1a90ab6 100644 --- a/base/serial/aux/zasrx.f90 +++ b/base/serial/aux/zasrx.f90 @@ -59,7 +59,7 @@ subroutine zasrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='zasrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='wrong flag') call psb_error() end select ! @@ -163,7 +163,7 @@ subroutine zasrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine zasrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zasrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -348,7 +348,7 @@ subroutine zasrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='zasrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='zasrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/zlcmp_mod.f90 b/base/serial/aux/zlcmp_mod.f90 index 252a9d743..dac732956 100644 --- a/base/serial/aux/zlcmp_mod.f90 +++ b/base/serial/aux/zlcmp_mod.f90 @@ -51,14 +51,14 @@ contains complex(psb_dpk_), intent(in) :: a,b logical :: zllt - zllt = (real(a)real(b)).or.((real(a)==real(b)).and.(aimag(a)>aimag(b))) + zlgt = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>aimag(b))) end function zlgt function zlge(a,b) use psb_const_mod complex(psb_dpk_), intent(in) :: a,b logical :: zlge - zlge = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>=aimag(b))) + zlge = (real(a)>real(b)).or.((real(a) == real(b)).and.(aimag(a)>=aimag(b))) end function zlge end module zlcmp_mod diff --git a/base/serial/aux/zlsr.f90 b/base/serial/aux/zlsr.f90 index 57e281be2..79c28def4 100644 --- a/base/serial/aux/zlsr.f90 +++ b/base/serial/aux/zlsr.f90 @@ -135,7 +135,7 @@ subroutine zlsr(n,x,dir) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zlsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zlsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -259,7 +259,7 @@ subroutine zlsr(n,x,dir) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zlsr',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zlsr',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -304,7 +304,7 @@ subroutine zlsr(n,x,dir) endif case default - call psb_errpush(4001,r_name='zlsr',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='zlsr',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/aux/zlsrx.f90 b/base/serial/aux/zlsrx.f90 index 478e4d29e..ee28e6bec 100644 --- a/base/serial/aux/zlsrx.f90 +++ b/base/serial/aux/zlsrx.f90 @@ -59,7 +59,7 @@ subroutine zlsrx(n,x,indx,dir,flag) case(psb_sort_keep_idx_) ! do nothing case default - call psb_errpush(4001,r_name='zlsrx',a_err='wrong flag') + call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='wrong flag') call psb_error() end select ! @@ -163,7 +163,7 @@ subroutine zlsrx(n,x,indx,dir,flag) end do outer_up if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zlsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -303,7 +303,7 @@ subroutine zlsrx(n,x,indx,dir,flag) end do outer_dw if (i == ilx) then if (x(i) /= piv) then - call psb_errpush(4001,r_name='zlsrx',a_err='impossible pivot condition') + call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='impossible pivot condition') call psb_error() endif i = i + 1 @@ -348,7 +348,7 @@ subroutine zlsrx(n,x,indx,dir,flag) endif case default - call psb_errpush(4001,r_name='zlsrx',a_err='wrong dir') + call psb_errpush(psb_err_internal_error_,r_name='zlsrx',a_err='wrong dir') call psb_error() end select diff --git a/base/serial/f03/psb_base_mat_impl.f03 b/base/serial/f03/psb_base_mat_impl.f03 index 39526adbc..0ec6710c4 100644 --- a/base/serial/f03/psb_base_mat_impl.f03 +++ b/base/serial/f03/psb_base_mat_impl.f03 @@ -185,7 +185,7 @@ subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if(present(lev)) then lev_ = lev else @@ -196,9 +196,9 @@ subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) n = 0 ma = a%get_nrows() call a%csget(idx,idx,n,ia,ja,info) - if (info == 0) call psb_realloc(n,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info == psb_success_) call psb_realloc(n,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if neigh(1:n) = ja(1:n) @@ -207,8 +207,8 @@ subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) do nl = 2, lev_ n1 = ill - ifl + 1 call psb_ensure_size(ill+n1*n1,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if ntl = 0 @@ -216,9 +216,9 @@ subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) nidx=neigh(i) if ((nidx /= idx).and.(nidx > 0).and.(nidx <= ma)) then call a%csget(nidx,nidx,nn,ia,ja,info) - if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info == psb_success_) call psb_ensure_size(ill+ntl+nn,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) diff --git a/base/serial/f03/psb_c_base_mat_impl.f03 b/base/serial/f03/psb_c_base_mat_impl.f03 index 57a01d08c..d7d687705 100644 --- a/base/serial/f03/psb_c_base_mat_impl.f03 +++ b/base/serial/f03/psb_c_base_mat_impl.f03 @@ -1,4 +1,4 @@ -!==================================== +! == ================================== ! ! ! @@ -8,7 +8,7 @@ ! ! ! -!==================================== +! == ================================== subroutine psb_c_base_cp_to_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_coo @@ -317,7 +317,7 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -334,11 +334,11 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -375,7 +375,7 @@ subroutine psb_c_base_csclip(a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nzin = 0 if (present(imin)) then @@ -423,12 +423,12 @@ subroutine psb_c_base_csclip(a,b,info,& call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& & jmin=jmin_, jmax=jmax_, append=.false., & & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -458,16 +458,16 @@ subroutine psb_c_base_transp_2mat(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ select type(b) class is (psb_c_base_sparse_mat) call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) class default info = 700 end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt()) goto 9999 end if @@ -505,12 +505,12 @@ subroutine psb_c_base_transp_1mat(a) character(len=*), parameter :: name='c_base_transp' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= 0) then + if (info /= psb_success_) then info = 700 call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 @@ -537,7 +537,7 @@ subroutine psb_c_base_transc_1mat(a) end subroutine psb_c_base_transc_1mat -!==================================== +! == ================================== ! ! ! @@ -548,7 +548,7 @@ end subroutine psb_c_base_transc_1mat ! ! ! -!==================================== +! == ================================== subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csmm @@ -729,18 +729,18 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -752,21 +752,21 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(cone,x,czero,tmp,info,trans) - if (info == 0)then + if (info == psb_success_)then do i=1, nar tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else @@ -779,8 +779,8 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -865,14 +865,14 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) call inner_vscal(nac,d,x,tmp) - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -884,19 +884,19 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (beta == czero) then call a%inner_cssm(alpha,x,czero,y,info,trans) - if (info == 0) call inner_vscal1(nar,d,y) + if (info == psb_success_) call inner_vscal1(nar,d,y) else allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(alpha,x,czero,tmp,info,trans) - if (info == 0) call inner_vscal1(nar,d,tmp) - if (info == 0)& + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& & call psb_geaxpby(nar,cone,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -910,8 +910,8 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if diff --git a/base/serial/f03/psb_c_coo_impl.f03 b/base/serial/f03/psb_c_coo_impl.f03 index e32be6ad3..baccca36b 100644 --- a/base/serial/f03/psb_c_coo_impl.f03 +++ b/base/serial/f03/psb_c_coo_impl.f03 @@ -12,12 +12,12 @@ subroutine psb_c_coo_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -25,7 +25,7 @@ subroutine psb_c_coo_get_diag(a,d,info) do i=1,a%get_nzeros() j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -57,12 +57,12 @@ subroutine psb_c_coo_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) m = a%get_nrows() if (size(d) < m) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -99,7 +99,7 @@ subroutine psb_c_coo_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -136,8 +136,8 @@ subroutine psb_c_coo_reallocate_nz(nz,a) call psb_realloc(nz,a%ia,a%ja,a%val,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -171,7 +171,7 @@ subroutine psb_c_coo_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -219,13 +219,13 @@ subroutine psb_c_coo_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -254,14 +254,14 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -271,14 +271,14 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(0) @@ -287,7 +287,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) call a%set_unit(.false.) call a%set_dupl(psb_dupl_def_) end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -450,7 +450,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -471,8 +471,8 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -510,8 +510,8 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -524,8 +524,8 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_coosm') goto 9999 end if @@ -558,10 +558,10 @@ contains integer :: i,j,k,m, ir, jc complex(psb_spk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -806,7 +806,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_coo_cssv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -820,8 +820,8 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -857,7 +857,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -866,8 +866,8 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m), stat=info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -875,7 +875,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -910,7 +910,7 @@ contains integer :: i,j,k,m, ir, jc, nnz complex(psb_spk_) :: acc - info = 0 + info = psb_success_ if (.not.sorted) then info = 1121 return @@ -1151,7 +1151,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_coo_csmv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -1167,8 +1167,8 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') @@ -1348,7 +1348,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_coo_csmm_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1366,8 +1366,8 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) end if - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra) then @@ -1392,8 +1392,8 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2), size(y,2)) allocate(acc(nc),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1569,7 +1569,7 @@ end function psb_c_coo_csnmi -!==================================== +! == ================================== ! ! ! @@ -1579,7 +1579,7 @@ end function psb_c_coo_csnmi ! ! ! -!==================================== +! == ================================== @@ -1608,7 +1608,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1647,7 +1647,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1666,7 +1666,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1710,7 +1710,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1779,8 +1779,8 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -1811,8 +1811,8 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -1823,8 +1823,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = iren(a%ia(i)) ja(nzin_+k) = iren(a%ja(i)) @@ -1839,8 +1839,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = (a%ia(i)) @@ -1883,7 +1883,7 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1922,7 +1922,7 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1941,7 +1941,7 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1986,7 +1986,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -2055,9 +2055,9 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -2090,9 +2090,9 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -2103,9 +2103,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -2121,9 +2121,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) @@ -2160,30 +2160,30 @@ subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -2211,7 +2211,7 @@ subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call c_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -2219,7 +2219,7 @@ subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2252,7 +2252,7 @@ contains integer, intent(in), optional :: gtl(:) integer :: i,ir,ic,ng - info = 0 + info = psb_success_ if (present(gtl)) then ng = size(gtl) @@ -2314,7 +2314,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='c_coo_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2534,7 +2534,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) @@ -2546,7 +2546,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2578,7 +2578,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2589,7 +2589,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2621,11 +2621,11 @@ subroutine psb_c_cp_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2657,11 +2657,11 @@ subroutine psb_c_cp_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2693,7 +2693,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -2705,7 +2705,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2737,7 +2737,7 @@ subroutine psb_c_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2748,7 +2748,7 @@ subroutine psb_c_mv_coo_from_coo(a,b,info) call b%free() call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2780,11 +2780,11 @@ subroutine psb_c_mv_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2816,11 +2816,11 @@ subroutine psb_c_mv_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2851,9 +2851,9 @@ subroutine psb_c_coo_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%cp_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2884,9 +2884,9 @@ subroutine psb_c_coo_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2921,7 +2921,7 @@ subroutine psb_c_fix_coo(a,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -2942,7 +2942,7 @@ subroutine psb_c_fix_coo(a,info,idir) dupl_ = a%get_dupl() call psb_c_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() @@ -2983,7 +2983,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -3004,7 +3004,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) dupl_ = dupl allocate(iaux(nzin+2),stat=info) - if (info /= 0) return + if (info /= psb_success_) return select case(idir_) @@ -3074,7 +3074,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 @@ -3158,7 +3158,7 @@ subroutine psb_c_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 diff --git a/base/serial/f03/psb_c_csc_impl.f03 b/base/serial/f03/psb_c_csc_impl.f03 index d7a60aeda..d3ba85c7e 100644 --- a/base/serial/f03/psb_c_csc_impl.f03 +++ b/base/serial/f03/psb_c_csc_impl.f03 @@ -1,4 +1,4 @@ -!===================================== +! == =================================== ! ! ! @@ -9,7 +9,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -31,7 +31,7 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(trans)) then trans_ = trans @@ -47,8 +47,8 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra.or.ctra) then m = a%get_ncols() @@ -446,7 +446,7 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_csc_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -461,8 +461,8 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra.or.ctra) then m = a%get_ncols() @@ -488,8 +488,8 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2) , size(y,2) ) allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -870,7 +870,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_csc_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then trans_ = trans @@ -883,8 +883,8 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() @@ -937,7 +937,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) end if else allocate(tmp(m), stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if tmp(1:m) = x(1:m) @@ -1135,7 +1135,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -1150,8 +1150,8 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() nc = min(size(x,2) , size(y,2)) @@ -1197,8 +1197,8 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1211,8 +1211,8 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_cscsm') goto 9999 end if @@ -1244,10 +1244,10 @@ contains integer :: i,j,k,m, ir, jc complex(psb_spk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -1407,7 +1407,7 @@ function psb_c_csc_csnmi(a) result(res) nr = a%get_nrows() nc = a%get_ncols() allocate(acc(nr),stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if acc(:) = dzero @@ -1437,12 +1437,12 @@ subroutine psb_c_csc_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1451,7 +1451,7 @@ subroutine psb_c_csc_get_diag(a,d,info) do i=1, mnm do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j==i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo @@ -1486,12 +1486,12 @@ subroutine psb_c_csc_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) n = a%get_ncols() if (size(d) < n) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1529,7 +1529,7 @@ subroutine psb_c_csc_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1551,7 +1551,7 @@ subroutine psb_c_csc_scals(d,a,info) end subroutine psb_c_csc_scals -!===================================== +! == =================================== ! ! ! @@ -1561,7 +1561,7 @@ end subroutine psb_c_csc_scals ! ! ! -!===================================== +! == =================================== subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) @@ -1589,7 +1589,7 @@ subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1625,7 +1625,7 @@ subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1643,7 +1643,7 @@ subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1689,7 +1689,7 @@ contains icl = jmin lcl = min(jmax,a%get_ncols()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1706,9 +1706,9 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info /= psb_success_) return isz = min(size(ia),size(ja)) if (present(iren)) then do i=icl, lcl @@ -1778,7 +1778,7 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1814,7 +1814,7 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1833,7 +1833,7 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1881,7 +1881,7 @@ contains icl = jmin lcl = min(jmax,a%get_ncols()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1897,10 +1897,10 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) if (present(iren)) then do i=icl, lcl @@ -1964,29 +1964,29 @@ subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer :: nza, i,j,k, nzl, isza, int_err(5) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -2004,7 +2004,7 @@ subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_c_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -2013,7 +2013,7 @@ subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2053,7 +2053,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='c_csc_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2257,10 +2257,10 @@ subroutine psb_c_cp_csc_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) - if (info ==0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end subroutine psb_c_cp_csc_from_coo @@ -2284,7 +2284,7 @@ subroutine psb_c_cp_csc_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2327,7 +2327,7 @@ subroutine psb_c_mv_csc_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2338,7 +2338,7 @@ subroutine psb_c_mv_csc_to_coo(a,b,info) call move_alloc(a%ia,b%ia) call move_alloc(a%val,b%val) call psb_realloc(nza,b%ja,info) - if (info /= 0) return + if (info /= psb_success_) return do i=1, nc do j=a%icp(i),a%icp(i+1)-1 b%ja(j) = i @@ -2370,10 +2370,10 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ call b%fix(info, idir=1) - if (info /= 0) return + if (info /= psb_success_) return nr = b%get_nrows() nc = b%get_ncols() @@ -2460,7 +2460,7 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_c_coo_sparse_mat) @@ -2475,7 +2475,7 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info) class default call tmp%mv_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_c_mv_csc_to_fmt @@ -2500,7 +2500,7 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) @@ -2515,7 +2515,7 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info) class default call tmp%cp_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_c_cp_csc_to_fmt @@ -2540,7 +2540,7 @@ subroutine psb_c_mv_csc_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_c_coo_sparse_mat) @@ -2555,7 +2555,7 @@ subroutine psb_c_mv_csc_from_fmt(a,b,info) class default call tmp%mv_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_c_mv_csc_from_fmt @@ -2581,7 +2581,7 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_c_coo_sparse_mat) @@ -2595,7 +2595,7 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info) class default call tmp%cp_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_c_cp_csc_from_fmt @@ -2614,10 +2614,10 @@ subroutine psb_c_csc_reallocate_nz(nz,a) call psb_erractionsave(err_act) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -2659,7 +2659,7 @@ subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -2676,11 +2676,11 @@ subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2710,7 +2710,7 @@ subroutine psb_c_csc_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -2756,14 +2756,14 @@ subroutine psb_c_csc_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ n = a%get_ncols() nz = a%get_nzeros() - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2791,14 +2791,14 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -2808,15 +2808,15 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -2935,7 +2935,7 @@ subroutine psb_c_csc_cp_from(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) @@ -2943,7 +2943,7 @@ subroutine psb_c_csc_cp_from(a,b) a%ia = b%ia a%val = b%val - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2973,7 +2973,7 @@ subroutine psb_c_csc_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) call move_alloc(b%icp, a%icp) call move_alloc(b%ia, a%ia) diff --git a/base/serial/f03/psb_c_csr_impl.f03 b/base/serial/f03/psb_c_csr_impl.f03 index a4460a180..7d0a916d4 100644 --- a/base/serial/f03/psb_c_csr_impl.f03 +++ b/base/serial/f03/psb_c_csr_impl.f03 @@ -1,5 +1,5 @@ -!===================================== +! == =================================== ! ! ! @@ -10,7 +10,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -32,7 +32,7 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(trans)) then trans_ = trans @@ -47,8 +47,8 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra) then m = a%get_ncols() @@ -377,7 +377,7 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_csr_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -391,8 +391,8 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) call psb_errpush(info,name) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra) then m = a%get_ncols() @@ -417,8 +417,8 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2) , size(y,2) ) allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -727,7 +727,7 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_csr_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then trans_ = trans @@ -740,8 +740,8 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() if (.not. (a%is_triangle())) then @@ -792,7 +792,7 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) end if else allocate(tmp(m), stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if @@ -992,7 +992,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='c_csr_cssm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -1007,8 +1007,8 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() nc = min(size(x,2) , size(y,2)) @@ -1041,8 +1041,8 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1054,8 +1054,8 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_csrsm') goto 9999 end if @@ -1087,10 +1087,10 @@ contains integer :: i,j,k,m, ir, jc complex(psb_spk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -1276,12 +1276,12 @@ subroutine psb_c_csr_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1290,7 +1290,7 @@ subroutine psb_c_csr_get_diag(a,d,info) do i=1, mnm do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j==i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo @@ -1325,12 +1325,12 @@ subroutine psb_c_csr_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) m = a%get_nrows() if (size(d) < m) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1368,7 +1368,7 @@ subroutine psb_c_csr_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1392,7 +1392,7 @@ end subroutine psb_c_csr_scals -!===================================== +! == =================================== ! ! ! @@ -1402,7 +1402,7 @@ end subroutine psb_c_csr_scals ! ! ! -!===================================== +! == =================================== subroutine psb_c_csr_reallocate_nz(nz,a) @@ -1419,11 +1419,11 @@ subroutine psb_c_csr_reallocate_nz(nz,a) call psb_erractionsave(err_act) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(& + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -1455,14 +1455,14 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -1472,15 +1472,15 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -1530,7 +1530,7 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1569,7 +1569,7 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1587,7 +1587,7 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1631,7 +1631,7 @@ contains irw = imin lrw = min(imax,a%get_nrows()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1646,9 +1646,9 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info /= psb_success_) return if (present(iren)) then do i=irw, lrw @@ -1706,7 +1706,7 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1745,7 +1745,7 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1764,7 +1764,7 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1809,7 +1809,7 @@ contains irw = imin lrw = min(imax,a%get_nrows()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1824,10 +1824,10 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info /= psb_success_) return if (present(iren)) then do i=irw, lrw @@ -1881,7 +1881,7 @@ subroutine psb_c_csr_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -1898,11 +1898,11 @@ subroutine psb_c_csr_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1940,29 +1940,29 @@ subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -1980,7 +1980,7 @@ subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_c_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -1989,7 +1989,7 @@ subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2029,7 +2029,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='c_csr_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2221,7 +2221,7 @@ subroutine psb_c_csr_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -2267,15 +2267,15 @@ subroutine psb_c_csr_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ m = a%get_nrows() nz = a%get_nzeros() - if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2392,10 +2392,10 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) - if (info ==0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end subroutine psb_c_cp_csr_from_coo @@ -2419,7 +2419,7 @@ subroutine psb_c_cp_csr_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2461,7 +2461,7 @@ subroutine psb_c_mv_csr_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2472,7 +2472,7 @@ subroutine psb_c_mv_csr_to_coo(a,b,info) call move_alloc(a%ja,b%ja) call move_alloc(a%val,b%val) call psb_realloc(nza,b%ia,info) - if (info /= 0) return + if (info /= psb_success_) return do i=1, nr do j=a%irp(i),a%irp(i+1)-1 b%ia(j) = i @@ -2505,10 +2505,10 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ call b%fix(info) - if (info /= 0) return + if (info /= psb_success_) return nr = b%get_nrows() nc = b%get_ncols() @@ -2594,7 +2594,7 @@ subroutine psb_c_mv_csr_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_c_coo_sparse_mat) @@ -2609,7 +2609,7 @@ subroutine psb_c_mv_csr_to_fmt(a,b,info) class default call tmp%mv_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_c_mv_csr_to_fmt @@ -2633,7 +2633,7 @@ subroutine psb_c_cp_csr_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) @@ -2648,7 +2648,7 @@ subroutine psb_c_cp_csr_to_fmt(a,b,info) class default call tmp%cp_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_c_cp_csr_to_fmt @@ -2672,7 +2672,7 @@ subroutine psb_c_mv_csr_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_c_coo_sparse_mat) @@ -2687,7 +2687,7 @@ subroutine psb_c_mv_csr_from_fmt(a,b,info) class default call tmp%mv_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_c_mv_csr_from_fmt @@ -2712,7 +2712,7 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_c_coo_sparse_mat) @@ -2726,7 +2726,7 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info) class default call tmp%cp_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_c_cp_csr_from_fmt @@ -2746,7 +2746,7 @@ subroutine psb_c_csr_cp_from(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) @@ -2754,7 +2754,7 @@ subroutine psb_c_csr_cp_from(a,b) a%ja = b%ja a%val = b%val - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2784,7 +2784,7 @@ subroutine psb_c_csr_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) call move_alloc(b%irp, a%irp) call move_alloc(b%ja, a%ja) diff --git a/base/serial/f03/psb_c_mat_impl.f03 b/base/serial/f03/psb_c_mat_impl.f03 index f7bfeb3e3..f7cd5272b 100644 --- a/base/serial/f03/psb_c_mat_impl.f03 +++ b/base/serial/f03/psb_c_mat_impl.f03 @@ -1,4 +1,4 @@ -!===================================== +! == =================================== ! ! ! @@ -9,7 +9,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_c_set_nrows(m,a) @@ -444,7 +444,7 @@ end subroutine psb_c_set_upper -!===================================== +! == =================================== ! ! ! @@ -454,7 +454,7 @@ end subroutine psb_c_set_upper ! ! ! -!===================================== +! == =================================== subroutine psb_c_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) @@ -473,7 +473,7 @@ subroutine psb_c_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) character(len=20) :: name='sparse_print' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_get_erraction(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -513,7 +513,7 @@ subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) character(len=20) :: name='get_neigh' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -523,7 +523,7 @@ subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) call a%a%get_neigh(idx,neigh,n,info,lev) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -557,10 +557,10 @@ subroutine psb_c_csall(nr,nc,a,info,nz) call psb_get_erraction(err_act) - info = 0 + info = psb_success_ allocate(psb_c_coo_sparse_mat :: a%a, stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -691,7 +691,7 @@ subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) character(len=20) :: name='csput' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_bld()) then info = 1121 @@ -701,7 +701,7 @@ subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -740,7 +740,7 @@ subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -751,7 +751,7 @@ subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -791,7 +791,7 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -802,7 +802,7 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -844,7 +844,7 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,& type(psb_c_coo_sparse_mat), allocatable :: acoo - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -854,10 +854,10 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,& allocate(acoo,stat=info) - if (info == 0) call a%a%csget(imin,imax,acoo,info,& + if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -895,7 +895,7 @@ subroutine psb_c_csclip(a,b,info,& logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat), allocatable :: acoo - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -904,10 +904,10 @@ subroutine psb_c_csclip(a,b,info,& endif allocate(acoo,stat=info) - if (info == 0) call a%a%csclip(acoo,info,& + if (info == psb_success_) call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -942,7 +942,7 @@ subroutine psb_c_b_csclip(a,b,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -952,7 +952,7 @@ subroutine psb_c_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -988,7 +988,7 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) character(len=20) :: name='cscnv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1005,7 +1005,7 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) end if if (count( (/present(mold),present(type) /)) > 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1024,7 +1024,7 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) case ('CSC') allocate(psb_c_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1032,8 +1032,8 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) allocate(psb_c_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1043,8 +1043,8 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) call altmp%cp_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1085,7 +1085,7 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) character(len=20) :: name='cscnv_ip' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1101,7 +1101,7 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) end if if (count( (/present(mold),present(type) /)) > 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1120,7 +1120,7 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) case ('CSC') allocate(psb_c_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1128,8 +1128,8 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) allocate(psb_c_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1139,8 +1139,8 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) call altmp%mv_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1179,7 +1179,7 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) character(len=20) :: name='cscnv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1189,16 +1189,16 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) endif call a%a%cp_to_coo(altmp,info ) - if ((info == 0).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) - if (info == 0) call altmp%trim() - if (info == 0) call altmp%set_asb() - if (info == 0) call b%mv_from_coo(altmp,info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1236,7 +1236,7 @@ subroutine psb_c_clip_d(a,b,info) type(psb_c_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1245,9 +1245,9 @@ subroutine psb_c_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%cp_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1298,7 +1298,7 @@ subroutine psb_c_clip_d_ip(a,info) type(psb_c_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1307,9 +1307,9 @@ subroutine psb_c_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%mv_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1370,12 +1370,12 @@ subroutine psb_c_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1434,7 +1434,7 @@ subroutine psb_c_sparse_mat_move(a,b,info) character(len=20) :: name='move_alloc' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call move_alloc(a%a,b%a) return @@ -1455,12 +1455,12 @@ subroutine psb_c_sparse_mat_clone(a,b,info) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1534,8 +1534,8 @@ subroutine psb_c_transp_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transp(b%a) @@ -1611,8 +1611,8 @@ subroutine psb_c_transc_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transc(b%a) @@ -1668,7 +1668,7 @@ end subroutine psb_c_reinit -!===================================== +! == =================================== ! ! ! @@ -1679,7 +1679,7 @@ end subroutine psb_c_reinit ! ! ! -!===================================== +! == =================================== subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) @@ -1695,7 +1695,7 @@ subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1704,7 +1704,7 @@ subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1733,7 +1733,7 @@ subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1742,7 +1742,7 @@ subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1772,7 +1772,7 @@ subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1781,7 +1781,7 @@ subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) endif call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1812,7 +1812,7 @@ subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1822,7 +1822,7 @@ subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1894,7 +1894,7 @@ subroutine psb_c_get_diag(a,d,info) endif call a%a%get_diag(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1932,7 +1932,7 @@ subroutine psb_c_scal(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1970,7 +1970,7 @@ subroutine psb_c_scals(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/base/serial/f03/psb_d_base_mat_impl.f03 b/base/serial/f03/psb_d_base_mat_impl.f03 index e4de9c658..59cc841b5 100644 --- a/base/serial/f03/psb_d_base_mat_impl.f03 +++ b/base/serial/f03/psb_d_base_mat_impl.f03 @@ -1,4 +1,4 @@ -!==================================== +! == ================================== ! ! ! @@ -8,7 +8,7 @@ ! ! ! -!==================================== +! == ================================== subroutine psb_d_base_cp_to_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_coo @@ -317,7 +317,7 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -334,11 +334,11 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -375,7 +375,7 @@ subroutine psb_d_base_csclip(a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nzin = 0 if (present(imin)) then @@ -423,12 +423,12 @@ subroutine psb_d_base_csclip(a,b,info,& call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& & jmin=jmin_, jmax=jmax_, append=.false., & & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -458,16 +458,16 @@ subroutine psb_d_base_transp_2mat(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ select type(b) class is (psb_d_base_sparse_mat) call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) class default info = 700 end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt()) goto 9999 end if @@ -505,12 +505,12 @@ subroutine psb_d_base_transp_1mat(a) character(len=*), parameter :: name='d_base_transp' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= 0) then + if (info /= psb_success_) then info = 700 call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 @@ -537,7 +537,7 @@ subroutine psb_d_base_transc_1mat(a) end subroutine psb_d_base_transc_1mat -!==================================== +! == ================================== ! ! ! @@ -548,7 +548,7 @@ end subroutine psb_d_base_transc_1mat ! ! ! -!==================================== +! == ================================== subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csmm @@ -729,18 +729,18 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -752,21 +752,21 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(done,x,dzero,tmp,info,trans) - if (info == 0)then + if (info == psb_success_)then do i=1, nar tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else @@ -779,8 +779,8 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -865,14 +865,14 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) call inner_vscal(nac,d,x,tmp) - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -884,19 +884,19 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (beta == dzero) then call a%inner_cssm(alpha,x,dzero,y,info,trans) - if (info == 0) call inner_vscal1(nar,d,y) + if (info == psb_success_) call inner_vscal1(nar,d,y) else allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(alpha,x,dzero,tmp,info,trans) - if (info == 0) call inner_vscal1(nar,d,tmp) - if (info == 0)& + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& & call psb_geaxpby(nar,done,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -910,8 +910,8 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if diff --git a/base/serial/f03/psb_d_coo_impl.f03 b/base/serial/f03/psb_d_coo_impl.f03 index a1ee04779..88509e65e 100644 --- a/base/serial/f03/psb_d_coo_impl.f03 +++ b/base/serial/f03/psb_d_coo_impl.f03 @@ -12,12 +12,12 @@ subroutine psb_d_coo_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -25,7 +25,7 @@ subroutine psb_d_coo_get_diag(a,d,info) do i=1,a%get_nzeros() j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -57,12 +57,12 @@ subroutine psb_d_coo_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) m = a%get_nrows() if (size(d) < m) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -99,7 +99,7 @@ subroutine psb_d_coo_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -136,8 +136,8 @@ subroutine psb_d_coo_reallocate_nz(nz,a) call psb_realloc(nz,a%ia,a%ja,a%val,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -171,7 +171,7 @@ subroutine psb_d_coo_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -219,13 +219,13 @@ subroutine psb_d_coo_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -254,14 +254,14 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -271,14 +271,14 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(0) @@ -287,7 +287,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) call a%set_unit(.false.) call a%set_dupl(psb_dupl_def_) end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -450,7 +450,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -471,7 +471,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -509,8 +509,8 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -523,8 +523,8 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_coosm') goto 9999 end if @@ -557,10 +557,10 @@ contains integer :: i,j,k,m, ir, jc real(psb_dpk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -736,7 +736,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_coo_cssv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -750,7 +750,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -786,7 +786,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -795,8 +795,8 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m), stat=info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -804,7 +804,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -839,7 +839,7 @@ contains integer :: i,j,k,m, ir, jc, nnz real(psb_dpk_) :: acc - info = 0 + info = psb_success_ if (.not.sorted) then info = 1121 return @@ -1011,7 +1011,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_coo_csmv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -1027,7 +1027,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then @@ -1178,7 +1178,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_coo_csmm_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1196,7 +1196,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() @@ -1220,8 +1220,8 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2), size(y,2)) allocate(acc(nc),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1369,7 +1369,7 @@ end function psb_d_coo_csnmi -!==================================== +! == ================================== ! ! ! @@ -1379,7 +1379,7 @@ end function psb_d_coo_csnmi ! ! ! -!==================================== +! == ================================== @@ -1408,7 +1408,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1447,7 +1447,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1466,7 +1466,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1510,7 +1510,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1579,8 +1579,8 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -1611,8 +1611,8 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -1623,8 +1623,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = iren(a%ia(i)) ja(nzin_+k) = iren(a%ja(i)) @@ -1639,8 +1639,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = (a%ia(i)) @@ -1683,7 +1683,7 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1722,7 +1722,7 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1741,7 +1741,7 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1786,7 +1786,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1855,9 +1855,9 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -1890,9 +1890,9 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -1903,9 +1903,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -1921,9 +1921,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) @@ -1960,30 +1960,30 @@ subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -2011,7 +2011,7 @@ subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call d_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -2019,7 +2019,7 @@ subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2052,7 +2052,7 @@ contains integer, intent(in), optional :: gtl(:) integer :: i,ir,ic,ng - info = 0 + info = psb_success_ if (present(gtl)) then ng = size(gtl) @@ -2114,7 +2114,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='d_coo_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2334,7 +2334,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) @@ -2346,7 +2346,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2378,7 +2378,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2389,7 +2389,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2421,11 +2421,11 @@ subroutine psb_d_cp_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2457,11 +2457,11 @@ subroutine psb_d_cp_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2493,7 +2493,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -2505,7 +2505,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2537,7 +2537,7 @@ subroutine psb_d_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2548,7 +2548,7 @@ subroutine psb_d_mv_coo_from_coo(a,b,info) call b%free() call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2580,11 +2580,11 @@ subroutine psb_d_mv_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2616,11 +2616,11 @@ subroutine psb_d_mv_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2651,9 +2651,9 @@ subroutine psb_d_coo_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%cp_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2684,9 +2684,9 @@ subroutine psb_d_coo_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2721,7 +2721,7 @@ subroutine psb_d_fix_coo(a,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -2742,7 +2742,7 @@ subroutine psb_d_fix_coo(a,info,idir) dupl_ = a%get_dupl() call psb_d_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() @@ -2783,7 +2783,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -2804,7 +2804,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) dupl_ = dupl allocate(iaux(nzin+2),stat=info) - if (info /= 0) return + if (info /= psb_success_) return select case(idir_) @@ -2874,7 +2874,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 @@ -2958,7 +2958,7 @@ subroutine psb_d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 diff --git a/base/serial/f03/psb_d_csc_impl.f03 b/base/serial/f03/psb_d_csc_impl.f03 index 4c26df2df..53176ec9c 100644 --- a/base/serial/f03/psb_d_csc_impl.f03 +++ b/base/serial/f03/psb_d_csc_impl.f03 @@ -1,5 +1,5 @@ -!===================================== +! == =================================== ! ! ! @@ -10,7 +10,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -32,7 +32,7 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(trans)) then trans_ = trans @@ -47,7 +47,7 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() @@ -308,7 +308,7 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_csc_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -317,7 +317,7 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (.not.a%is_asb()) then info = 1121 call psb_errpush(info,name) @@ -348,8 +348,8 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2) , size(y,2) ) allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -593,7 +593,7 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_csc_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then trans_ = trans @@ -606,7 +606,7 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (.not. (a%is_triangle())) then @@ -658,7 +658,7 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) end if else allocate(tmp(m), stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if tmp(1:m) = x(1:m) @@ -813,7 +813,7 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -828,7 +828,7 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (size(x,1) 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1024,7 +1024,7 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) case ('CSC') allocate(psb_d_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1032,8 +1032,8 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) allocate(psb_d_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1043,8 +1043,8 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) call altmp%cp_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1085,7 +1085,7 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) character(len=20) :: name='cscnv_ip' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1101,7 +1101,7 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) end if if (count( (/present(mold),present(type) /)) > 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1120,7 +1120,7 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) case ('CSC') allocate(psb_d_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1128,8 +1128,8 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) allocate(psb_d_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1139,8 +1139,8 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) call altmp%mv_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1179,7 +1179,7 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) character(len=20) :: name='cscnv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1189,16 +1189,16 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) endif call a%a%cp_to_coo(altmp,info ) - if ((info == 0).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) - if (info == 0) call altmp%trim() - if (info == 0) call altmp%set_asb() - if (info == 0) call b%mv_from_coo(altmp,info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1236,7 +1236,7 @@ subroutine psb_d_clip_d(a,b,info) type(psb_d_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1245,9 +1245,9 @@ subroutine psb_d_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%cp_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1298,7 +1298,7 @@ subroutine psb_d_clip_d_ip(a,info) type(psb_d_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1307,9 +1307,9 @@ subroutine psb_d_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%mv_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1370,12 +1370,12 @@ subroutine psb_d_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1434,7 +1434,7 @@ subroutine psb_d_sparse_mat_move(a,b,info) character(len=20) :: name='move_alloc' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call move_alloc(a%a,b%a) return @@ -1455,12 +1455,12 @@ subroutine psb_d_sparse_mat_clone(a,b,info) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1534,8 +1534,8 @@ subroutine psb_d_transp_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transp(b%a) @@ -1611,8 +1611,8 @@ subroutine psb_d_transc_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transc(b%a) @@ -1668,7 +1668,7 @@ end subroutine psb_d_reinit -!===================================== +! == =================================== ! ! ! @@ -1679,7 +1679,7 @@ end subroutine psb_d_reinit ! ! ! -!===================================== +! == =================================== subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) @@ -1695,7 +1695,7 @@ subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1704,7 +1704,7 @@ subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1733,7 +1733,7 @@ subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1742,7 +1742,7 @@ subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1772,7 +1772,7 @@ subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1781,7 +1781,7 @@ subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) endif call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1812,7 +1812,7 @@ subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1822,7 +1822,7 @@ subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1894,7 +1894,7 @@ subroutine psb_d_get_diag(a,d,info) endif call a%a%get_diag(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1932,7 +1932,7 @@ subroutine psb_d_scal(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1970,7 +1970,7 @@ subroutine psb_d_scals(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/base/serial/f03/psb_s_base_mat_impl.f03 b/base/serial/f03/psb_s_base_mat_impl.f03 index e544acba0..7ede84589 100644 --- a/base/serial/f03/psb_s_base_mat_impl.f03 +++ b/base/serial/f03/psb_s_base_mat_impl.f03 @@ -1,4 +1,4 @@ -!==================================== +! == ================================== ! ! ! @@ -8,7 +8,7 @@ ! ! ! -!==================================== +! == ================================== subroutine psb_s_base_cp_to_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_coo @@ -317,7 +317,7 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -334,11 +334,11 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -375,7 +375,7 @@ subroutine psb_s_base_csclip(a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nzin = 0 if (present(imin)) then @@ -423,12 +423,12 @@ subroutine psb_s_base_csclip(a,b,info,& call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& & jmin=jmin_, jmax=jmax_, append=.false., & & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -458,16 +458,16 @@ subroutine psb_s_base_transp_2mat(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ select type(b) class is (psb_s_base_sparse_mat) call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) class default info = 700 end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt()) goto 9999 end if @@ -505,12 +505,12 @@ subroutine psb_s_base_transp_1mat(a) character(len=*), parameter :: name='s_base_transp' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= 0) then + if (info /= psb_success_) then info = 700 call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 @@ -537,7 +537,7 @@ subroutine psb_s_base_transc_1mat(a) end subroutine psb_s_base_transc_1mat -!==================================== +! == ================================== ! ! ! @@ -548,7 +548,7 @@ end subroutine psb_s_base_transc_1mat ! ! ! -!==================================== +! == ================================== subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csmm @@ -729,18 +729,18 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -752,21 +752,21 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(sone,x,szero,tmp,info,trans) - if (info == 0)then + if (info == psb_success_)then do i=1, nar tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else @@ -779,8 +779,8 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -865,14 +865,14 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) call inner_vscal(nac,d,x,tmp) - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -884,19 +884,19 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (beta == szero) then call a%inner_cssm(alpha,x,szero,y,info,trans) - if (info == 0) call inner_vscal1(nar,d,y) + if (info == psb_success_) call inner_vscal1(nar,d,y) else allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(alpha,x,szero,tmp,info,trans) - if (info == 0) call inner_vscal1(nar,d,tmp) - if (info == 0)& + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& & call psb_geaxpby(nar,sone,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -910,8 +910,8 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if diff --git a/base/serial/f03/psb_s_coo_impl.f03 b/base/serial/f03/psb_s_coo_impl.f03 index 30f6aa587..86e617e47 100644 --- a/base/serial/f03/psb_s_coo_impl.f03 +++ b/base/serial/f03/psb_s_coo_impl.f03 @@ -12,12 +12,12 @@ subroutine psb_s_coo_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -25,7 +25,7 @@ subroutine psb_s_coo_get_diag(a,d,info) do i=1,a%get_nzeros() j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -57,12 +57,12 @@ subroutine psb_s_coo_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) m = a%get_nrows() if (size(d) < m) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -99,7 +99,7 @@ subroutine psb_s_coo_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -136,8 +136,8 @@ subroutine psb_s_coo_reallocate_nz(nz,a) call psb_realloc(nz,a%ia,a%ja,a%val,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -171,7 +171,7 @@ subroutine psb_s_coo_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -219,13 +219,13 @@ subroutine psb_s_coo_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -254,14 +254,14 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -271,14 +271,14 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(0) @@ -287,7 +287,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) call a%set_unit(.false.) call a%set_dupl(psb_dupl_def_) end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -450,7 +450,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -471,7 +471,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -509,8 +509,8 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -523,8 +523,8 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_coosm') goto 9999 end if @@ -557,10 +557,10 @@ contains integer :: i,j,k,m, ir, jc real(psb_spk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -736,7 +736,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_coo_cssv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -750,7 +750,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -786,7 +786,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -795,8 +795,8 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m), stat=info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -804,7 +804,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -839,7 +839,7 @@ contains integer :: i,j,k,m, ir, jc, nnz real(psb_spk_) :: acc - info = 0 + info = psb_success_ if (.not.sorted) then info = 1121 return @@ -1011,7 +1011,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_coo_csmv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -1027,7 +1027,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then @@ -1178,7 +1178,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_coo_csmm_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1196,7 +1196,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() @@ -1220,8 +1220,8 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2), size(y,2)) allocate(acc(nc),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1369,7 +1369,7 @@ end function psb_s_coo_csnmi -!==================================== +! == ================================== ! ! ! @@ -1379,7 +1379,7 @@ end function psb_s_coo_csnmi ! ! ! -!==================================== +! == ================================== @@ -1408,7 +1408,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1447,7 +1447,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1466,7 +1466,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1510,7 +1510,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1579,8 +1579,8 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -1611,8 +1611,8 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -1623,8 +1623,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = iren(a%ia(i)) ja(nzin_+k) = iren(a%ja(i)) @@ -1639,8 +1639,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = (a%ia(i)) @@ -1683,7 +1683,7 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1722,7 +1722,7 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1741,7 +1741,7 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1786,7 +1786,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1855,9 +1855,9 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -1890,9 +1890,9 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -1903,9 +1903,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -1921,9 +1921,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) @@ -1960,30 +1960,30 @@ subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -2011,7 +2011,7 @@ subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call s_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -2019,7 +2019,7 @@ subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2052,7 +2052,7 @@ contains integer, intent(in), optional :: gtl(:) integer :: i,ir,ic,ng - info = 0 + info = psb_success_ if (present(gtl)) then ng = size(gtl) @@ -2114,7 +2114,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='s_coo_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2334,7 +2334,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) @@ -2346,7 +2346,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2378,7 +2378,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2389,7 +2389,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2421,11 +2421,11 @@ subroutine psb_s_cp_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2457,11 +2457,11 @@ subroutine psb_s_cp_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2493,7 +2493,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -2505,7 +2505,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2537,7 +2537,7 @@ subroutine psb_s_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2548,7 +2548,7 @@ subroutine psb_s_mv_coo_from_coo(a,b,info) call b%free() call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2580,11 +2580,11 @@ subroutine psb_s_mv_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2616,11 +2616,11 @@ subroutine psb_s_mv_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2651,9 +2651,9 @@ subroutine psb_s_coo_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%cp_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2684,9 +2684,9 @@ subroutine psb_s_coo_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2721,7 +2721,7 @@ subroutine psb_s_fix_coo(a,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -2742,7 +2742,7 @@ subroutine psb_s_fix_coo(a,info,idir) dupl_ = a%get_dupl() call psb_s_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() @@ -2783,7 +2783,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -2804,7 +2804,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) dupl_ = dupl allocate(iaux(nzin+2),stat=info) - if (info /= 0) return + if (info /= psb_success_) return select case(idir_) @@ -2874,7 +2874,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 @@ -2958,7 +2958,7 @@ subroutine psb_s_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 diff --git a/base/serial/f03/psb_s_csc_impl.f03 b/base/serial/f03/psb_s_csc_impl.f03 index 03b706df2..87f6c3d21 100644 --- a/base/serial/f03/psb_s_csc_impl.f03 +++ b/base/serial/f03/psb_s_csc_impl.f03 @@ -1,5 +1,5 @@ -!===================================== +! == =================================== ! ! ! @@ -10,7 +10,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -32,7 +32,7 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(trans)) then trans_ = trans @@ -47,7 +47,7 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() @@ -308,7 +308,7 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_csc_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -317,7 +317,7 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (.not.a%is_asb()) then info = 1121 call psb_errpush(info,name) @@ -348,8 +348,8 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2) , size(y,2) ) allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -593,7 +593,7 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_csc_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then trans_ = trans @@ -606,7 +606,7 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (.not. (a%is_triangle())) then @@ -658,7 +658,7 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) end if else allocate(tmp(m), stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if tmp(1:m) = x(1:m) @@ -814,7 +814,7 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='s_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -829,7 +829,7 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (size(x,1) 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1024,7 +1024,7 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) case ('CSC') allocate(psb_s_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1032,8 +1032,8 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) allocate(psb_s_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1043,8 +1043,8 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) call altmp%cp_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1085,7 +1085,7 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) character(len=20) :: name='cscnv_ip' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1101,7 +1101,7 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) end if if (count( (/present(mold),present(type) /)) > 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1120,7 +1120,7 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) case ('CSC') allocate(psb_s_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1128,8 +1128,8 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) allocate(psb_s_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1139,8 +1139,8 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) call altmp%mv_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1179,7 +1179,7 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) character(len=20) :: name='cscnv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1189,16 +1189,16 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) endif call a%a%cp_to_coo(altmp,info ) - if ((info == 0).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) - if (info == 0) call altmp%trim() - if (info == 0) call altmp%set_asb() - if (info == 0) call b%mv_from_coo(altmp,info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1236,7 +1236,7 @@ subroutine psb_s_clip_d(a,b,info) type(psb_s_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1245,9 +1245,9 @@ subroutine psb_s_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%cp_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1298,7 +1298,7 @@ subroutine psb_s_clip_d_ip(a,info) type(psb_s_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1307,9 +1307,9 @@ subroutine psb_s_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%mv_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1370,12 +1370,12 @@ subroutine psb_s_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1434,7 +1434,7 @@ subroutine psb_s_sparse_mat_move(a,b,info) character(len=20) :: name='move_alloc' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call move_alloc(a%a,b%a) return @@ -1455,12 +1455,12 @@ subroutine psb_s_sparse_mat_clone(a,b,info) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1534,8 +1534,8 @@ subroutine psb_s_transp_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transp(b%a) @@ -1611,8 +1611,8 @@ subroutine psb_s_transc_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transc(b%a) @@ -1668,7 +1668,7 @@ end subroutine psb_s_reinit -!===================================== +! == =================================== ! ! ! @@ -1679,7 +1679,7 @@ end subroutine psb_s_reinit ! ! ! -!===================================== +! == =================================== subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) @@ -1695,7 +1695,7 @@ subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1704,7 +1704,7 @@ subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1733,7 +1733,7 @@ subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1742,7 +1742,7 @@ subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1772,7 +1772,7 @@ subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1781,7 +1781,7 @@ subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) endif call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1812,7 +1812,7 @@ subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1822,7 +1822,7 @@ subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1894,7 +1894,7 @@ subroutine psb_s_get_diag(a,d,info) endif call a%a%get_diag(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1932,7 +1932,7 @@ subroutine psb_s_scal(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1970,7 +1970,7 @@ subroutine psb_s_scals(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/base/serial/f03/psb_z_base_mat_impl.f03 b/base/serial/f03/psb_z_base_mat_impl.f03 index e7f90efd8..09c6e2525 100644 --- a/base/serial/f03/psb_z_base_mat_impl.f03 +++ b/base/serial/f03/psb_z_base_mat_impl.f03 @@ -1,4 +1,4 @@ -!==================================== +! == ================================== ! ! ! @@ -8,7 +8,7 @@ ! ! ! -!==================================== +! == ================================== subroutine psb_z_base_cp_to_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_coo @@ -317,7 +317,7 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -334,11 +334,11 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -375,7 +375,7 @@ subroutine psb_z_base_csclip(a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nzin = 0 if (present(imin)) then @@ -423,12 +423,12 @@ subroutine psb_z_base_csclip(a,b,info,& call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& & jmin=jmin_, jmax=jmax_, append=.false., & & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -458,16 +458,16 @@ subroutine psb_z_base_transp_2mat(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ select type(b) class is (psb_z_base_sparse_mat) call b%cp_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) class default info = 700 end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt()) goto 9999 end if @@ -505,12 +505,12 @@ subroutine psb_z_base_transp_1mat(a) character(len=*), parameter :: name='z_base_transp' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_to_coo(tmp,info) - if (info == 0) call tmp%transp() - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= 0) then + if (info /= psb_success_) then info = 700 call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 @@ -537,7 +537,7 @@ subroutine psb_z_base_transc_1mat(a) end subroutine psb_z_base_transc_1mat -!==================================== +! == ================================== ! ! ! @@ -548,7 +548,7 @@ end subroutine psb_z_base_transc_1mat ! ! ! -!==================================== +! == ================================== subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csmm @@ -729,18 +729,18 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0) then + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -752,21 +752,21 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nar,nc),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(zone,x,zzero,tmp,info,trans) - if (info == 0)then + if (info == psb_success_)then do i=1, nar tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if - if (info == 0)& + if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else @@ -779,8 +779,8 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -865,14 +865,14 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) end if allocate(tmp(nac),stat=info) - if (info /= 0) info = 4000 - if (info == 0) call inner_vscal(nac,d,x,tmp) - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + if (info == psb_success_)& & call a%inner_cssm(alpha,tmp,beta,y,info,trans) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if else if (psb_toupper(scale_) == 'L') then @@ -884,19 +884,19 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (beta == zzero) then call a%inner_cssm(alpha,x,zzero,y,info,trans) - if (info == 0) call inner_vscal1(nar,d,y) + if (info == psb_success_) call inner_vscal1(nar,d,y) else allocate(tmp(nar),stat=info) - if (info /= 0) info = 4000 - if (info == 0)& + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_)& & call a%inner_cssm(alpha,x,zzero,tmp,info,trans) - if (info == 0) call inner_vscal1(nar,d,tmp) - if (info == 0)& + if (info == psb_success_) call inner_vscal1(nar,d,tmp) + if (info == psb_success_)& & call psb_geaxpby(nar,zone,tmp,beta,y,info) - if (info == 0) then + if (info == psb_success_) then deallocate(tmp,stat=info) - if (info /= 0) info = 4000 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -910,8 +910,8 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%inner_cssm(alpha,x,beta,y,info,trans) end if - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if diff --git a/base/serial/f03/psb_z_coo_impl.f03 b/base/serial/f03/psb_z_coo_impl.f03 index 8103e844d..1ff1314eb 100644 --- a/base/serial/f03/psb_z_coo_impl.f03 +++ b/base/serial/f03/psb_z_coo_impl.f03 @@ -12,12 +12,12 @@ subroutine psb_z_coo_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -25,7 +25,7 @@ subroutine psb_z_coo_get_diag(a,d,info) do i=1,a%get_nzeros() j=a%ia(i) - if ((j==a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -57,12 +57,12 @@ subroutine psb_z_coo_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) m = a%get_nrows() if (size(d) < m) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -99,7 +99,7 @@ subroutine psb_z_coo_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -136,8 +136,8 @@ subroutine psb_z_coo_reallocate_nz(nz,a) call psb_realloc(nz,a%ia,a%ja,a%val,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -171,7 +171,7 @@ subroutine psb_z_coo_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -219,13 +219,13 @@ subroutine psb_z_coo_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nz = a%get_nzeros() - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -254,14 +254,14 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -271,14 +271,14 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(0) @@ -287,7 +287,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) call a%set_unit(.false.) call a%set_dupl(psb_dupl_def_) end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -450,7 +450,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -471,8 +471,8 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -510,8 +510,8 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -524,8 +524,8 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_coosm') goto 9999 end if @@ -558,10 +558,10 @@ contains integer :: i,j,k,m, ir, jc complex(psb_dpk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -806,7 +806,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_coo_cssv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -820,8 +820,8 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() if (size(x,1) < m) then info = 36 @@ -857,7 +857,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -866,8 +866,8 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m), stat=info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -875,7 +875,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -910,7 +910,7 @@ contains integer :: i,j,k,m, ir, jc, nnz complex(psb_dpk_) :: acc - info = 0 + info = psb_success_ if (.not.sorted) then info = 1121 return @@ -1151,7 +1151,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_coo_csmv_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_asb()) then @@ -1167,8 +1167,8 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') @@ -1348,7 +1348,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_coo_csmm_impl' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1366,8 +1366,8 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) end if - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra) then @@ -1392,8 +1392,8 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2), size(y,2)) allocate(acc(nc),stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1569,7 +1569,7 @@ end function psb_z_coo_csnmi -!==================================== +! == ================================== ! ! ! @@ -1579,7 +1579,7 @@ end function psb_z_coo_csnmi ! ! ! -!==================================== +! == ================================== @@ -1608,7 +1608,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1647,7 +1647,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1666,7 +1666,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1710,7 +1710,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1779,8 +1779,8 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -1811,8 +1811,8 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -1823,8 +1823,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = iren(a%ia(i)) ja(nzin_+k) = iren(a%ja(i)) @@ -1839,8 +1839,8 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return end if ia(nzin_+k) = (a%ia(i)) @@ -1883,7 +1883,7 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1922,7 +1922,7 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1941,7 +1941,7 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1986,7 +1986,7 @@ contains irw = imin lrw = imax if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -2055,9 +2055,9 @@ contains nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then do i=ip,jp @@ -2090,9 +2090,9 @@ contains nzt = (nza*(lrw-irw+1))/max(a%get_nrows(),1) call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return if (present(iren)) then k = 0 @@ -2103,9 +2103,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -2121,9 +2121,9 @@ contains if (k > nzt) then nzt = k call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return end if val(nzin_+k) = a%val(i) @@ -2160,30 +2160,30 @@ subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -2211,7 +2211,7 @@ subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call z_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -2219,7 +2219,7 @@ subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2252,7 +2252,7 @@ contains integer, intent(in), optional :: gtl(:) integer :: i,ir,ic,ng - info = 0 + info = psb_success_ if (present(gtl)) then ng = size(gtl) @@ -2314,7 +2314,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='z_coo_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2534,7 +2534,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) @@ -2546,7 +2546,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2578,7 +2578,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2589,7 +2589,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2621,11 +2621,11 @@ subroutine psb_z_cp_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2657,11 +2657,11 @@ subroutine psb_z_cp_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%cp_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2693,7 +2693,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -2705,7 +2705,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2737,7 +2737,7 @@ subroutine psb_z_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) @@ -2748,7 +2748,7 @@ subroutine psb_z_mv_coo_from_coo(a,b,info) call b%free() call a%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2780,11 +2780,11 @@ subroutine psb_z_mv_coo_to_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_from_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2816,11 +2816,11 @@ subroutine psb_z_mv_coo_from_fmt(a,b,info) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call b%mv_to_coo(a,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2851,9 +2851,9 @@ subroutine psb_z_coo_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%cp_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2884,9 +2884,9 @@ subroutine psb_z_coo_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%mv_from_coo(b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2921,7 +2921,7 @@ subroutine psb_z_fix_coo(a,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -2942,7 +2942,7 @@ subroutine psb_z_fix_coo(a,info,idir) dupl_ = a%get_dupl() call psb_z_fix_coo_inner(nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call a%set_sorted() call a%set_nzeros(i) call a%set_asb() @@ -2983,7 +2983,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) integer :: debug_level, debug_unit character(len=20) :: name = 'psb_fixcoo' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -3004,7 +3004,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) dupl_ = dupl allocate(iaux(nzin+2),stat=info) - if (info /= 0) return + if (info /= psb_success_) return select case(idir_) @@ -3074,7 +3074,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 @@ -3158,7 +3158,7 @@ subroutine psb_z_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir) j = j + 1 if (j > nzin) exit if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(130,name) + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 diff --git a/base/serial/f03/psb_z_csc_impl.f03 b/base/serial/f03/psb_z_csc_impl.f03 index 02a260308..33a273f0c 100644 --- a/base/serial/f03/psb_z_csc_impl.f03 +++ b/base/serial/f03/psb_z_csc_impl.f03 @@ -1,5 +1,5 @@ -!===================================== +! == =================================== ! ! ! @@ -10,7 +10,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -32,7 +32,7 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(trans)) then trans_ = trans @@ -48,8 +48,8 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra.or.ctra) then m = a%get_ncols() @@ -447,7 +447,7 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_csc_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -462,8 +462,8 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra.or.ctra) then m = a%get_ncols() @@ -489,8 +489,8 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2) , size(y,2) ) allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -871,7 +871,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_csc_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then trans_ = trans @@ -884,8 +884,8 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() @@ -938,7 +938,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) end if else allocate(tmp(m), stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if tmp(1:m) = x(1:m) @@ -1136,7 +1136,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -1151,8 +1151,8 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() nc = min(size(x,2) , size(y,2)) @@ -1198,8 +1198,8 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1212,8 +1212,8 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_cscsm') goto 9999 end if @@ -1245,10 +1245,10 @@ contains integer :: i,j,k,m, ir, jc complex(psb_dpk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -1408,7 +1408,7 @@ function psb_z_csc_csnmi(a) result(res) nr = a%get_nrows() nc = a%get_ncols() allocate(acc(nr),stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if acc(:) = dzero @@ -1438,12 +1438,12 @@ subroutine psb_z_csc_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1452,7 +1452,7 @@ subroutine psb_z_csc_get_diag(a,d,info) do i=1, mnm do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j==i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo @@ -1487,12 +1487,12 @@ subroutine psb_z_csc_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) n = a%get_ncols() if (size(d) < n) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1530,7 +1530,7 @@ subroutine psb_z_csc_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1552,7 +1552,7 @@ subroutine psb_z_csc_scals(d,a,info) end subroutine psb_z_csc_scals -!===================================== +! == =================================== ! ! ! @@ -1562,7 +1562,7 @@ end subroutine psb_z_csc_scals ! ! ! -!===================================== +! == =================================== subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) @@ -1590,7 +1590,7 @@ subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1626,7 +1626,7 @@ subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1644,7 +1644,7 @@ subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1690,7 +1690,7 @@ contains icl = jmin lcl = min(jmax,a%get_ncols()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1707,9 +1707,9 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info /= psb_success_) return isz = min(size(ia),size(ja)) if (present(iren)) then do i=icl, lcl @@ -1779,7 +1779,7 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1815,7 +1815,7 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1834,7 +1834,7 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1882,7 +1882,7 @@ contains icl = jmin lcl = min(jmax,a%get_ncols()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1898,10 +1898,10 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) if (present(iren)) then do i=icl, lcl @@ -1965,29 +1965,29 @@ subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer :: nza, i,j,k, nzl, isza, int_err(5) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -2005,7 +2005,7 @@ subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_z_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -2014,7 +2014,7 @@ subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2054,7 +2054,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='z_csc_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2258,10 +2258,10 @@ subroutine psb_z_cp_csc_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) - if (info ==0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end subroutine psb_z_cp_csc_from_coo @@ -2285,7 +2285,7 @@ subroutine psb_z_cp_csc_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2328,7 +2328,7 @@ subroutine psb_z_mv_csc_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2339,7 +2339,7 @@ subroutine psb_z_mv_csc_to_coo(a,b,info) call move_alloc(a%ia,b%ia) call move_alloc(a%val,b%val) call psb_realloc(nza,b%ja,info) - if (info /= 0) return + if (info /= psb_success_) return do i=1, nc do j=a%icp(i),a%icp(i+1)-1 b%ja(j) = i @@ -2371,10 +2371,10 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ call b%fix(info, idir=1) - if (info /= 0) return + if (info /= psb_success_) return nr = b%get_nrows() nc = b%get_ncols() @@ -2461,7 +2461,7 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_z_coo_sparse_mat) @@ -2476,7 +2476,7 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info) class default call tmp%mv_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_z_mv_csc_to_fmt @@ -2501,7 +2501,7 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) @@ -2516,7 +2516,7 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info) class default call tmp%cp_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_z_cp_csc_to_fmt @@ -2541,7 +2541,7 @@ subroutine psb_z_mv_csc_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_z_coo_sparse_mat) @@ -2556,7 +2556,7 @@ subroutine psb_z_mv_csc_from_fmt(a,b,info) class default call tmp%mv_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_z_mv_csc_from_fmt @@ -2582,7 +2582,7 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_z_coo_sparse_mat) @@ -2596,7 +2596,7 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info) class default call tmp%cp_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_z_cp_csc_from_fmt @@ -2615,10 +2615,10 @@ subroutine psb_z_csc_reallocate_nz(nz,a) call psb_erractionsave(err_act) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -2660,7 +2660,7 @@ subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -2677,11 +2677,11 @@ subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2711,7 +2711,7 @@ subroutine psb_z_csc_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -2757,14 +2757,14 @@ subroutine psb_z_csc_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ n = a%get_ncols() nz = a%get_nzeros() - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz,a%ia,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2792,14 +2792,14 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -2809,15 +2809,15 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(n+1,a%icp,info) - if (info == 0) call psb_realloc(nz_,a%ia,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -2936,7 +2936,7 @@ subroutine psb_z_csc_cp_from(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) @@ -2944,7 +2944,7 @@ subroutine psb_z_csc_cp_from(a,b) a%ia = b%ia a%val = b%val - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2974,7 +2974,7 @@ subroutine psb_z_csc_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) call move_alloc(b%icp, a%icp) call move_alloc(b%ia, a%ia) diff --git a/base/serial/f03/psb_z_csr_impl.f03 b/base/serial/f03/psb_z_csr_impl.f03 index 6f3958b57..bd2931cef 100644 --- a/base/serial/f03/psb_z_csr_impl.f03 +++ b/base/serial/f03/psb_z_csr_impl.f03 @@ -1,5 +1,5 @@ -!===================================== +! == =================================== ! ! ! @@ -10,7 +10,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -32,7 +32,7 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(trans)) then trans_ = trans @@ -47,8 +47,8 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra) then m = a%get_ncols() @@ -377,7 +377,7 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_csr_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -391,8 +391,8 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) call psb_errpush(info,name) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') if (tra) then m = a%get_ncols() @@ -417,8 +417,8 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) nc = min(size(x,2) , size(y,2) ) allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -727,7 +727,7 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_csr_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then trans_ = trans @@ -740,8 +740,8 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() if (.not. (a%is_triangle())) then @@ -792,7 +792,7 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) end if else allocate(tmp(m), stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if @@ -992,7 +992,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='z_csr_cssm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -1007,8 +1007,8 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T') - ctra = (psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T') + ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() nc = min(size(x,2) , size(y,2)) @@ -1041,8 +1041,8 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -1054,8 +1054,8 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_csrsm') goto 9999 end if @@ -1087,10 +1087,10 @@ contains integer :: i,j,k,m, ir, jc complex(psb_dpk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -1276,12 +1276,12 @@ subroutine psb_z_csr_get_diag(a,d,info) character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1290,7 +1290,7 @@ subroutine psb_z_csr_get_diag(a,d,info) do i=1, mnm do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j==i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo @@ -1325,12 +1325,12 @@ subroutine psb_z_csr_scal(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) m = a%get_nrows() if (size(d) < m) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1368,7 +1368,7 @@ subroutine psb_z_csr_scals(d,a,info) character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -1392,7 +1392,7 @@ end subroutine psb_z_csr_scals -!===================================== +! == =================================== ! ! ! @@ -1402,7 +1402,7 @@ end subroutine psb_z_csr_scals ! ! ! -!===================================== +! == =================================== subroutine psb_z_csr_reallocate_nz(nz,a) @@ -1419,11 +1419,11 @@ subroutine psb_z_csr_reallocate_nz(nz,a) call psb_erractionsave(err_act) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(& + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -1455,14 +1455,14 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -1472,15 +1472,15 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -1530,7 +1530,7 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1569,7 +1569,7 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1587,7 +1587,7 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1631,7 +1631,7 @@ contains irw = imin lrw = min(imax,a%get_nrows()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1646,9 +1646,9 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info /= psb_success_) return if (present(iren)) then do i=irw, lrw @@ -1706,7 +1706,7 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1745,7 +1745,7 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1764,7 +1764,7 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1809,7 +1809,7 @@ contains irw = imin lrw = min(imax,a%get_nrows()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1824,10 +1824,10 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info /= psb_success_) return if (present(iren)) then do i=irw, lrw @@ -1881,7 +1881,7 @@ subroutine psb_z_csr_csgetblk(imin,imax,a,b,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -1898,11 +1898,11 @@ subroutine psb_z_csr_csgetblk(imin,imax,a,b,info,& & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1940,29 +1940,29 @@ subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -1980,7 +1980,7 @@ subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call psb_z_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -1989,7 +1989,7 @@ subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -2029,7 +2029,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='z_csr_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2221,7 +2221,7 @@ subroutine psb_z_csr_reinit(a,clear) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -2267,15 +2267,15 @@ subroutine psb_z_csr_trim(a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ m = a%get_nrows() nz = a%get_nzeros() - if (info == 0) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2392,10 +2392,10 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) - if (info ==0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end subroutine psb_z_cp_csr_from_coo @@ -2419,7 +2419,7 @@ subroutine psb_z_cp_csr_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2461,7 +2461,7 @@ subroutine psb_z_mv_csr_to_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -2472,7 +2472,7 @@ subroutine psb_z_mv_csr_to_coo(a,b,info) call move_alloc(a%ja,b%ja) call move_alloc(a%val,b%val) call psb_realloc(nza,b%ia,info) - if (info /= 0) return + if (info /= psb_success_) return do i=1, nr do j=a%irp(i),a%irp(i+1)-1 b%ia(j) = i @@ -2505,10 +2505,10 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ call b%fix(info) - if (info /= 0) return + if (info /= psb_success_) return nr = b%get_nrows() nc = b%get_ncols() @@ -2594,7 +2594,7 @@ subroutine psb_z_mv_csr_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_z_coo_sparse_mat) @@ -2609,7 +2609,7 @@ subroutine psb_z_mv_csr_to_fmt(a,b,info) class default call tmp%mv_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_z_mv_csr_to_fmt @@ -2633,7 +2633,7 @@ subroutine psb_z_cp_csr_to_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) @@ -2648,7 +2648,7 @@ subroutine psb_z_cp_csr_to_fmt(a,b,info) class default call tmp%cp_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine psb_z_cp_csr_to_fmt @@ -2672,7 +2672,7 @@ subroutine psb_z_mv_csr_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_z_coo_sparse_mat) @@ -2687,7 +2687,7 @@ subroutine psb_z_mv_csr_from_fmt(a,b,info) class default call tmp%mv_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_z_mv_csr_from_fmt @@ -2712,7 +2712,7 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_z_coo_sparse_mat) @@ -2726,7 +2726,7 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info) class default call tmp%cp_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine psb_z_cp_csr_from_fmt @@ -2746,7 +2746,7 @@ subroutine psb_z_csr_cp_from(a,b) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) @@ -2754,7 +2754,7 @@ subroutine psb_z_csr_cp_from(a,b) a%ja = b%ja a%val = b%val - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2784,7 +2784,7 @@ subroutine psb_z_csr_mv_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) call move_alloc(b%irp, a%irp) call move_alloc(b%ja, a%ja) diff --git a/base/serial/f03/psb_z_mat_impl.f03 b/base/serial/f03/psb_z_mat_impl.f03 index 96ba40331..0c3659a02 100644 --- a/base/serial/f03/psb_z_mat_impl.f03 +++ b/base/serial/f03/psb_z_mat_impl.f03 @@ -1,4 +1,4 @@ -!===================================== +! == =================================== ! ! ! @@ -9,7 +9,7 @@ ! ! ! -!===================================== +! == =================================== subroutine psb_z_set_nrows(m,a) @@ -444,7 +444,7 @@ end subroutine psb_z_set_upper -!===================================== +! == =================================== ! ! ! @@ -454,7 +454,7 @@ end subroutine psb_z_set_upper ! ! ! -!===================================== +! == =================================== subroutine psb_z_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) @@ -473,7 +473,7 @@ subroutine psb_z_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) character(len=20) :: name='sparse_print' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_get_erraction(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -513,7 +513,7 @@ subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) character(len=20) :: name='get_neigh' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -523,7 +523,7 @@ subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) call a%a%get_neigh(idx,neigh,n,info,lev) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -557,10 +557,10 @@ subroutine psb_z_csall(nr,nc,a,info,nz) call psb_get_erraction(err_act) - info = 0 + info = psb_success_ allocate(psb_z_coo_sparse_mat :: a%a, stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -691,7 +691,7 @@ subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) character(len=20) :: name='csput' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.a%is_bld()) then info = 1121 @@ -701,7 +701,7 @@ subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -740,7 +740,7 @@ subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -751,7 +751,7 @@ subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -791,7 +791,7 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& character(len=20) :: name='csget' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -802,7 +802,7 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -844,7 +844,7 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,& type(psb_z_coo_sparse_mat), allocatable :: acoo - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -854,10 +854,10 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,& allocate(acoo,stat=info) - if (info == 0) call a%a%csget(imin,imax,acoo,info,& + if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -895,7 +895,7 @@ subroutine psb_z_csclip(a,b,info,& logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat), allocatable :: acoo - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -904,10 +904,10 @@ subroutine psb_z_csclip(a,b,info,& endif allocate(acoo,stat=info) - if (info == 0) call a%a%csclip(acoo,info,& + if (info == psb_success_) call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info == 0) call move_alloc(acoo,b%a) - if (info /= 0) goto 9999 + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -942,7 +942,7 @@ subroutine psb_z_b_csclip(a,b,info,& character(len=20) :: name='csclip' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -952,7 +952,7 @@ subroutine psb_z_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -988,7 +988,7 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) character(len=20) :: name='cscnv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1005,7 +1005,7 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) end if if (count( (/present(mold),present(type) /)) > 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1024,7 +1024,7 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) case ('CSC') allocate(psb_z_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1032,8 +1032,8 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) allocate(psb_z_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1043,8 +1043,8 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) call altmp%cp_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1085,7 +1085,7 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) character(len=20) :: name='cscnv_ip' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1101,7 +1101,7 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) end if if (count( (/present(mold),present(type) /)) > 1) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='TYPE, MOLD') goto 9999 end if @@ -1120,7 +1120,7 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) case ('CSC') allocate(psb_z_csc_sparse_mat :: altmp, stat=info) case default - info = 136 + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select @@ -1128,8 +1128,8 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) allocate(psb_z_csr_sparse_mat :: altmp, stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -1139,8 +1139,8 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) call altmp%mv_from_fmt(a%a, info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1179,7 +1179,7 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) character(len=20) :: name='cscnv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then @@ -1189,16 +1189,16 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) endif call a%a%cp_to_coo(altmp,info ) - if ((info == 0).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) - if (info == 0) call altmp%trim() - if (info == 0) call altmp%set_asb() - if (info == 0) call b%mv_from_coo(altmp,info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err="mv_from") goto 9999 end if @@ -1236,7 +1236,7 @@ subroutine psb_z_clip_d(a,b,info) type(psb_z_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1245,9 +1245,9 @@ subroutine psb_z_clip_d(a,b,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%cp_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1298,7 +1298,7 @@ subroutine psb_z_clip_d_ip(a,info) type(psb_z_coo_sparse_mat), allocatable :: acoo integer :: i, j, nz - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (a%is_null()) then info = 1121 @@ -1307,9 +1307,9 @@ subroutine psb_z_clip_d_ip(a,info) endif allocate(acoo,stat=info) - if (info == 0) call a%a%mv_to_coo(acoo,info) - if (info /= 0) then - info = 4000 + if (info == psb_success_) call a%a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -1370,12 +1370,12 @@ subroutine psb_z_cp_from(a,b) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(a%a,source=b,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call a%a%cp_from_fmt(b, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1434,7 +1434,7 @@ subroutine psb_z_sparse_mat_move(a,b,info) character(len=20) :: name='move_alloc' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call move_alloc(a%a,b%a) return @@ -1455,12 +1455,12 @@ subroutine psb_z_sparse_mat_clone(a,b,info) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ allocate(b%a,source=a%a,stat=info) - if (info /= 0) info = 4000 - if (info == 0) call b%a%cp_from_fmt(a%a, info) - if (info /= 0) goto 9999 + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%a%cp_from_fmt(a%a, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1534,8 +1534,8 @@ subroutine psb_z_transp_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transp(b%a) @@ -1611,8 +1611,8 @@ subroutine psb_z_transc_2mat(a,b) endif allocate(a%a,source=b%a,stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ goto 9999 end if call a%a%transc(b%a) @@ -1668,7 +1668,7 @@ end subroutine psb_z_reinit -!===================================== +! == =================================== ! ! ! @@ -1679,7 +1679,7 @@ end subroutine psb_z_reinit ! ! ! -!===================================== +! == =================================== subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) @@ -1695,7 +1695,7 @@ subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1704,7 +1704,7 @@ subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1733,7 +1733,7 @@ subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) character(len=20) :: name='psb_csmv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1742,7 +1742,7 @@ subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) endif call a%a%csmm(alpha,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1772,7 +1772,7 @@ subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1781,7 +1781,7 @@ subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) endif call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1812,7 +1812,7 @@ subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) character(len=20) :: name='psb_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -1822,7 +1822,7 @@ subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) call a%a%cssm(alpha,x,beta,y,info,trans,scale,d) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1894,7 +1894,7 @@ subroutine psb_z_get_diag(a,d,info) endif call a%a%get_diag(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1932,7 +1932,7 @@ subroutine psb_z_scal(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1970,7 +1970,7 @@ subroutine psb_z_scals(d,a,info) endif call a%a%scal(d,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/base/serial/f77/caxpby.f b/base/serial/f77/caxpby.f index b807acacf..912dcdf61 100644 --- a/base/serial/f77/caxpby.f +++ b/base/serial/f77/caxpby.f @@ -45,21 +45,21 @@ C C C Error handling C - info = 0 + info = psb_success_ if (m.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 else if (n.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldx.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 int_err(3)=lldx @@ -67,7 +67,7 @@ C call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldy.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 int_err(3)=lldy diff --git a/base/serial/f77/daxpby.f b/base/serial/f77/daxpby.f index 24d9d729f..9516b50a6 100644 --- a/base/serial/f77/daxpby.f +++ b/base/serial/f77/daxpby.f @@ -43,21 +43,21 @@ C C C Error handling C - info = 0 + info = psb_success_ if (m.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 else if (n.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldx.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 int_err(3)=lldx @@ -65,7 +65,7 @@ C call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldy.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 int_err(3)=lldy diff --git a/base/serial/f77/saxpby.f b/base/serial/f77/saxpby.f index 0a2134161..b0711c619 100644 --- a/base/serial/f77/saxpby.f +++ b/base/serial/f77/saxpby.f @@ -44,21 +44,21 @@ C C C Error handling C - info = 0 + info = psb_success_ if (m.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 else if (n.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldx.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 int_err(3)=lldx @@ -66,7 +66,7 @@ C call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldy.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 int_err(3)=lldy diff --git a/base/serial/f77/smmp.f b/base/serial/f77/smmp.f index 4e8900f14..6f48691ea 100644 --- a/base/serial/f77/smmp.f +++ b/base/serial/f77/smmp.f @@ -1,4 +1,4 @@ -c======================================================================= +c == ===================================================================== c Sparse Matrix Multiplication Package c c Randolph E. Bank and Craig C. Douglas @@ -9,7 +9,7 @@ c Compile this with the following command (or a similar one): c c f77 -c -O smmp.f c -c======================================================================= +c == ===================================================================== subroutine symbmm * (n, m, l, * ia, ja, diaga, @@ -44,7 +44,7 @@ c$$$ enddo if (size(ic) < n+1) then write(0,*) 'Called realloc in SYMBMM ' call psb_realloc(n+1,ic,info) - if (info /=0) then + if (info /= psb_success_) then write(0,*) 'realloc failed in SYMBMM ',info end if endif @@ -187,7 +187,7 @@ c c = d + ... c(i) = temp(i) temp(i) = 0. endif -c$$$ if (mod(i,100)==1) +c$$$ if (mod(i,100) == 1) c$$$ + write(0,*) ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 do 40 j = ic(i),ic(i+1)-1 if((jc(j)<1).or. (jc(j) > maxlmn)) then @@ -256,7 +256,7 @@ c c = d + ... c(i) = temp(i) temp(i) = 0. endif -c$$$ if (mod(i,100)==1) +c$$$ if (mod(i,100) == 1) c$$$ + write(0,*) ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 do 40 j = ic(i),ic(i+1)-1 if((jc(j)<1).or. (jc(j) > maxlmn)) then @@ -325,7 +325,7 @@ c c = d + ... c(i) = temp(i) temp(i) = 0. endif -c$$$ if (mod(i,100)==1) +c$$$ if (mod(i,100) == 1) c$$$ + write(0,*) ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 do 40 j = ic(i),ic(i+1)-1 if((jc(j)<1).or. (jc(j) > maxlmn)) then @@ -394,7 +394,7 @@ c c = d + ... c(i) = temp(i) temp(i) = 0. endif -c$$$ if (mod(i,100)==1) +c$$$ if (mod(i,100) == 1) c$$$ + write(0,*) ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 do 40 j = ic(i),ic(i+1)-1 if((jc(j)<1).or. (jc(j) > maxlmn)) then diff --git a/base/serial/f77/zaxpby.f b/base/serial/f77/zaxpby.f index c4f5237e4..c3e5b1d35 100644 --- a/base/serial/f77/zaxpby.f +++ b/base/serial/f77/zaxpby.f @@ -45,21 +45,21 @@ C C C Error handling C - info = 0 + info = psb_success_ if (m.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 else if (n.lt.0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldx.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 int_err(3)=lldx @@ -67,7 +67,7 @@ C call fcpsb_errpush(info,name,int_err) goto 9999 else if (lldy.lt.max(1,m)) then - info=50 + info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 int_err(3)=lldy diff --git a/base/serial/psb_cnumbmm.f90 b/base/serial/psb_cnumbmm.f90 index 12625d55a..6bdaf70d0 100644 --- a/base/serial/psb_cnumbmm.f90 +++ b/base/serial/psb_cnumbmm.f90 @@ -51,7 +51,7 @@ subroutine psb_cnumbmm(a,b,c) character(len=*), parameter :: name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then info = 1121 @@ -99,7 +99,7 @@ subroutine psb_cbase_numbmm(a,b,c) integer :: err_act name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() @@ -112,8 +112,8 @@ subroutine psb_cbase_numbmm(a,b,c) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(temp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -135,7 +135,7 @@ subroutine psb_cbase_numbmm(a,b,c) call gen_numbmm(a,b,c,temp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -163,7 +163,7 @@ contains integer, intent(out) :: info integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -192,8 +192,8 @@ contains maxlmn = max(l,m,n) allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & aval(maxlmn),bval(maxlmn), stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -219,7 +219,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn - info = 2 + info = psb_err_pivot_too_small_ return else temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) @@ -229,7 +229,7 @@ contains do j = c%irp(i),c%irp(i+1)-1 if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then write(0,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn - info = 3 + info = psb_err_invalid_ovr_num_ return else c%val(j) = temp(c%ja(j)) diff --git a/base/serial/psb_crwextd.f90 b/base/serial/psb_crwextd.f90 index cb89f53ca..da51d7579 100644 --- a/base/serial/psb_crwextd.f90 +++ b/base/serial/psb_crwextd.f90 @@ -55,7 +55,7 @@ subroutine psb_crwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_crwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nr > a%get_nrows()) then @@ -74,17 +74,17 @@ subroutine psb_crwextd(nr,a,info,b,rowscale) end if class default call aa%mv_to_coo(actmp,info) - if (info == 0) then + if (info == psb_success_) then if (present(b)) then call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) else call psb_rwextd(nr,actmp,info,rowscale=rowscale) end if end if - if (info == 0) call aa%mv_from_coo(actmp,info) + if (info == psb_success_) call aa%mv_from_coo(actmp,info) end select end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -114,7 +114,7 @@ subroutine psb_cbase_rwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_cbase_rwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(rowscale)) then @@ -232,7 +232,7 @@ subroutine psb_cbase_rwextd(nr,a,info,b,rowscale) call a%set_nrows(nr) class default - info = 135 + info = psb_err_unsupported_format_ ch_err=a%get_fmt() call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/serial/psb_csymbmm.f90 b/base/serial/psb_csymbmm.f90 index e694d6452..81a6a9490 100644 --- a/base/serial/psb_csymbmm.f90 +++ b/base/serial/psb_csymbmm.f90 @@ -50,7 +50,7 @@ subroutine psb_csymbmm(a,b,c,info) integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null())) then info = 1121 @@ -59,13 +59,13 @@ subroutine psb_csymbmm(a,b,c,info) endif allocate(ccsr, stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call psb_symbmm(a%a,b%a,ccsr,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -98,7 +98,7 @@ subroutine psb_cbase_symbmm(a,b,c,info) integer :: err_act name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() @@ -110,8 +110,8 @@ subroutine psb_cbase_symbmm(a,b,c,info) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(itemp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -131,7 +131,7 @@ subroutine psb_cbase_symbmm(a,b,c,info) call gen_symbmm(a,b,c,itemp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -167,7 +167,7 @@ contains end interface integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -203,8 +203,8 @@ contains allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -233,7 +233,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn - info=2 + info=psb_err_pivot_too_small_ return else if(index(ibcl(k)) == 0) then diff --git a/base/serial/psb_dnumbmm.f90 b/base/serial/psb_dnumbmm.f90 index aa5d3fe35..4a93b13e3 100644 --- a/base/serial/psb_dnumbmm.f90 +++ b/base/serial/psb_dnumbmm.f90 @@ -51,7 +51,7 @@ subroutine psb_dnumbmm(a,b,c) character(len=*), parameter :: name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then info = 1121 @@ -99,7 +99,7 @@ subroutine psb_dbase_numbmm(a,b,c) integer :: err_act name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() @@ -112,8 +112,8 @@ subroutine psb_dbase_numbmm(a,b,c) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(temp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -135,7 +135,7 @@ subroutine psb_dbase_numbmm(a,b,c) call gen_numbmm(a,b,c,temp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -163,7 +163,7 @@ contains integer, intent(out) :: info integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -192,8 +192,8 @@ contains maxlmn = max(l,m,n) allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & aval(maxlmn),bval(maxlmn), stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -219,7 +219,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn - info = 2 + info = psb_err_pivot_too_small_ return else temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) @@ -229,7 +229,7 @@ contains do j = c%irp(i),c%irp(i+1)-1 if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then write(0,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn - info = 3 + info = psb_err_invalid_ovr_num_ return else c%val(j) = temp(c%ja(j)) diff --git a/base/serial/psb_drwextd.f90 b/base/serial/psb_drwextd.f90 index 718cd1c0b..13b71b02c 100644 --- a/base/serial/psb_drwextd.f90 +++ b/base/serial/psb_drwextd.f90 @@ -55,7 +55,7 @@ subroutine psb_drwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_drwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nr > a%get_nrows()) then @@ -74,17 +74,17 @@ subroutine psb_drwextd(nr,a,info,b,rowscale) end if class default call aa%mv_to_coo(actmp,info) - if (info == 0) then + if (info == psb_success_) then if (present(b)) then call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) else call psb_rwextd(nr,actmp,info,rowscale=rowscale) end if end if - if (info == 0) call aa%mv_from_coo(actmp,info) + if (info == psb_success_) call aa%mv_from_coo(actmp,info) end select end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -114,7 +114,7 @@ subroutine psb_dbase_rwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_dbase_rwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(rowscale)) then @@ -232,7 +232,7 @@ subroutine psb_dbase_rwextd(nr,a,info,b,rowscale) call a%set_nrows(nr) class default - info = 135 + info = psb_err_unsupported_format_ ch_err=a%get_fmt() call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index 2265dbb0f..f7c29fbbc 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -50,7 +50,7 @@ subroutine psb_dsymbmm(a,b,c,info) integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null())) then info = 1121 @@ -59,13 +59,13 @@ subroutine psb_dsymbmm(a,b,c,info) endif allocate(ccsr, stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call psb_symbmm(a%a,b%a,ccsr,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -98,7 +98,7 @@ subroutine psb_dbase_symbmm(a,b,c,info) integer :: err_act name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() @@ -110,8 +110,8 @@ subroutine psb_dbase_symbmm(a,b,c,info) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(itemp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -131,7 +131,7 @@ subroutine psb_dbase_symbmm(a,b,c,info) call gen_symbmm(a,b,c,itemp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -167,7 +167,7 @@ contains end interface integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -203,8 +203,8 @@ contains allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -233,7 +233,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn - info=2 + info=psb_err_pivot_too_small_ return else if(index(ibcl(k)) == 0) then diff --git a/base/serial/psb_snumbmm.f90 b/base/serial/psb_snumbmm.f90 index d6fa4cec3..bb97feacb 100644 --- a/base/serial/psb_snumbmm.f90 +++ b/base/serial/psb_snumbmm.f90 @@ -51,7 +51,7 @@ subroutine psb_snumbmm(a,b,c) character(len=*), parameter :: name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then info = 1121 @@ -99,7 +99,7 @@ subroutine psb_sbase_numbmm(a,b,c) integer :: err_act name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() @@ -112,8 +112,8 @@ subroutine psb_sbase_numbmm(a,b,c) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(temp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -135,7 +135,7 @@ subroutine psb_sbase_numbmm(a,b,c) call gen_numbmm(a,b,c,temp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -163,7 +163,7 @@ contains integer, intent(out) :: info integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -192,8 +192,8 @@ contains maxlmn = max(l,m,n) allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & aval(maxlmn),bval(maxlmn), stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -219,7 +219,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn - info = 2 + info = psb_err_pivot_too_small_ return else temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) @@ -229,7 +229,7 @@ contains do j = c%irp(i),c%irp(i+1)-1 if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then write(0,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn - info = 3 + info = psb_err_invalid_ovr_num_ return else c%val(j) = temp(c%ja(j)) diff --git a/base/serial/psb_sort_impl.f90 b/base/serial/psb_sort_impl.f90 index 4d5b58426..e66c11c1c 100644 --- a/base/serial/psb_sort_impl.f90 +++ b/base/serial/psb_sort_impl.f90 @@ -55,7 +55,7 @@ logical function psb_isaperm(n,eip) psb_isaperm = .true. if (n <= 0) return allocate(ip(n), stat=info) - if (info /= 0) return + if (info /= psb_success_) return ! ! sanity check first ! @@ -166,7 +166,7 @@ subroutine imsort(x,ix,dir,flag) case( psb_sort_up_, psb_sort_down_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -174,7 +174,7 @@ subroutine imsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if if (present(flag)) then @@ -186,7 +186,7 @@ subroutine imsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -227,7 +227,7 @@ subroutine smsort(x,ix,dir,flag) case( psb_sort_up_, psb_sort_down_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -235,7 +235,7 @@ subroutine smsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if if (present(flag)) then @@ -247,7 +247,7 @@ subroutine smsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -287,7 +287,7 @@ subroutine dmsort(x,ix,dir,flag) case( psb_sort_up_, psb_sort_down_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -295,7 +295,7 @@ subroutine dmsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if if (present(flag)) then @@ -307,7 +307,7 @@ subroutine dmsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -347,7 +347,7 @@ subroutine camsort(x,ix,dir,flag) case( psb_asort_up_, psb_asort_down_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -355,7 +355,7 @@ subroutine camsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if if (present(flag)) then @@ -367,7 +367,7 @@ subroutine camsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -407,7 +407,7 @@ subroutine zamsort(x,ix,dir,flag) case( psb_asort_up_, psb_asort_down_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -415,7 +415,7 @@ subroutine zamsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if if (present(flag)) then @@ -427,7 +427,7 @@ subroutine zamsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -468,7 +468,7 @@ subroutine imsort_u(x,nout,dir) case( psb_sort_up_, psb_sort_down_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -509,7 +509,7 @@ subroutine iqsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -525,7 +525,7 @@ subroutine iqsort(x,ix,dir,flag) case( psb_sort_up_, psb_sort_down_) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -538,7 +538,7 @@ subroutine iqsort(x,ix,dir,flag) ! OK keep going if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -548,7 +548,7 @@ subroutine iqsort(x,ix,dir,flag) end if case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -586,7 +586,7 @@ subroutine sqsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -602,7 +602,7 @@ subroutine sqsort(x,ix,dir,flag) case( psb_sort_up_, psb_sort_down_) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -615,7 +615,7 @@ subroutine sqsort(x,ix,dir,flag) ! OK keep going if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -625,7 +625,7 @@ subroutine sqsort(x,ix,dir,flag) end if case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -662,7 +662,7 @@ subroutine dqsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -678,7 +678,7 @@ subroutine dqsort(x,ix,dir,flag) case( psb_sort_up_, psb_sort_down_) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -691,7 +691,7 @@ subroutine dqsort(x,ix,dir,flag) ! OK keep going if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -701,7 +701,7 @@ subroutine dqsort(x,ix,dir,flag) end if case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -739,7 +739,7 @@ subroutine cqsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -755,7 +755,7 @@ subroutine cqsort(x,ix,dir,flag) case( psb_lsort_up_, psb_lsort_down_) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -768,7 +768,7 @@ subroutine cqsort(x,ix,dir,flag) ! OK keep going if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -781,7 +781,7 @@ subroutine cqsort(x,ix,dir,flag) ! OK keep going if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -791,7 +791,7 @@ subroutine cqsort(x,ix,dir,flag) end if case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -829,7 +829,7 @@ subroutine zqsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -845,7 +845,7 @@ subroutine zqsort(x,ix,dir,flag) case( psb_lsort_up_, psb_lsort_down_) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -858,7 +858,7 @@ subroutine zqsort(x,ix,dir,flag) ! OK keep going if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -871,7 +871,7 @@ subroutine zqsort(x,ix,dir,flag) ! OK keep going if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if @@ -881,7 +881,7 @@ subroutine zqsort(x,ix,dir,flag) end if case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -923,7 +923,7 @@ subroutine ihsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -937,7 +937,7 @@ subroutine ihsort(x,ix,dir,flag) case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) ! OK case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -954,10 +954,10 @@ subroutine ihsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if - if (flag_==psb_sort_ovw_idx_) then + if (flag_ == psb_sort_ovw_idx_) then do i=1, n ix(i) = i end do @@ -1032,7 +1032,7 @@ subroutine shsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -1046,7 +1046,7 @@ subroutine shsort(x,ix,dir,flag) case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) ! OK case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -1063,10 +1063,10 @@ subroutine shsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if - if (flag_==psb_sort_ovw_idx_) then + if (flag_ == psb_sort_ovw_idx_) then do i=1, n ix(i) = i end do @@ -1141,7 +1141,7 @@ subroutine dhsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -1155,7 +1155,7 @@ subroutine dhsort(x,ix,dir,flag) case(psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) ! OK case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -1172,10 +1172,10 @@ subroutine dhsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if - if (flag_==psb_sort_ovw_idx_) then + if (flag_ == psb_sort_ovw_idx_) then do i=1, n ix(i) = i end do @@ -1250,7 +1250,7 @@ subroutine chsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -1264,7 +1264,7 @@ subroutine chsort(x,ix,dir,flag) case(psb_asort_up_,psb_asort_down_) ! OK case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -1281,10 +1281,10 @@ subroutine chsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if - if (flag_==psb_sort_ovw_idx_) then + if (flag_ == psb_sort_ovw_idx_) then do i=1, n ix(i) = i end do @@ -1359,7 +1359,7 @@ subroutine zhsort(x,ix,dir,flag) case( psb_sort_ovw_idx_, psb_sort_keep_idx_) ! OK keep going case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/4,flag_,0,0,0/)) goto 9999 end select @@ -1373,7 +1373,7 @@ subroutine zhsort(x,ix,dir,flag) case(psb_asort_up_,psb_asort_down_) ! OK case default - call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select @@ -1390,10 +1390,10 @@ subroutine zhsort(x,ix,dir,flag) if (present(ix)) then if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=(/2,size(ix),0,0,0/)) goto 9999 end if - if (flag_==psb_sort_ovw_idx_) then + if (flag_ == psb_sort_ovw_idx_) then do i=1, n ix(i) = i end do @@ -1458,7 +1458,7 @@ subroutine psb_init_int_heap(heap,info,dir) integer, intent(out) :: info integer, intent(in), optional :: dir - info = 0 + info = psb_success_ heap%last=0 if (present(dir)) then heap%dir = dir @@ -1484,7 +1484,7 @@ subroutine psb_dump_int_heap(iout,heap,info) integer, intent(out) :: info integer, intent(in) :: iout - info = 0 + info = psb_success_ if (iout < 0) then write(0,*) 'Invalid file ' info =-1 @@ -1512,7 +1512,7 @@ subroutine psb_insert_int_heap(key,heap,info) type(psb_int_heap), intent(inout) :: heap integer, intent(out) :: info - info = 0 + info = psb_success_ if (heap%last < 0) then write(0,*) 'Invalid last in heap ',heap%last info = heap%last @@ -1521,7 +1521,7 @@ subroutine psb_insert_int_heap(key,heap,info) heap%last = heap%last call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Memory allocation failure in heap_insert' info = -5 return @@ -1539,7 +1539,7 @@ subroutine psb_int_heap_get_first(key,heap,info) type(psb_int_heap), intent(inout) :: heap integer, intent(out) :: key,info - info = 0 + info = psb_success_ call psi_int_heap_get_first(key,heap%last,heap%keys,heap%dir,info) @@ -1563,7 +1563,7 @@ subroutine psb_init_real_idx_heap(heap,info,dir) integer, intent(out) :: info integer, intent(in), optional :: dir - info = 0 + info = psb_success_ heap%last=0 if (present(dir)) then heap%dir = dir @@ -1590,7 +1590,7 @@ subroutine psb_dump_real_idx_heap(iout,heap,info) integer, intent(out) :: info integer, intent(in) :: iout - info = 0 + info = psb_success_ if (iout < 0) then write(0,*) 'Invalid file ' info =-1 @@ -1623,7 +1623,7 @@ subroutine psb_insert_real_idx_heap(key,index,heap,info) type(psb_real_idx_heap), intent(inout) :: heap integer, intent(out) :: info - info = 0 + info = psb_success_ if (heap%last < 0) then write(0,*) 'Invalid last in heap ',heap%last info = heap%last @@ -1631,9 +1631,9 @@ subroutine psb_insert_real_idx_heap(key,index,heap,info) endif call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & + if (info == psb_success_) & & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Memory allocation failure in heap_insert' info = -5 return @@ -1653,7 +1653,7 @@ subroutine psb_real_idx_heap_get_first(key,index,heap,info) integer, intent(out) :: index,info real(psb_spk_), intent(out) :: key - info = 0 + info = psb_success_ call psi_real_idx_heap_get_first(key,index,& & heap%last,heap%keys,heap%idxs,heap%dir,info) @@ -1678,7 +1678,7 @@ subroutine psb_init_double_idx_heap(heap,info,dir) integer, intent(out) :: info integer, intent(in), optional :: dir - info = 0 + info = psb_success_ heap%last=0 if (present(dir)) then heap%dir = dir @@ -1705,7 +1705,7 @@ subroutine psb_dump_double_idx_heap(iout,heap,info) integer, intent(out) :: info integer, intent(in) :: iout - info = 0 + info = psb_success_ if (iout < 0) then write(0,*) 'Invalid file ' info =-1 @@ -1738,7 +1738,7 @@ subroutine psb_insert_double_idx_heap(key,index,heap,info) type(psb_double_idx_heap), intent(inout) :: heap integer, intent(out) :: info - info = 0 + info = psb_success_ if (heap%last < 0) then write(0,*) 'Invalid last in heap ',heap%last info = heap%last @@ -1746,9 +1746,9 @@ subroutine psb_insert_double_idx_heap(key,index,heap,info) endif call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & + if (info == psb_success_) & & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Memory allocation failure in heap_insert' info = -5 return @@ -1768,7 +1768,7 @@ subroutine psb_double_idx_heap_get_first(key,index,heap,info) integer, intent(out) :: index,info real(psb_dpk_), intent(out) :: key - info = 0 + info = psb_success_ call psi_double_idx_heap_get_first(key,index,& & heap%last,heap%keys,heap%idxs,heap%dir,info) @@ -1792,7 +1792,7 @@ subroutine psb_init_int_idx_heap(heap,info,dir) integer, intent(out) :: info integer, intent(in), optional :: dir - info = 0 + info = psb_success_ heap%last=0 if (present(dir)) then heap%dir = dir @@ -1819,7 +1819,7 @@ subroutine psb_dump_int_idx_heap(iout,heap,info) integer, intent(out) :: info integer, intent(in) :: iout - info = 0 + info = psb_success_ if (iout < 0) then write(0,*) 'Invalid file ' info =-1 @@ -1852,7 +1852,7 @@ subroutine psb_insert_int_idx_heap(key,index,heap,info) type(psb_int_idx_heap), intent(inout) :: heap integer, intent(out) :: info - info = 0 + info = psb_success_ if (heap%last < 0) then write(0,*) 'Invalid last in heap ',heap%last info = heap%last @@ -1860,9 +1860,9 @@ subroutine psb_insert_int_idx_heap(key,index,heap,info) endif call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & + if (info == psb_success_) & & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Memory allocation failure in heap_insert' info = -5 return @@ -1882,7 +1882,7 @@ subroutine psb_int_idx_heap_get_first(key,index,heap,info) integer, intent(out) :: index,info integer, intent(out) :: key - info = 0 + info = psb_success_ call psi_int_idx_heap_get_first(key,index,& & heap%last,heap%keys,heap%idxs,heap%dir,info) @@ -1908,7 +1908,7 @@ subroutine psb_init_scomplex_idx_heap(heap,info,dir) integer, intent(out) :: info integer, intent(in), optional :: dir - info = 0 + info = psb_success_ heap%last=0 if (present(dir)) then heap%dir = dir @@ -1936,7 +1936,7 @@ subroutine psb_dump_scomplex_idx_heap(iout,heap,info) integer, intent(out) :: info integer, intent(in) :: iout - info = 0 + info = psb_success_ if (iout < 0) then write(0,*) 'Invalid file ' info =-1 @@ -1969,7 +1969,7 @@ subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) type(psb_scomplex_idx_heap), intent(inout) :: heap integer, intent(out) :: info - info = 0 + info = psb_success_ if (heap%last < 0) then write(0,*) 'Invalid last in heap ',heap%last info = heap%last @@ -1977,9 +1977,9 @@ subroutine psb_insert_scomplex_idx_heap(key,index,heap,info) endif call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & + if (info == psb_success_) & & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Memory allocation failure in heap_insert' info = -5 return @@ -1999,7 +1999,7 @@ subroutine psb_scomplex_idx_heap_get_first(key,index,heap,info) complex(psb_spk_), intent(out) :: key - info = 0 + info = psb_success_ call psi_scomplex_idx_heap_get_first(key,index,& & heap%last,heap%keys,heap%idxs,heap%dir,info) @@ -2025,7 +2025,7 @@ subroutine psb_init_dcomplex_idx_heap(heap,info,dir) integer, intent(out) :: info integer, intent(in), optional :: dir - info = 0 + info = psb_success_ heap%last=0 if (present(dir)) then heap%dir = dir @@ -2053,7 +2053,7 @@ subroutine psb_dump_dcomplex_idx_heap(iout,heap,info) integer, intent(out) :: info integer, intent(in) :: iout - info = 0 + info = psb_success_ if (iout < 0) then write(0,*) 'Invalid file ' info =-1 @@ -2086,7 +2086,7 @@ subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info) type(psb_dcomplex_idx_heap), intent(inout) :: heap integer, intent(out) :: info - info = 0 + info = psb_success_ if (heap%last < 0) then write(0,*) 'Invalid last in heap ',heap%last info = heap%last @@ -2094,9 +2094,9 @@ subroutine psb_insert_dcomplex_idx_heap(key,index,heap,info) endif call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) - if (info == 0) & + if (info == psb_success_) & & call psb_ensure_size(heap%last+1,heap%idxs,info,addsz=psb_heap_resize) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Memory allocation failure in heap_insert' info = -5 return @@ -2116,7 +2116,7 @@ subroutine psb_dcomplex_idx_heap_get_first(key,index,heap,info) complex(psb_dpk_), intent(out) :: key - info = 0 + info = psb_success_ call psi_dcomplex_idx_heap_get_first(key,index,& & heap%last,heap%keys,heap%idxs,heap%dir,info) @@ -2149,7 +2149,7 @@ subroutine psi_insert_int_heap(key,last,heap,dir,info) integer :: i, i2 integer :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -2249,7 +2249,7 @@ subroutine psi_int_heap_get_first(key,last,heap,dir,info) integer :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 info = -1 @@ -2379,7 +2379,7 @@ subroutine psi_insert_real_heap(key,last,heap,dir,info) integer :: i, i2 real(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -2480,7 +2480,7 @@ subroutine psi_real_heap_get_first(key,last,heap,dir,info) real(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 info = -1 @@ -2609,7 +2609,7 @@ subroutine psi_insert_double_heap(key,last,heap,dir,info) integer :: i, i2 real(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -2710,7 +2710,7 @@ subroutine psi_double_heap_get_first(key,last,heap,dir,info) real(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 info = -1 @@ -2841,7 +2841,7 @@ subroutine psi_insert_scomplex_heap(key,last,heap,dir,info) integer :: i, i2 complex(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -2942,7 +2942,7 @@ subroutine psi_scomplex_heap_get_first(key,last,heap,dir,info) complex(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 info = -1 @@ -3071,7 +3071,7 @@ subroutine psi_insert_dcomplex_heap(key,last,heap,dir,info) integer :: i, i2 complex(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -3172,7 +3172,7 @@ subroutine psi_dcomplex_heap_get_first(key,last,heap,dir,info) complex(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 info = -1 @@ -3305,7 +3305,7 @@ subroutine psi_insert_int_idx_heap(key,index,last,heap,idxs,dir,info) integer :: i, i2, itemp integer :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -3419,7 +3419,7 @@ subroutine psi_int_idx_heap_get_first(key,index,last,heap,idxs,dir,info) integer :: i, j,itemp integer :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 index = 0 @@ -3564,7 +3564,7 @@ subroutine psi_insert_real_idx_heap(key,index,last,heap,idxs,dir,info) integer :: i, i2, itemp real(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -3678,7 +3678,7 @@ subroutine psi_real_idx_heap_get_first(key,index,last,heap,idxs,dir,info) integer :: i, j,itemp real(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 index = 0 @@ -3824,7 +3824,7 @@ subroutine psi_insert_double_idx_heap(key,index,last,heap,idxs,dir,info) integer :: i, i2, itemp real(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -3938,7 +3938,7 @@ subroutine psi_double_idx_heap_get_first(key,index,last,heap,idxs,dir,info) integer :: i, j,itemp real(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 index = 0 @@ -4084,7 +4084,7 @@ subroutine psi_insert_scomplex_idx_heap(key,index,last,heap,idxs,dir,info) integer :: i, i2, itemp complex(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -4198,7 +4198,7 @@ subroutine psi_scomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) integer :: i, j, itemp complex(psb_spk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 index = 0 @@ -4344,7 +4344,7 @@ subroutine psi_insert_dcomplex_idx_heap(key,index,last,heap,idxs,dir,info) integer :: i, i2, itemp complex(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last < 0) then write(0,*) 'Invalid last in heap ',last info = last @@ -4458,7 +4458,7 @@ subroutine psi_dcomplex_idx_heap_get_first(key,index,last,heap,idxs,dir,info) integer :: i, j, itemp complex(psb_dpk_) :: temp - info = 0 + info = psb_success_ if (last <= 0) then key = 0 index = 0 diff --git a/base/serial/psb_srwextd.f90 b/base/serial/psb_srwextd.f90 index 8261ccf2a..f29fe02d5 100644 --- a/base/serial/psb_srwextd.f90 +++ b/base/serial/psb_srwextd.f90 @@ -55,7 +55,7 @@ subroutine psb_srwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_srwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nr > a%get_nrows()) then @@ -74,17 +74,17 @@ subroutine psb_srwextd(nr,a,info,b,rowscale) end if class default call aa%mv_to_coo(actmp,info) - if (info == 0) then + if (info == psb_success_) then if (present(b)) then call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) else call psb_rwextd(nr,actmp,info,rowscale=rowscale) end if end if - if (info == 0) call aa%mv_from_coo(actmp,info) + if (info == psb_success_) call aa%mv_from_coo(actmp,info) end select end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -114,7 +114,7 @@ subroutine psb_sbase_rwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_sbase_rwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(rowscale)) then @@ -232,7 +232,7 @@ subroutine psb_sbase_rwextd(nr,a,info,b,rowscale) call a%set_nrows(nr) class default - info = 135 + info = psb_err_unsupported_format_ ch_err=a%get_fmt() call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/serial/psb_ssymbmm.f90 b/base/serial/psb_ssymbmm.f90 index bcfb3b1b8..faff306f0 100644 --- a/base/serial/psb_ssymbmm.f90 +++ b/base/serial/psb_ssymbmm.f90 @@ -50,7 +50,7 @@ subroutine psb_ssymbmm(a,b,c,info) integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null())) then info = 1121 @@ -59,13 +59,13 @@ subroutine psb_ssymbmm(a,b,c,info) endif allocate(ccsr, stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call psb_symbmm(a%a,b%a,ccsr,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -98,7 +98,7 @@ subroutine psb_sbase_symbmm(a,b,c,info) integer :: err_act name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() @@ -110,8 +110,8 @@ subroutine psb_sbase_symbmm(a,b,c,info) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(itemp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -131,7 +131,7 @@ subroutine psb_sbase_symbmm(a,b,c,info) call gen_symbmm(a,b,c,itemp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -167,7 +167,7 @@ contains end interface integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -203,8 +203,8 @@ contains allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -233,7 +233,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn - info=2 + info=psb_err_pivot_too_small_ return else if(index(ibcl(k)) == 0) then diff --git a/base/serial/psb_znumbmm.f90 b/base/serial/psb_znumbmm.f90 index 9b5f5b7a1..09ce1f305 100644 --- a/base/serial/psb_znumbmm.f90 +++ b/base/serial/psb_znumbmm.f90 @@ -51,7 +51,7 @@ subroutine psb_znumbmm(a,b,c) character(len=*), parameter :: name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then info = 1121 @@ -99,7 +99,7 @@ subroutine psb_zbase_numbmm(a,b,c) integer :: err_act name='psb_numbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() @@ -112,8 +112,8 @@ subroutine psb_zbase_numbmm(a,b,c) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(temp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -135,7 +135,7 @@ subroutine psb_zbase_numbmm(a,b,c) call gen_numbmm(a,b,c,temp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -163,7 +163,7 @@ contains integer, intent(out) :: info integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -192,8 +192,8 @@ contains maxlmn = max(l,m,n) allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & aval(maxlmn),bval(maxlmn), stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -219,7 +219,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn - info = 2 + info = psb_err_pivot_too_small_ return else temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) @@ -229,7 +229,7 @@ contains do j = c%irp(i),c%irp(i+1)-1 if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then write(0,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn - info = 3 + info = psb_err_invalid_ovr_num_ return else c%val(j) = temp(c%ja(j)) diff --git a/base/serial/psb_zrwextd.f90 b/base/serial/psb_zrwextd.f90 index 14fa4603d..b787e4fb1 100644 --- a/base/serial/psb_zrwextd.f90 +++ b/base/serial/psb_zrwextd.f90 @@ -55,7 +55,7 @@ subroutine psb_zrwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_zrwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (nr > a%get_nrows()) then @@ -74,17 +74,17 @@ subroutine psb_zrwextd(nr,a,info,b,rowscale) end if class default call aa%mv_to_coo(actmp,info) - if (info == 0) then + if (info == psb_success_) then if (present(b)) then call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) else call psb_rwextd(nr,actmp,info,rowscale=rowscale) end if end if - if (info == 0) call aa%mv_from_coo(actmp,info) + if (info == psb_success_) call aa%mv_from_coo(actmp,info) end select end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -114,7 +114,7 @@ subroutine psb_zbase_rwextd(nr,a,info,b,rowscale) logical rowscale_ name='psb_zbase_rwextd' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(rowscale)) then @@ -232,7 +232,7 @@ subroutine psb_zbase_rwextd(nr,a,info,b,rowscale) call a%set_nrows(nr) class default - info = 135 + info = psb_err_unsupported_format_ ch_err=a%get_fmt() call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index afed497a8..20c1f119c 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -50,7 +50,7 @@ subroutine psb_zsymbmm(a,b,c,info) integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if ((a%is_null()) .or.(b%is_null())) then info = 1121 @@ -59,13 +59,13 @@ subroutine psb_zsymbmm(a,b,c,info) endif allocate(ccsr, stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call psb_symbmm(a%a,b%a,ccsr,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -98,7 +98,7 @@ subroutine psb_zbase_symbmm(a,b,c,info) integer :: err_act name='psb_symbmm' call psb_erractionsave(err_act) - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() @@ -110,8 +110,8 @@ subroutine psb_zbase_symbmm(a,b,c,info) write(0,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb endif allocate(itemp(max(ma,na,mb,nb)),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 endif @@ -131,7 +131,7 @@ subroutine psb_zbase_symbmm(a,b,c,info) call gen_symbmm(a,b,c,itemp,info) end select - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -167,7 +167,7 @@ contains end interface integer :: nze, ma,na,mb,nb - info = 0 + info = psb_success_ ma = a%get_nrows() na = a%get_ncols() mb = b%get_nrows() @@ -203,8 +203,8 @@ contains allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& & stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ return endif @@ -233,7 +233,7 @@ contains do k=1,nbzr if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then write(0,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn - info=2 + info=psb_err_pivot_too_small_ return else if(index(ibcl(k)) == 0) then diff --git a/base/serial/psi_impl.f90 b/base/serial/psi_impl.f90 index 76d6d13be..b697bd006 100644 --- a/base/serial/psi_impl.f90 +++ b/base/serial/psi_impl.f90 @@ -73,15 +73,15 @@ integer :: i,j,k,nh if (nc > size(iperm)) then - info = 2 + info = psb_err_pivot_too_small_ return endif if (idxmap%state == psb_desc_large_) then allocate(itmp(size(idxmap%loc_to_glob)), stat=i) - if (i/=0) then - info = 4001 + if (i /= 0) then + info = psb_err_internal_error_ return end if do i=1,nc @@ -136,12 +136,12 @@ debug_level = psb_get_debug_level() debug_unit = psb_get_debug_unit() - info = 0 + info = psb_success_ ictxt = cdesc%matrix_data(psb_ctxt_) call psb_info(ictxt,me,np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -151,8 +151,8 @@ if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',& & size(halo_in) call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index') goto 9999 end if call psb_move_alloc(idx_out,cdesc%halo_index,info) @@ -167,8 +167,8 @@ ! then ext index if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index') goto 9999 end if call psb_move_alloc(idx_out,cdesc%ext_index,info) @@ -181,13 +181,13 @@ ! then the overlap index call psi_crea_index(cdesc,ovrlap_in, idx_out,.true.,nxch,nsnd,nrcv,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index') goto 9999 end if call psb_move_alloc(idx_out,cdesc%ovrlap_index,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_move_alloc') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc') goto 9999 end if @@ -199,23 +199,23 @@ if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem' call psi_crea_ovr_elem(me,cdesc%ovrlap_index,cdesc%ovrlap_elem,info) if (debug_level>0) write(debug_unit,*) me,'Done crea_ovr_elem' - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_ovr_elem') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_ovr_elem') goto 9999 end if ! Extract ovr_mst_idx from ovrlap_elem if (debug_level>0) write(debug_unit,*) me,'Calling bld_ovr_mst' call psi_bld_ovr_mst(me,cdesc%ovrlap_elem,tmp_mst_idx,info) - if (info == 0) call psi_crea_index(cdesc,& + if (info == psb_success_) call psi_crea_index(cdesc,& & tmp_mst_idx,idx_out,.false.,nxch,nsnd,nrcv,info) if (debug_level>0) write(debug_unit,*) me,'Done crea_indx' - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_bld_ovr_mst') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_bld_ovr_mst') goto 9999 end if call psb_move_alloc(idx_out,cdesc%ovr_mst_idx,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_move_alloc') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc') goto 9999 end if @@ -225,10 +225,10 @@ ! finally bnd_elem call psi_crea_bnd_elem(idx_out,cdesc,info) - if (info == 0) call psb_move_alloc(idx_out,cdesc%bnd_elem,info) + if (info == psb_success_) call psb_move_alloc(idx_out,cdesc%bnd_elem,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_bnd_elem') goto 9999 end if if (debug_level>0) write(debug_unit,*) me,'Done crea_bnd_elem' @@ -273,7 +273,7 @@ do if (lb>ub) exit lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then + if (key == glb_lc(lm,1)) then tmp = lm exit else if (keyub) exit lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then + if (key == glb_lc(lm,1)) then tmp = lm exit else if (keyub) exit lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then + if (key == glb_lc(lm,1)) then tmp = lm exit else if (keyub) exit lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then + if (key == glb_lc(lm,1)) then tmp = lm exit else if (keyub) exit lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then + if (key == glb_lc(lm,1)) then tmp = lm exit else if (keyub) exit lm = (lb+ub)/2 - if (key==glb_lc(lm,1)) then + if (key == glb_lc(lm,1)) then tmp = lm exit else if (key= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),' error ',& & psb_cd_get_dectype(desc_a) - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -101,8 +101,8 @@ subroutine psb_casb(x, desc_a, info) if (i1sz < ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -110,8 +110,8 @@ subroutine psb_casb(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_halo' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -189,7 +189,7 @@ subroutine psb_casbv(x, desc_a, info) integer :: debug_level, debug_unit character(len=20) :: name,ch_err - info = 0 + info = psb_success_ int_err(1) = 0 name = 'psb_cgeasb_v' @@ -201,11 +201,11 @@ subroutine psb_casbv(x, desc_a, info) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -219,8 +219,8 @@ subroutine psb_casbv(x, desc_a, info) & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol if (i1sz < ncol) then call psb_realloc(ncol,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -228,8 +228,8 @@ subroutine psb_casbv(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='f90_pshalo' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_ccdbldext.F90 b/base/tools/psb_ccdbldext.F90 index d9f94b5ef..721e0a294 100644 --- a/base/tools/psb_ccdbldext.F90 +++ b/base/tools/psb_ccdbldext.F90 @@ -100,7 +100,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) character(len=20) :: name, ch_err name='psb_ccdbldext' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -124,7 +124,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) nhalo = n_col-m if (novr<0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=novr call psb_errpush(info,name,i_err=int_err) @@ -135,8 +135,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdcpy' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -145,7 +145,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':From desccpy' - if (novr==0) then + if (novr == 0) then ! ! Just copy the input. ! @@ -194,22 +194,22 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if halo(:) = desc_a%halo_index(:) @@ -239,8 +239,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -340,8 +340,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -352,8 +352,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -384,8 +384,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -401,15 +401,15 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') goto 9999 end if call psb_ensure_size((idxs+tot_elem+n_elem),works,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -445,8 +445,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! matchings SENDs. ! call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -471,8 +471,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) iszr=sum(rvsz) if (max(iszr,1) > lworkr) then call psb_realloc(max(iszr,1),workr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -482,8 +482,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -494,8 +494,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (psb_is_large_desc(desc_ov)) then call psb_ensure_size(iszr,maskr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -532,8 +532,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) proc_id = temp(i) call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -562,8 +562,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) n_col = n_col+1 proc_id = -desc_ov%idxmap%glob_to_loc(idx)-np-1 call psb_ensure_size(n_col,desc_ov%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -572,8 +572,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%idxmap%loc_to_glob(n_col) = idx call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -645,8 +645,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if tmp_halo(counter_h:counter_h+counter_t-1) = t_halo_in(1:counter_t) @@ -654,8 +654,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%halo_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if @@ -671,8 +671,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) @@ -680,15 +680,15 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(30,name,i_err=(/5,extype_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) goto 9999 end select @@ -705,18 +705,18 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) - if (info /= 0) then - call psb_errpush(4010,name,a_err='icdasdb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb') goto 9999 end if call psb_cd_set_ovl_asb(desc_ov,info) - if (info == 0) then + if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info ==0).and.allocated(icol)) deallocate(icol,stat=info) - if (info /= 0) then - call psb_errpush(4013,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) + if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) goto 9999 end if end if diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index ad6e6f135..db6c44f19 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -64,7 +64,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 name = 'psb_cd_inloc' debug_unit = psb_get_debug_unit() @@ -95,16 +95,16 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) !... check m and n parameters.... if (m < 1) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m else if (n < 1) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 2 int_err(2) = n endif - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -135,8 +135,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) islarge = psb_cd_choose_large_state(ictxt,m) allocate(vl(loc_row),stat=info) - if (info /=0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -151,8 +151,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) if (check_.or.(.not.islarge)) then allocate(tmpgidx(m,2),stat=info) - if (info /=0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -160,7 +160,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) flag_ = 1 do i=1,loc_row if ((v(i)<1).or.(v(i)>m)) then - info = 551 + info = psb_err_entry_out_of_bounds_ int_err(1) = i int_err(2) = v(i) int_err(3) = loc_row @@ -172,7 +172,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) vl(i) = v(i) end do - if (info ==0) then + if (info == psb_success_) then call psb_amx(ictxt,tmpgidx(:,1)) call psb_sum(ictxt,tmpgidx(:,2)) novrl = 0 @@ -189,7 +189,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) if (norphan > 0) then int_err(1) = norphan int_err(2) = m - info = 552 + info = psb_err_inconsistent_index_lists_ end if end if else @@ -198,7 +198,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) npr_ov = 0 do i=1,loc_row if ((v(i)<1).or.(v(i)>m)) then - info = 551 + info = psb_err_entry_out_of_bounds_ int_err(1) = i int_err(2) = v(i) int_err(3) = loc_row @@ -208,13 +208,13 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) vl(i) = v(i) end do - if ((m /= nrt).and.(me==psb_root_)) then + if ((m /= nrt).and.(me == psb_root_)) then write(0,*) trim(name),' Warning: globalcheck=.false., but there is a mismatch' write(0,*) trim(name),' : in the global sizes!',m,nrt end if end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -236,8 +236,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) & write(debug_unit,*) me,' ',trim(name),': code for NOVRL>0',novrl,npr_ov allocate(nov(0:np),ov_idx(npr_ov,2),stat=info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=np + 2*npr_ov call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -267,7 +267,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) end do if (j /= nov(me+1)) then - info=4001 + info=psb_err_internal_error_ call psb_errpush(info,name,a_err='overlap count') goto 9999 end if @@ -281,7 +281,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) allocate(desc%matrix_data(psb_mdata_size_),& &temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& & stat=info) - if (info == 0) then + if (info == psb_success_) then desc%lprm(1) = 0 desc%matrix_data(:) = 0 desc%idxmap%state = psb_desc_large_ @@ -290,14 +290,14 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) allocate(desc%idxmap%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& &temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& & stat=info) - if (info == 0) then + if (info == psb_success_) then desc%lprm(1) = 0 desc%matrix_data(:) = 0 desc%idxmap%state = psb_desc_normal_ end if end if - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=2*m+psb_mdata_size_ call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -307,8 +307,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) loc_col = min(2*loc_row,m) allocate(desc%idxmap%loc_to_glob(loc_col),stat=info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=loc_col call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -339,8 +339,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) ! hashed by the low order bits of the entries. ! - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=loc_col call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -358,7 +358,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) if (nprocs > 1) then do if (j > size(ov_idx,dim=1)) then - info=4001 + info=psb_err_internal_error_ call psb_errpush(info,name,a_err='search ov_idx') goto 9999 end if @@ -366,8 +366,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) j = j + 1 end do call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -382,8 +382,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) enddo - if (info /= 0) then - info=4001 + if (info /= psb_success_) then + info=psb_err_internal_error_ call psb_errpush(info,name,a_err='insert loop') goto 9999 endif @@ -403,7 +403,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) do i=1,m if (((tmpgidx(i,1)-flag_) > np-1).or.((tmpgidx(i,1)-flag_) < 0)) then - info=580 + info=psb_err_partfunc_wrong_pid_ int_err(1)=3 int_err(2)=tmpgidx(i,1) - flag_ int_err(3)=i @@ -413,7 +413,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) desc%idxmap%glob_to_loc(i) = -(np+(tmpgidx(i,1)-flag_)+1) enddo - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -430,7 +430,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) if (nprocs > 1) then do if (j > size(ov_idx,dim=1)) then - info=4001 + info=psb_err_internal_error_ call psb_errpush(info,name,a_err='search ov_idx') goto 9999 end if @@ -438,8 +438,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) j = j + 1 end do call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -456,13 +456,13 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) call psi_bld_tmpovrl(temp_ovrlap,desc,info) - if (info == 0) deallocate(temp_ovrlap,vl,stat=info) - if ((info == 0).and.(allocated(tmpgidx)))& + if (info == psb_success_) deallocate(temp_ovrlap,vl,stat=info) + if ((info == psb_success_).and.(allocated(tmpgidx)))& & deallocate(tmpgidx,stat=info) - if ((info == 0) .and.(allocated(ov_idx))) & + if ((info == psb_success_) .and.(allocated(ov_idx))) & & deallocate(ov_idx,nov,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -472,9 +472,9 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) desc%matrix_data(psb_n_col_) = loc_row call psb_realloc(max(1,loc_row/2),desc%halo_index, info) - if (info == 0) call psb_realloc(1,desc%ext_index, info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_realloc(1,desc%ext_index, info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') Goto 9999 end if @@ -486,8 +486,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck) & write(debug_unit,*) me,' ',trim(name),': end' call psb_cd_set_bld(desc,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_cd_set_bld') Goto 9999 end if diff --git a/base/tools/psb_cd_lstext.f90 b/base/tools/psb_cd_lstext.f90 index 89a930404..c5fc615fe 100644 --- a/base/tools/psb_cd_lstext.f90 +++ b/base/tools/psb_cd_lstext.f90 @@ -64,7 +64,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) character(len=20) :: name, ch_err name='psb_cd_lstext' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -87,15 +87,15 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) if (present(mask)) then if (size(mask) < nl) then - info=4010 + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='size of mask') goto 9999 end if mask_ => mask else allocate(lmask(nl),stat=info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocat lmask') goto 9999 end if @@ -113,8 +113,8 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),':Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdcpy' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -125,7 +125,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) call psb_cd_reinit(desc_ov,info) - if (info == 0) call psb_cdins(nl,in_list,desc_ov,info,mask=mask_) + if (info == psb_success_) call psb_cdins(nl,in_list,desc_ov,info,mask=mask_) ! At this point we have added to the halo the indices in ! in_list. Just call icdasb forcing to use @@ -142,9 +142,9 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) call psb_cd_set_ovl_asb(desc_ov,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='sp_free' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if diff --git a/base/tools/psb_cd_reinit.f90 b/base/tools/psb_cd_reinit.f90 index 55b60883b..dda9af853 100644 --- a/base/tools/psb_cd_reinit.f90 +++ b/base/tools/psb_cd_reinit.f90 @@ -50,7 +50,7 @@ Subroutine psb_cd_reinit(desc,info) character(len=20) :: name, ch_err name='psb_cd_reinit' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/tools/psb_cd_set_bld.f90 b/base/tools/psb_cd_set_bld.f90 index 957738126..6cd467e05 100644 --- a/base/tools/psb_cd_set_bld.f90 +++ b/base/tools/psb_cd_set_bld.f90 @@ -36,7 +36,7 @@ subroutine psb_cd_set_ovl_bld(desc,info) integer :: info call psb_cd_set_bld(desc,info) - if (info == 0) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_ + if (info == psb_success_) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_ end subroutine psb_cd_set_ovl_bld @@ -52,7 +52,7 @@ subroutine psb_cd_set_bld(desc,info) character(len=20) :: name if (debug) write(0,*) me,'Entered CDCPY' if (psb_get_errstatus() /= 0) return - info = 0 + info = psb_success_ call psb_erractionsave(err_act) name = 'psb_cd_set_bld' @@ -80,11 +80,11 @@ subroutine psb_cd_set_bld(desc,info) ! the hash occupancy. ! nc = psb_cd_get_local_cols(desc) - if (info == 0)& + if (info == psb_success_)& & call psb_hash_init(nc,desc%idxmap%hash,info) - if (info == 0) call psi_bld_g2lmap(desc,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='hashInit') + if (info == psb_success_) call psi_bld_g2lmap(desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='hashInit') goto 9999 end if diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index 65600e0de..49efc67fa 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -62,7 +62,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 name = 'psb_cdall' call psb_erractionsave(err_act) @@ -77,14 +77,14 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) !... check m and n parameters.... if (m < 1) then - info = 10 + info = psb_err_iarg_neg_ err=info int_err(1) = 1 int_err(2) = m call psb_errpush(err,name,int_err) goto 9999 else if (n < 1) then - info = 10 + info = psb_err_iarg_neg_ err=info int_err(1) = 2 int_err(2) = n @@ -125,20 +125,20 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (psb_cd_choose_large_state(ictxt,m)) then allocate(desc%matrix_data(psb_mdata_size_),& & temp_ovrlap(max(1,2*loc_row)),prc_v(np),stat=info) - if (info == 0) then + if (info == psb_success_) then desc%matrix_data(:) = 0 desc%idxmap%state = psb_desc_large_ end if else allocate(desc%idxmap%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& & temp_ovrlap(max(1,2*loc_row)),prc_v(np),stat=info) - if (info == 0) then + if (info == psb_success_) then desc%matrix_data(:) = 0 desc%idxmap%state = psb_desc_normal_ end if end if - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ err=info int_err(1)=2*m+psb_mdata_size_+np call psb_errpush(err,name,int_err,a_err='integer') @@ -173,8 +173,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) loc_col = min(2*loc_col,m) allocate(desc%idxmap%loc_to_glob(loc_col), desc%lprm(1),& & stat=info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=loc_col call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -185,10 +185,10 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) desc%idxmap%loc_to_glob(:) = -1 k = 0 do i=1,m - if (info == 0) then + if (info == psb_success_) then call parts(i,m,np,prc_v,nprocs) if (nprocs > np) then - info=570 + info=psb_err_partfunc_toomuchprocs_ int_err(1)=3 int_err(2)=np int_err(3)=nprocs @@ -197,7 +197,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psb_errpush(err,name,int_err) goto 9999 else if (nprocs <= 0) then - info=575 + info=psb_err_partfunc_toofewprocs_ int_err(1)=3 int_err(2)=nprocs int_err(3)=i @@ -207,7 +207,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) else do j=1,nprocs if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then - info=580 + info=psb_err_partfunc_wrong_pid_ int_err(1)=3 int_err(2)=prc_v(j) int_err(3)=i @@ -229,16 +229,16 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) ! this point belongs to me k = k + 1 call psb_ensure_size((k+1),desc%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if desc%idxmap%loc_to_glob(k) = i if (nprocs > 1) then call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -253,8 +253,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) end if end if enddo - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -273,10 +273,10 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) ! do i=1,m - if (info == 0) then + if (info == psb_success_) then call parts(i,m,np,prc_v,nprocs) if (nprocs > np) then - info=570 + info=psb_err_partfunc_toomuchprocs_ int_err(1)=3 int_err(2)=np int_err(3)=nprocs @@ -285,7 +285,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psb_errpush(err,name,int_err) goto 9999 else if (nprocs <= 0) then - info=575 + info=psb_err_partfunc_toofewprocs_ int_err(1)=3 int_err(2)=nprocs int_err(3)=i @@ -295,7 +295,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) else do j=1,nprocs if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then - info=580 + info=psb_err_partfunc_wrong_pid_ int_err(1)=3 int_err(2)=prc_v(j) int_err(3)=i @@ -319,8 +319,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) desc%idxmap%glob_to_loc(i) = counter if (nprocs > 1) then call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -341,8 +341,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) allocate(desc%idxmap%loc_to_glob(loc_col),& &desc%lprm(1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -369,9 +369,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psi_bld_tmpovrl(temp_ovrlap,desc,info) - if (info == 0) deallocate(prc_v,temp_ovrlap,stat=info) + if (info == psb_success_) deallocate(prc_v,temp_ovrlap,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ err=info call psb_errpush(err,name) Goto 9999 @@ -382,9 +382,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) desc%matrix_data(psb_n_col_) = loc_row call psb_realloc(max(1,loc_row/2),desc%halo_index, info) - if (info == 0) call psb_realloc(1,desc%ext_index, info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_realloc(1,desc%ext_index, info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') Goto 9999 end if @@ -393,8 +393,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) desc%ext_index(:) = -1 call psb_cd_set_bld(desc,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_cd_set_bld') Goto 9999 end if diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index a7ce87635..e4d9c9082 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -65,7 +65,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) if(psb_get_errstatus() /= 0) return debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - info = 0 + info = psb_success_ err = 0 name = 'psb_cdalv' @@ -77,20 +77,20 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) n = m !... check m and n parameters.... if (m < 1) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m else if (n < 1) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 2 int_err(2) = n else if (size(v) np-1).or.((v(i)-flag_) < 0)) then - info=580 + info=psb_err_partfunc_wrong_pid_ int_err(1)=3 int_err(2)=v(i) - flag_ int_err(3)=i @@ -203,7 +203,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': End main loop:' ,loc_row,itmpov,info - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -215,8 +215,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) allocate(desc%idxmap%loc_to_glob(loc_col), desc%lprm(1),& & stat=info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=loc_col call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -248,7 +248,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) do i=1,m if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then - info=580 + info=psb_err_partfunc_wrong_pid_ int_err(1)=3 int_err(2)=v(i) - flag_ int_err(3)=i @@ -270,7 +270,7 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': End main loop:' ,loc_row,itmpov,info - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -282,8 +282,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) allocate(desc%idxmap%loc_to_glob(loc_col),& &desc%lprm(1),stat=info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=loc_col call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -304,8 +304,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) call psi_bld_tmpovrl(temp_ovrlap,desc,info) deallocate(temp_ovrlap,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -315,9 +315,9 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) desc%matrix_data(psb_n_col_) = loc_row call psb_realloc(max(1,loc_row/2),desc%halo_index, info) - if (info == 0) call psb_realloc(1,desc%ext_index, info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_realloc(1,desc%ext_index, info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') Goto 9999 end if @@ -326,8 +326,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) desc%ext_index(:) = -1 call psb_cd_set_bld(desc,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_cd_set_bld') Goto 9999 end if diff --git a/base/tools/psb_cdcpy.f90 b/base/tools/psb_cdcpy.f90 index 6834e0e16..1b5930c1d 100644 --- a/base/tools/psb_cdcpy.f90 +++ b/base/tools/psb_cdcpy.f90 @@ -57,7 +57,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) debug_level = psb_get_debug_level() if (psb_get_errstatus() /= 0) return - info = 0 + info = psb_success_ call psb_erractionsave(err_act) name = 'psb_cdcpy' @@ -68,31 +68,31 @@ subroutine psb_cdcpy(desc_in, desc_out, info) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': Entered' if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif call psb_safe_ab_cpy(desc_in%matrix_data,desc_out%matrix_data,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%halo_index,desc_out%halo_index,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ext_index,desc_out%ext_index,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ovrlap_index,desc_out%ovrlap_index,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ovr_mst_idx,desc_out%ovr_mst_idx,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%lprm,desc_out%lprm,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info) - if (info == 0) call psb_idxmap_copy(desc_in%idxmap,desc_out%idxmap, info) -!!$ if (info == 0) call psb_safe_ab_cpy(desc_in%loc_to_glob,desc_out%loc_to_glob,info) -!!$ if (info == 0) call psb_safe_ab_cpy(desc_in%glob_to_loc,desc_out%glob_to_loc,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%halo_index,desc_out%halo_index,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ext_index,desc_out%ext_index,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_index,desc_out%ovrlap_index,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%ovr_mst_idx,desc_out%ovr_mst_idx,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%lprm,desc_out%lprm,info) + if (info == psb_success_) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info) + if (info == psb_success_) call psb_idxmap_copy(desc_in%idxmap,desc_out%idxmap, info) +!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%loc_to_glob,desc_out%loc_to_glob,info) +!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%glob_to_loc,desc_out%glob_to_loc,info) !!$ desc_out%hashvsize = desc_in%hashvsize !!$ desc_out%hashvmask = desc_in%hashvmask -!!$ if (info == 0) call psb_safe_ab_cpy(desc_in%hashv,desc_out%hashv,info) -!!$ if (info == 0) call psb_safe_ab_cpy(desc_in%glb_lc,desc_out%glb_lc,info) -!!$ if (info == 0) call CloneHashTable(desc_in%hash,desc_out%hash,info) +!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%hashv,desc_out%hashv,info) +!!$ if (info == psb_success_) call psb_safe_ab_cpy(desc_in%glb_lc,desc_out%glb_lc,info) +!!$ if (info == psb_success_) call CloneHashTable(desc_in%hash,desc_out%hash,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_cdins.f90 b/base/tools/psb_cdins.f90 index a2dba1725..f6271ded5 100644 --- a/base/tools/psb_cdins.f90 +++ b/base/tools/psb_cdins.f90 @@ -66,7 +66,7 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) integer, allocatable :: ila_(:), jla_(:) character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_cdins' call psb_erractionsave(err_act) @@ -80,7 +80,7 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) call psb_info(ictxt, me, np) if (.not.psb_is_bld_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -126,8 +126,8 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) write(0,*) 'Inconsistent call : ',present(ila),present(jla) endif allocate(ila_(nz),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -189,7 +189,7 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask) logical, pointer :: mask_(:) character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_cdins' call psb_erractionsave(err_act) @@ -203,7 +203,7 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask) call psb_info(ictxt, me, np) if (.not.psb_is_bld_desc(desc)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -245,8 +245,8 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask) call psi_idx_ins_cnv(nz,ja,jla,desc,info,mask=mask_) else allocate(jla_(nz),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index bf3aea500..597e1f63a 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -63,7 +63,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_cdren' debug_unit = psb_get_debug_unit() @@ -77,13 +77,13 @@ subroutine psb_cdren(trans,iperm,desc_a,info) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 600 + info = psb_err_spmat_invalid_state_ int_err(1) = dectype call psb_errpush(info,name,int_err) goto 9999 diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index d9a0d6b01..caad3d066 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -30,14 +30,14 @@ !!$ !!$ ! Purpose - ! ======= + ! == = ==== ! ! Allocate special descriptor for replicated index space. ! ! ! ! INPUT - !====== + ! == ==== ! M :(Global Input) Integer ! Total number of equations ! required. @@ -46,7 +46,7 @@ ! required. ! ! OUTPUT - !========= + ! == ======= ! desc : TYPEDESC ! desc OUTPUT FIELDS: ! @@ -117,7 +117,7 @@ subroutine psb_cdrep(m, ictxt, desc, info) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 name = 'psb_cdrep' debug_unit = psb_get_debug_unit() @@ -130,16 +130,16 @@ subroutine psb_cdrep(m, ictxt, desc, info) n = m !... check m and n parameters.... if (m < 1) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m else if (n < 1) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 2 int_err(2) = n endif - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -154,15 +154,15 @@ subroutine psb_cdrep(m, ictxt, desc, info) else call psb_bcast(ictxt,exch(1:2),root=psb_root_) if (exch(1) /= m) then - info=550 + info=psb_err_parm_differs_among_procs_ int_err(1)=1 else if (exch(2) /= n) then - info=550 + info=psb_err_parm_differs_among_procs_ int_err(1)=2 endif endif - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name,i_err=int_err) goto 9999 end if @@ -176,8 +176,8 @@ subroutine psb_cdrep(m, ictxt, desc, info) allocate(desc%idxmap%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& & desc%idxmap%loc_to_glob(m),desc%lprm(1),& & desc%ovrlap_elem(0,3),stat=info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=2*m+psb_mdata_size_+1 call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -206,8 +206,8 @@ subroutine psb_cdrep(m, ictxt, desc, info) desc%lprm(:) = 0 call psi_cnv_dsc(thalo,tovr,text,desc,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_cvn_dsc') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cvn_dsc') goto 9999 end if diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 index 210e9c604..a07e0af66 100644 --- a/base/tools/psb_cfree.f90 +++ b/base/tools/psb_cfree.f90 @@ -53,11 +53,11 @@ subroutine psb_cfree(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_cfree' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return end if @@ -67,13 +67,13 @@ subroutine psb_cfree(x, desc_a, info) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -81,7 +81,7 @@ subroutine psb_cfree(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -123,13 +123,13 @@ subroutine psb_cfreev(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_cfreev' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -137,14 +137,14 @@ subroutine psb_cfreev(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -152,7 +152,7 @@ subroutine psb_cfreev(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) endif diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index cb9a8687a..e359d5983 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -72,7 +72,7 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_cinsvi' @@ -86,20 +86,20 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -111,14 +111,14 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) mglob = psb_cd_get_global_rows(desc_a) allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -253,7 +253,7 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_cinsi' @@ -267,20 +267,20 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -291,7 +291,7 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl) call psb_errpush(info,name,int_err) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) @@ -306,8 +306,8 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl) endif allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_cspalloc.f90 b/base/tools/psb_cspalloc.f90 index 2130408d3..a5d159232 100644 --- a/base/tools/psb_cspalloc.f90 +++ b/base/tools/psb_cspalloc.f90 @@ -60,7 +60,7 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_cspall' debug_unit = psb_get_debug_unit() @@ -72,7 +72,7 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -103,8 +103,8 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) !....allocate aspk, ia1, ia2..... call a%csall(loc_row,loc_col,info,nz=length_ia1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='sp_all' call psb_errpush(info,name,int_err) goto 9999 diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 index 5747dc593..207d7376e 100644 --- a/base/tools/psb_cspasb.f90 +++ b/base/tools/psb_cspasb.f90 @@ -69,7 +69,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold) integer :: debug_level, debug_unit character(len=20) :: name, ch_err - info = 0 + info = psb_success_ int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) @@ -83,13 +83,13 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold) ! check on BLACS grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 600 + info = psb_err_spmat_invalid_state_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name) goto 9999 @@ -123,7 +123,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold) end IF if (info /= psb_no_err_) then - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_cspfree.f90 b/base/tools/psb_cspfree.f90 index 7c2a3c9a2..34461bcef 100644 --- a/base/tools/psb_cspfree.f90 +++ b/base/tools/psb_cspfree.f90 @@ -52,12 +52,12 @@ subroutine psb_cspfree(a, desc_a,info) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_cspfree' call psb_erractionsave(err_act) if (.not.allocated(desc_a%matrix_data)) then - info = 295 + info = psb_err_forgot_spall_ call psb_errpush(info,name) return else diff --git a/base/tools/psb_csphalo.F90 b/base/tools/psb_csphalo.F90 index 3efb0028b..3f349d246 100644 --- a/base/tools/psb_csphalo.F90 +++ b/base/tools/psb_csphalo.F90 @@ -92,7 +92,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_csphalo' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -141,8 +141,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -160,7 +160,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! !$ idxv => desc_a%ovrlap_index ! Do not accept OVRLAP_INDEX any longer. case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') goto 9999 end select @@ -196,8 +196,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& Enddo call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -225,8 +225,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -234,8 +234,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& mat_recv = iszr iszs=sum(sdsz) call psb_ensure_size(max(iszs,1),iasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),jasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),valsnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) l1 = 0 ipx = 1 @@ -255,8 +255,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_getrow' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -270,8 +270,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_loc_to_glob' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -284,8 +284,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& & acoo%ia,rvsz,brvindx,mpi_integer,icomm,info) call mpi_alltoallv(jasnd,sdsz,bsdindx,mpi_integer,& & acoo%ja,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -297,8 +297,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psbglob_to_loc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -349,8 +349,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! Do we expect any duplicates to appear???? call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_cspins.f90 b/base/tools/psb_cspins.f90 index f637bf15b..dea8b23fe 100644 --- a/base/tools/psb_cspins.f90 +++ b/base/tools/psb_cspins.f90 @@ -70,7 +70,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_cspins' call psb_erractionsave(err_act) @@ -80,7 +80,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -106,7 +106,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (present(rebuild)) then rebuild_ = rebuild @@ -118,15 +118,15 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -134,14 +134,14 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -149,9 +149,9 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) else call psb_cdins(nz,ia,ja,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -159,14 +159,14 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -178,9 +178,9 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -192,8 +192,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -204,15 +204,15 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ia,ja,val,1,nrow,1,ncol,& & info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -252,7 +252,7 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_cspins' call psb_erractionsave(err_act) @@ -262,12 +262,12 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_ar)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_ac)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -293,14 +293,14 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (psb_is_bld_desc(desc_ac)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if ila(1:nz) = ia(1:nz) @@ -309,9 +309,9 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -319,8 +319,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) ncol = psb_cd_get_local_cols(desc_ac) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -332,9 +332,9 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ if (psb_is_large_desc(desc_a)) then !!$ !!$ allocate(ila(nz),jla(nz),stat=info) -!!$ if (info /= 0) then +!!$ if (info /= psb_success_) then !!$ ch_err='allocate' -!!$ call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) +!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) !!$ goto 9999 !!$ end if !!$ @@ -347,8 +347,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ !!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& !!$ & info,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 @@ -359,15 +359,15 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ ncol = psb_cd_get_local_cols(desc_a) !!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& !!$ & info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if !!$ end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/tools/psb_csprn.f90 b/base/tools/psb_csprn.f90 index f3a74591e..00e5052da 100644 --- a/base/tools/psb_csprn.f90 +++ b/base/tools/psb_csprn.f90 @@ -59,7 +59,7 @@ Subroutine psb_csprn(a, desc_a,info,clear) character(len=20) :: name logical :: clear_ - info = 0 + info = psb_success_ err = 0 int_err(1)=0 name = 'psb_csprn' @@ -84,7 +84,7 @@ Subroutine psb_csprn(a, desc_a,info,clear) call a%reinit(clear=clear) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': done' diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 363f3694e..6aacf4a09 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -61,7 +61,7 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) name='psb_geall' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 int_err(1)=0 call psb_erractionsave(err_act) @@ -70,14 +70,14 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -94,7 +94,7 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) else call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then - info=550 + info=psb_err_parm_differs_among_procs_ int_err(1)=1 call psb_errpush(info,name,int_err) goto 9999 @@ -107,14 +107,14 @@ subroutine psb_dalloc(x, desc_a, info, n, lb) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr*n_ call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') goto 9999 @@ -194,7 +194,7 @@ subroutine psb_dallocv(x, desc_a,info,n) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_geall' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -205,14 +205,14 @@ subroutine psb_dallocv(x, desc_a,info,n) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -225,14 +225,14 @@ subroutine psb_dallocv(x, desc_a,info,n) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,x,info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') goto 9999 diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index 60997a17e..1c2b5d342 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -57,14 +57,14 @@ subroutine psb_dasb(x, desc_a, info) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_dgeasb_m' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() if ((.not.allocated(desc_a%matrix_data))) then - info=3110 + info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -78,14 +78,14 @@ subroutine psb_dasb(x, desc_a, info) & psb_cd_get_dectype(desc_a) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),' error ',& & psb_cd_get_dectype(desc_a) - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -101,8 +101,8 @@ subroutine psb_dasb(x, desc_a, info) if (i1sz < ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -110,8 +110,8 @@ subroutine psb_dasb(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_halo' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -189,7 +189,7 @@ subroutine psb_dasbv(x, desc_a, info) integer :: debug_level, debug_unit character(len=20) :: name,ch_err - info = 0 + info = psb_success_ int_err(1) = 0 name = 'psb_dgeasb_v' @@ -201,11 +201,11 @@ subroutine psb_dasbv(x, desc_a, info) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -219,8 +219,8 @@ subroutine psb_dasbv(x, desc_a, info) & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol if (i1sz < ncol) then call psb_realloc(ncol,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -228,8 +228,8 @@ subroutine psb_dasbv(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='f90_pshalo' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_dcdbldext.F90 b/base/tools/psb_dcdbldext.F90 index 763e17f7e..cb087836b 100644 --- a/base/tools/psb_dcdbldext.F90 +++ b/base/tools/psb_dcdbldext.F90 @@ -99,7 +99,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) character(len=20) :: name, ch_err name='psb_dcdbldext' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -123,7 +123,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) nhalo = n_col-m if (novr<0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=novr call psb_errpush(info,name,i_err=int_err) @@ -134,8 +134,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdcpy' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -144,7 +144,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':From desccpy' - if (novr==0) then + if (novr == 0) then ! ! Just copy the input. ! @@ -193,22 +193,22 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if halo(:) = desc_a%halo_index(:) @@ -238,8 +238,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -339,8 +339,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -351,8 +351,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -383,8 +383,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -400,15 +400,15 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') goto 9999 end if call psb_ensure_size((idxs+tot_elem+n_elem),works,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -444,8 +444,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! matchings SENDs. ! call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -470,8 +470,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) iszr=sum(rvsz) if (max(iszr,1) > lworkr) then call psb_realloc(max(iszr,1),workr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -481,8 +481,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -493,8 +493,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) if (psb_is_large_desc(desc_ov)) then call psb_ensure_size(iszr,maskr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -531,8 +531,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) proc_id = temp(i) call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -561,8 +561,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) n_col = n_col+1 proc_id = -desc_ov%idxmap%glob_to_loc(idx)-np-1 call psb_ensure_size(n_col,desc_ov%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -571,8 +571,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%idxmap%loc_to_glob(n_col) = idx call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -644,8 +644,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if tmp_halo(counter_h:counter_h+counter_t-1) = t_halo_in(1:counter_t) @@ -653,8 +653,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%halo_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if @@ -670,8 +670,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) @@ -679,15 +679,15 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(30,name,i_err=(/5,extype_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) goto 9999 end select @@ -704,18 +704,18 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) - if (info /= 0) then - call psb_errpush(4010,name,a_err='icdasdb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb') goto 9999 end if call psb_cd_set_ovl_asb(desc_ov,info) - if (info == 0) then + if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info ==0).and.allocated(icol)) deallocate(icol,stat=info) - if (info /= 0) then - call psb_errpush(4013,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) + if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) goto 9999 end if end if diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 865682ddf..aa7f0fd19 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -53,11 +53,11 @@ subroutine psb_dfree(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_dfree' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -67,13 +67,13 @@ subroutine psb_dfree(x, desc_a, info) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -81,7 +81,7 @@ subroutine psb_dfree(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -122,12 +122,12 @@ subroutine psb_dfreev(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_dfreev' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return end if @@ -135,13 +135,13 @@ subroutine psb_dfreev(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -149,7 +149,7 @@ subroutine psb_dfreev(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) endif diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index e6d453789..fa4bb1f72 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -71,7 +71,7 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_dinsvi' @@ -85,20 +85,20 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -110,15 +110,15 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) mglob = psb_cd_get_global_rows(desc_a) allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -253,7 +253,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_dinsi' @@ -267,20 +267,20 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -291,7 +291,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) call psb_errpush(info,name,int_err) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) @@ -306,8 +306,8 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl) endif allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_dspalloc.f90 b/base/tools/psb_dspalloc.f90 index 25e97bc52..ac8248b55 100644 --- a/base/tools/psb_dspalloc.f90 +++ b/base/tools/psb_dspalloc.f90 @@ -60,7 +60,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_dspall' debug_unit = psb_get_debug_unit() @@ -72,7 +72,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -103,8 +103,8 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) !....allocate aspk, ia1, ia2..... call a%csall(loc_row,loc_col,info,nz=length_ia1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='sp_all' call psb_errpush(info,name,int_err) goto 9999 diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index 2bf0d0230..a04b977cb 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -69,7 +69,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) integer :: debug_level, debug_unit character(len=20) :: name, ch_err - info = 0 + info = psb_success_ int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) @@ -83,13 +83,13 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) ! check on BLACS grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 600 + info = psb_err_spmat_invalid_state_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name) goto 9999 @@ -123,7 +123,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) end IF if (info /= psb_no_err_) then - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_dspfree.f90 b/base/tools/psb_dspfree.f90 index 4bfcdbc91..a85615808 100644 --- a/base/tools/psb_dspfree.f90 +++ b/base/tools/psb_dspfree.f90 @@ -52,12 +52,12 @@ subroutine psb_dspfree(a, desc_a,info) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_dspfree' call psb_erractionsave(err_act) if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return else diff --git a/base/tools/psb_dsphalo.F90 b/base/tools/psb_dsphalo.F90 index e0a34f34e..d29165d08 100644 --- a/base/tools/psb_dsphalo.F90 +++ b/base/tools/psb_dsphalo.F90 @@ -92,7 +92,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_dsphalo' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -141,8 +141,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -160,7 +160,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! !$ idxv => desc_a%ovrlap_index ! Do not accept OVRLAP_INDEX any longer. case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') goto 9999 end select @@ -196,8 +196,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Enddo call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -225,8 +225,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -234,8 +234,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& mat_recv = iszr iszs=sum(sdsz) call psb_ensure_size(max(iszs,1),iasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),jasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),valsnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) l1 = 0 ipx = 1 @@ -255,8 +255,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_getrow' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -270,8 +270,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_loc_to_glob' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -284,8 +284,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& & acoo%ia,rvsz,brvindx,mpi_integer,icomm,info) call mpi_alltoallv(jasnd,sdsz,bsdindx,mpi_integer,& & acoo%ja,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -297,8 +297,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psbglob_to_loc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -349,8 +349,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! Do we expect any duplicates to appear???? call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_dspins.f90 b/base/tools/psb_dspins.f90 index d4af50f35..4a9878f8a 100644 --- a/base/tools/psb_dspins.f90 +++ b/base/tools/psb_dspins.f90 @@ -69,7 +69,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_dspins' call psb_erractionsave(err_act) @@ -79,7 +79,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -105,7 +105,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (present(rebuild)) then rebuild_ = rebuild @@ -117,15 +117,15 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -133,14 +133,14 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -148,9 +148,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) else call psb_cdins(nz,ia,ja,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -158,14 +158,14 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -177,9 +177,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -191,8 +191,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -203,15 +203,15 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ia,ja,val,1,nrow,1,ncol,& & info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -250,7 +250,7 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_dspins' call psb_erractionsave(err_act) @@ -260,12 +260,12 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_ar)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_ac)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -291,14 +291,14 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (psb_is_bld_desc(desc_ac)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if ila(1:nz) = ia(1:nz) @@ -307,9 +307,9 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -317,8 +317,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) ncol = psb_cd_get_local_cols(desc_ac) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -330,9 +330,9 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ if (psb_is_large_desc(desc_a)) then !!$ !!$ allocate(ila(nz),jla(nz),stat=info) -!!$ if (info /= 0) then +!!$ if (info /= psb_success_) then !!$ ch_err='allocate' -!!$ call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) +!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) !!$ goto 9999 !!$ end if !!$ @@ -345,8 +345,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ !!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& !!$ & info,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 @@ -357,15 +357,15 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ ncol = psb_cd_get_local_cols(desc_a) !!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& !!$ & info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if !!$ end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/tools/psb_dsprn.f90 b/base/tools/psb_dsprn.f90 index e3155a8b4..7d2e0d92c 100644 --- a/base/tools/psb_dsprn.f90 +++ b/base/tools/psb_dsprn.f90 @@ -58,7 +58,7 @@ Subroutine psb_dsprn(a, desc_a,info,clear) character(len=20) :: name logical :: clear_ - info = 0 + info = psb_success_ err = 0 int_err(1)=0 name = 'psb_dsprn' @@ -83,7 +83,7 @@ Subroutine psb_dsprn(a, desc_a,info,clear) call a%reinit(clear=clear) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': done' diff --git a/base/tools/psb_get_overlap.f90 b/base/tools/psb_get_overlap.f90 index 04c72c6f4..0ae5cd83f 100644 --- a/base/tools/psb_get_overlap.f90 +++ b/base/tools/psb_get_overlap.f90 @@ -52,12 +52,12 @@ subroutine psb_get_ovrlap(ovrel,desc,info) integer :: i,j, err_act character(len=20) :: name - info = 0 + info = psb_success_ name='psi_get_overlap' call psb_erractionsave(err_act) if (.not.psb_is_asb_desc(desc)) then - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -67,8 +67,8 @@ subroutine psb_get_ovrlap(ovrel,desc,info) i=size(desc%ovrlap_elem,1) allocate(ovrel(i),stat=info) - if (info /= 0 ) then - info = 4000 + if (info /= psb_success_ ) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -81,8 +81,8 @@ subroutine psb_get_ovrlap(ovrel,desc,info) if (allocated(ovrel)) then deallocate(ovrel,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') goto 9999 end if end if diff --git a/base/tools/psb_glob_to_loc.f90 b/base/tools/psb_glob_to_loc.f90 index f2290efa8..3cace4015 100644 --- a/base/tools/psb_glob_to_loc.f90 +++ b/base/tools/psb_glob_to_loc.f90 @@ -67,7 +67,7 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'glob_to_loc' call psb_erractionsave(err_act) @@ -92,11 +92,11 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned) call psb_erractionrestore(err_act) return case('W') - if ((info /= 0).or.(count(y(1:n)<0) >0)) then + if ((info /= psb_success_).or.(count(y(1:n)<0) >0)) then write(0,'("Error ",i5," in subroutine glob_to_loc")') info end if case('A') - if ((info /= 0).or.(count(y(1:n)<0) >0)) then + if ((info /= psb_success_).or.(count(y(1:n)<0) >0)) then call psb_errpush(info,name) goto 9999 end if @@ -187,7 +187,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) integer :: ictxt, iam, np if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'glob_to_loc' ictxt = desc_a%matrix_data(psb_ctxt_) call psb_info(ictxt,iam,np) @@ -215,11 +215,11 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact,owned) call psb_erractionrestore(err_act) return case('W') - if ((info /= 0).or.(count(x(1:n)<0) >0)) then + if ((info /= psb_success_).or.(count(x(1:n)<0) >0)) then write(0,'("Error ",i5," in subroutine glob_to_loc")') info end if case('A') - if ((info /= 0).or.(count(x(1:n)<0) >0)) then + if ((info /= psb_success_).or.(count(x(1:n)<0) >0)) then write(0,*) count(x(1:n)<0) call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_ialloc.f90 b/base/tools/psb_ialloc.f90 index 3f19ed10f..70682a0a1 100644 --- a/base/tools/psb_ialloc.f90 +++ b/base/tools/psb_ialloc.f90 @@ -59,7 +59,7 @@ subroutine psb_ialloc(x, desc_a, info, n, lb) name='psb_geall' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 int_err(1)=0 call psb_erractionsave(err_act) @@ -68,14 +68,14 @@ subroutine psb_ialloc(x, desc_a, info, n, lb) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -92,7 +92,7 @@ subroutine psb_ialloc(x, desc_a, info, n, lb) else call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then - info=550 + info=psb_err_parm_differs_among_procs_ int_err(1)=1 call psb_errpush(info,name,int_err) goto 9999 @@ -105,14 +105,14 @@ subroutine psb_ialloc(x, desc_a, info, n, lb) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr*n_ call psb_errpush(info,name,int_err,a_err='integer') goto 9999 @@ -191,7 +191,7 @@ subroutine psb_iallocv(x, desc_a, info,n) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_geall' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -202,14 +202,14 @@ subroutine psb_iallocv(x, desc_a, info,n) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -222,14 +222,14 @@ subroutine psb_iallocv(x, desc_a, info,n) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,x,info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr call psb_errpush(info,name,int_err,a_err='integer') goto 9999 diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 061992942..5175eccbb 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -57,14 +57,14 @@ subroutine psb_iasb(x, desc_a, info) character(len=20) :: name,ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_igeasb_m' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() if ((.not.allocated(desc_a%matrix_data))) then - info=3110 + info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -78,14 +78,14 @@ subroutine psb_iasb(x, desc_a, info) & psb_cd_get_dectype(desc_a) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),' error ',& & psb_cd_get_dectype(desc_a) - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -101,8 +101,8 @@ subroutine psb_iasb(x, desc_a, info) if (i1sz < ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -110,8 +110,8 @@ subroutine psb_iasb(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_halo' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -190,7 +190,7 @@ subroutine psb_iasbv(x, desc_a, info) integer :: debug_level, debug_unit character(len=20) :: name,ch_err - info = 0 + info = psb_success_ int_err(1) = 0 name = 'psb_igeasb_v' @@ -202,11 +202,11 @@ subroutine psb_iasbv(x, desc_a, info) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -220,8 +220,8 @@ subroutine psb_iasbv(x, desc_a, info) & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol if (i1sz < ncol) then call psb_realloc(ncol,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -229,8 +229,8 @@ subroutine psb_iasbv(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='f90_pshalo' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index 5334f1b34..b7ad3bca5 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -67,7 +67,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ int_err(1) = 0 name = 'psb_cdasb' @@ -84,13 +84,13 @@ subroutine psb_icdasb(desc_a,info,ext_hv) ! check on blacs grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_a)) then - info = 600 + info = psb_err_spmat_invalid_state_ int_err(1) = dectype call psb_errpush(info,name) goto 9999 @@ -134,8 +134,8 @@ subroutine psb_icdasb(desc_a,info,ext_hv) & write(debug_unit,*) me,' ',trim(name),& & ': Large descriptor, calling ldsc_pre_halo' call psi_ldsc_pre_halo(desc_a,ext_hv_,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='ldsc_pre_halo') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='ldsc_pre_halo') goto 9999 end if end if @@ -149,14 +149,14 @@ subroutine psb_icdasb(desc_a,info,ext_hv) & write(debug_unit,*) me,' ',trim(name),': Final conversion' ! Then convert and put them back where they belong. call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psi_cnv_dsc') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cnv_dsc') goto 9999 end if deallocate(ovrlap_index, halo_index, ext_index, stat=info) - if (info /= 0) then - info =4000 + if (info /= psb_success_) then + info =psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -164,7 +164,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv) ! Ok, register into MATRIX_DATA desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ else - info = 600 + info = psb_err_spmat_invalid_state_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index 62a89cc63..baa74ff8b 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -53,12 +53,12 @@ subroutine psb_ifree(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_ifree' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return end if @@ -68,20 +68,20 @@ subroutine psb_ifree(x, desc_a, info) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=290 + info=psb_err_forgot_geall_ call psb_errpush(info,name) goto 9999 end if !deallocate x deallocate(x,stat=info) - if (info /= 0) then + if (info /= psb_success_) then info=2045 call psb_errpush(info,name) goto 9999 @@ -153,13 +153,13 @@ subroutine psb_ifreev(x, desc_a,info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_ifreev' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return end if @@ -168,13 +168,13 @@ subroutine psb_ifreev(x, desc_a,info) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=290 + info=psb_err_forgot_geall_ call psb_errpush(info,name) goto 9999 end if @@ -182,7 +182,7 @@ subroutine psb_ifreev(x, desc_a,info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) endif diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 32bb7e368..e1c2c4901 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -71,7 +71,7 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_insvi' @@ -85,20 +85,20 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -110,14 +110,14 @@ subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) mglob = psb_cd_get_global_rows(desc_a) allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -252,7 +252,7 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_iinsi' @@ -266,20 +266,20 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -290,7 +290,7 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl) call psb_errpush(info,name,int_err) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) @@ -305,8 +305,8 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl) endif allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_linmap.f90 b/base/tools/psb_linmap.f90 index d6bbe129c..04b8c4b61 100644 --- a/base/tools/psb_linmap.f90 +++ b/base/tools/psb_linmap.f90 @@ -44,19 +44,19 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res integer :: info character(len=20), parameter :: name='psb_linmap' - info = 0 + info = psb_success_ select case(map_kind) case (psb_map_aggr_) ! OK if (psb_is_ok_desc(desc_X)) then this%p_desc_X=>desc_X else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then this%p_desc_Y=>desc_Y else - info = 3 + info = psb_err_invalid_ovr_num_ endif if (present(iaggr)) then if (.not.present(naggr)) then @@ -64,7 +64,7 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res else allocate(this%iaggr(size(iaggr)),& & this%naggr(size(naggr)), stat=info) - if (info == 0) then + if (info == psb_success_) then this%iaggr = iaggr this%naggr = naggr end if @@ -78,12 +78,12 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (psb_is_ok_desc(desc_X)) then call psb_cdcpy(desc_X, this%desc_X,info) else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then call psb_cdcpy(desc_Y, this%desc_Y,info) else - info = 3 + info = psb_err_invalid_ovr_num_ endif ! For a general linear map ignore iaggr,naggr allocate(this%iaggr(0), this%naggr(0), stat=info) @@ -93,13 +93,13 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res info = 1 end select - if (info == 0) call psb_clone(map_X2Y,this%map_X2Y,info) - if (info == 0) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) - if (info == 0) then + if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) + if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) + if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == psb_success_) then call psb_set_map_kind(map_kind, this) end if - if (info /= 0) then + if (info /= psb_success_) then write(0,*) trim(name),' Invalid descriptor input' return end if @@ -121,7 +121,7 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res character(len=20), parameter :: name='psb_linmap' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ select case(map_kind) case (psb_map_aggr_) ! OK @@ -129,12 +129,12 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (psb_is_ok_desc(desc_X)) then this%p_desc_X=>desc_X else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then this%p_desc_Y=>desc_Y else - info = 3 + info = psb_err_invalid_ovr_num_ endif if (present(iaggr)) then if (.not.present(naggr)) then @@ -142,7 +142,7 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res else allocate(this%iaggr(size(iaggr)),& & this%naggr(size(naggr)), stat=info) - if (info == 0) then + if (info == psb_success_) then this%iaggr = iaggr this%naggr = naggr end if @@ -156,12 +156,12 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (psb_is_ok_desc(desc_X)) then call psb_cdcpy(desc_X, this%desc_X,info) else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then call psb_cdcpy(desc_Y, this%desc_Y,info) else - info = 3 + info = psb_err_invalid_ovr_num_ endif ! For a general linear map ignore iaggr,naggr allocate(this%iaggr(0), this%naggr(0), stat=info) @@ -171,13 +171,13 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res info = 1 end select - if (info == 0) call psb_clone(map_X2Y,this%map_X2Y,info) - if (info == 0) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) - if (info == 0) then + if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) + if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) + if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == psb_success_) then call psb_set_map_kind(map_kind, this) end if - if (info /= 0) then + if (info /= psb_success_) then write(0,*) trim(name),' Invalid descriptor input' return end if @@ -202,7 +202,7 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res integer :: info character(len=20), parameter :: name='psb_linmap' - info = 0 + info = psb_success_ select case(map_kind) case (psb_map_aggr_) @@ -211,12 +211,12 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (psb_is_ok_desc(desc_X)) then this%p_desc_X=>desc_X else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then this%p_desc_Y=>desc_Y else - info = 3 + info = psb_err_invalid_ovr_num_ endif if (present(iaggr)) then if (.not.present(naggr)) then @@ -224,7 +224,7 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res else allocate(this%iaggr(size(iaggr)),& & this%naggr(size(naggr)), stat=info) - if (info == 0) then + if (info == psb_success_) then this%iaggr = iaggr this%naggr = naggr end if @@ -238,12 +238,12 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (psb_is_ok_desc(desc_X)) then call psb_cdcpy(desc_X, this%desc_X,info) else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then call psb_cdcpy(desc_Y, this%desc_Y,info) else - info = 3 + info = psb_err_invalid_ovr_num_ endif ! For a general linear map ignore iaggr,naggr allocate(this%iaggr(0), this%naggr(0), stat=info) @@ -254,13 +254,13 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res end select - if (info == 0) call psb_clone(map_X2Y,this%map_X2Y,info) - if (info == 0) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) - if (info == 0) then + if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) + if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) + if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == psb_success_) then call psb_set_map_kind(map_kind, this) end if - if (info /= 0) then + if (info /= psb_success_) then write(0,*) trim(name),' Invalid descriptor input' return end if @@ -281,7 +281,7 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res integer :: info character(len=20), parameter :: name='psb_linmap' - info = 0 + info = psb_success_ select case(map_kind) case (psb_map_aggr_) ! OK @@ -289,12 +289,12 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (psb_is_ok_desc(desc_X)) then this%p_desc_X=>desc_X else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then this%p_desc_Y=>desc_Y else - info = 3 + info = psb_err_invalid_ovr_num_ endif if (present(iaggr)) then if (.not.present(naggr)) then @@ -302,7 +302,7 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res else allocate(this%iaggr(size(iaggr)),& & this%naggr(size(naggr)), stat=info) - if (info == 0) then + if (info == psb_success_) then this%iaggr = iaggr this%naggr = naggr end if @@ -316,12 +316,12 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (psb_is_ok_desc(desc_X)) then call psb_cdcpy(desc_X, this%desc_X,info) else - info = 2 + info = psb_err_pivot_too_small_ endif if (psb_is_ok_desc(desc_Y)) then call psb_cdcpy(desc_Y, this%desc_Y,info) else - info = 3 + info = psb_err_invalid_ovr_num_ endif ! For a general linear map ignore iaggr,naggr allocate(this%iaggr(0), this%naggr(0), stat=info) @@ -331,13 +331,13 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res info = 1 end select - if (info == 0) call psb_clone(map_X2Y,this%map_X2Y,info) - if (info == 0) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info) - if (info == 0) then + if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) + if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) + if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) + if (info == psb_success_) then call psb_set_map_kind(map_kind, this) end if - if (info /= 0) then + if (info /= psb_success_) then write(0,*) trim(name),' Invalid descriptor input' return end if diff --git a/base/tools/psb_loc_to_glob.f90 b/base/tools/psb_loc_to_glob.f90 index 48e378d7c..a43551105 100644 --- a/base/tools/psb_loc_to_glob.f90 +++ b/base/tools/psb_loc_to_glob.f90 @@ -63,7 +63,7 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_loc_to_glob2' call psb_erractionsave(err_act) @@ -76,14 +76,14 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact) call psb_map_l2g(x,y,desc_a%idxmap,info) - if (info /= 0) then + if (info /= psb_success_) then select case(act) case('E','I') ! do nothing, silently. - info = 0 + info = psb_success_ case('W') write(0,'("Error ",i5," in subroutine loc_to_glob")') info - info = 0 + info = psb_success_ case('A') call psb_errpush(info,name) goto 9999 @@ -168,7 +168,7 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_loc_to_glob' call psb_erractionsave(err_act) @@ -181,14 +181,14 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact) call psb_map_l2g(x,desc_a%idxmap,info) - if (info /= 0) then + if (info /= psb_success_) then select case(act) case('E','I') ! do nothing, silently. - info = 0 + info = psb_success_ case('W') write(0,'("Error ",i5," in subroutine loc_to_glob")') info - info = 0 + info = psb_success_ case('A') call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_map.f90 b/base/tools/psb_map.f90 index 2b1e12c41..c392d7abc 100644 --- a/base/tools/psb_map.f90 +++ b/base/tools/psb_map.f90 @@ -48,7 +48,7 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input' info = 1 @@ -64,13 +64,13 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_Y) nc2 = psb_cd_get_local_cols(map%p_desc_Y) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_X,info,work=work) - if (info == 0) call psb_csmm(sone,map%map_X2Y,x,szero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_Y)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(sone,map%map_X2Y,x,szero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -84,13 +84,13 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_Y) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_X,info,work=work) - if (info == 0) call psb_csmm(sone,map%map_X2Y,xt,szero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_Y)) then + if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(sone,map%map_X2Y,xt,szero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -127,7 +127,7 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input' info = 1 @@ -143,13 +143,13 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_X) nc2 = psb_cd_get_local_cols(map%p_desc_X) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_Y,info,work=work) - if (info == 0) call psb_csmm(sone,map%map_Y2X,x,szero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_X)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(sone,map%map_Y2X,x,szero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -163,13 +163,13 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_X) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_Y,info,work=work) - if (info == 0) call psb_csmm(sone,map%map_Y2X,xt,szero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_X)) then + if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(sone,map%map_Y2X,xt,szero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -205,7 +205,7 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input: unassembled' info = 1 @@ -221,13 +221,13 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_Y) nc2 = psb_cd_get_local_cols(map%p_desc_Y) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_X,info,work=work) - if (info == 0) call psb_csmm(done,map%map_X2Y,x,dzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_Y)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(done,map%map_X2Y,x,dzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -241,13 +241,13 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_Y) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_X,info,work=work) - if (info == 0) call psb_csmm(done,map%map_X2Y,xt,dzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_Y)) then + if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(done,map%map_X2Y,xt,dzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -285,7 +285,7 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input' info = 1 @@ -301,13 +301,13 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_X) nc2 = psb_cd_get_local_cols(map%p_desc_X) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_Y,info,work=work) - if (info == 0) call psb_csmm(done,map%map_Y2X,x,dzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_X)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(done,map%map_Y2X,x,dzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -321,13 +321,13 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_X) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_Y,info,work=work) - if (info == 0) call psb_csmm(done,map%map_Y2X,xt,dzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_X)) then + if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(done,map%map_Y2X,xt,dzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -364,7 +364,7 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input' info = 1 @@ -380,13 +380,13 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_Y) nc2 = psb_cd_get_local_cols(map%p_desc_Y) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_X,info,work=work) - if (info == 0) call psb_csmm(cone,map%map_X2Y,x,czero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_Y)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(cone,map%map_X2Y,x,czero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -400,13 +400,13 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_Y) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_X,info,work=work) - if (info == 0) call psb_csmm(cone,map%map_X2Y,xt,czero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_Y)) then + if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(cone,map%map_X2Y,xt,czero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -443,7 +443,7 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input' info = 1 @@ -459,13 +459,13 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_X) nc2 = psb_cd_get_local_cols(map%p_desc_X) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_Y,info,work=work) - if (info == 0) call psb_csmm(cone,map%map_Y2X,x,czero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_X)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(cone,map%map_Y2X,x,czero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -479,13 +479,13 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_X) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_Y,info,work=work) - if (info == 0) call psb_csmm(cone,map%map_Y2X,xt,czero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_X)) then + if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(cone,map%map_Y2X,xt,czero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -522,7 +522,7 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input' info = 1 @@ -538,13 +538,13 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_Y) nc2 = psb_cd_get_local_cols(map%p_desc_Y) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_X,info,work=work) - if (info == 0) call psb_csmm(zone,map%map_X2Y,x,zzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_Y)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(zone,map%map_X2Y,x,zzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -558,13 +558,13 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_Y) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_X,info,work=work) - if (info == 0) call psb_csmm(zone,map%map_X2Y,xt,zzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_Y)) then + if (info == psb_success_) call psb_halo(xt,map%desc_X,info,work=work) + if (info == psb_success_) call psb_csmm(zone,map%map_X2Y,xt,zzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_Y)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_Y,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -601,7 +601,7 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work) & map_kind, map_data, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' - info = 0 + info = psb_success_ if (.not.psb_is_asb_map(map)) then write(0,*) trim(name),' Invalid descriptor input' info = 1 @@ -617,13 +617,13 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work) nr2 = psb_cd_get_global_rows(map%p_desc_X) nc2 = psb_cd_get_local_cols(map%p_desc_X) allocate(yt(nc2),stat=info) - if (info == 0) call psb_halo(x,map%p_desc_Y,info,work=work) - if (info == 0) call psb_csmm(zone,map%map_Y2X,x,zzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%p_desc_X)) then + if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(zone,map%map_Y2X,x,zzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%p_desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if @@ -637,13 +637,13 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work) nc2 = psb_cd_get_local_cols(map%desc_X) allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == 0) call psb_halo(xt,map%desc_Y,info,work=work) - if (info == 0) call psb_csmm(zone,map%map_Y2X,xt,zzero,yt,info) - if ((info == 0) .and. psb_is_repl_desc(map%desc_X)) then + if (info == psb_success_) call psb_halo(xt,map%desc_Y,info,work=work) + if (info == psb_success_) call psb_csmm(zone,map%map_Y2X,xt,zzero,yt,info) + if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_X)) then call psb_sum(ictxt,yt(1:nr2)) end if - if (info == 0) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) - if (info /= 0) then + if (info == psb_success_) call psb_geaxpby(alpha,yt,beta,y,map%desc_X,info) + if (info /= psb_success_) then write(0,*) trim(name),' Error from inner routines',info info = -1 end if diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 9b6c62cfb..9c1ac7654 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -61,7 +61,7 @@ subroutine psb_salloc(x, desc_a, info, n, lb) name='psb_geall' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 int_err(1)=0 call psb_erractionsave(err_act) @@ -70,14 +70,14 @@ subroutine psb_salloc(x, desc_a, info, n, lb) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -94,7 +94,7 @@ subroutine psb_salloc(x, desc_a, info, n, lb) else call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then - info=550 + info=psb_err_parm_differs_among_procs_ int_err(1)=1 call psb_errpush(info,name,int_err) goto 9999 @@ -107,14 +107,14 @@ subroutine psb_salloc(x, desc_a, info, n, lb) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr*n_ call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') goto 9999 @@ -194,7 +194,7 @@ subroutine psb_sallocv(x, desc_a,info,n) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_geall' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -205,14 +205,14 @@ subroutine psb_sallocv(x, desc_a,info,n) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -225,14 +225,14 @@ subroutine psb_sallocv(x, desc_a,info,n) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,x,info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') goto 9999 diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index ea47f298b..88bac7ddb 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -57,14 +57,14 @@ subroutine psb_sasb(x, desc_a, info) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_sgeasb_m' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() if ((.not.allocated(desc_a%matrix_data))) then - info=3110 + info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -78,14 +78,14 @@ subroutine psb_sasb(x, desc_a, info) & psb_cd_get_dectype(desc_a) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),' error ',& & psb_cd_get_dectype(desc_a) - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -101,8 +101,8 @@ subroutine psb_sasb(x, desc_a, info) if (i1sz < ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -110,8 +110,8 @@ subroutine psb_sasb(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_halo' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -189,7 +189,7 @@ subroutine psb_sasbv(x, desc_a, info) integer :: debug_level, debug_unit character(len=20) :: name,ch_err - info = 0 + info = psb_success_ int_err(1) = 0 name = 'psb_sgeasb_v' @@ -201,11 +201,11 @@ subroutine psb_sasbv(x, desc_a, info) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -219,8 +219,8 @@ subroutine psb_sasbv(x, desc_a, info) & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol if (i1sz < ncol) then call psb_realloc(ncol,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -228,8 +228,8 @@ subroutine psb_sasbv(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='f90_pshalo' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_scdbldext.F90 b/base/tools/psb_scdbldext.F90 index a5c1e9579..79143f917 100644 --- a/base/tools/psb_scdbldext.F90 +++ b/base/tools/psb_scdbldext.F90 @@ -98,7 +98,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) character(len=20) :: name, ch_err name='psb_scdbldext' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -122,7 +122,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) nhalo = n_col-m if (novr<0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=novr call psb_errpush(info,name,i_err=int_err) @@ -133,8 +133,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdcpy' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -143,7 +143,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':From desccpy' - if (novr==0) then + if (novr == 0) then ! ! Just copy the input. ! @@ -192,22 +192,22 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if halo(:) = desc_a%halo_index(:) @@ -237,8 +237,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -338,8 +338,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -350,8 +350,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -382,8 +382,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -399,15 +399,15 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') goto 9999 end if call psb_ensure_size((idxs+tot_elem+n_elem),works,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -443,8 +443,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! matchings SENDs. ! call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -469,8 +469,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) iszr=sum(rvsz) if (max(iszr,1) > lworkr) then call psb_realloc(max(iszr,1),workr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -480,8 +480,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -492,8 +492,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (psb_is_large_desc(desc_ov)) then call psb_ensure_size(iszr,maskr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -530,8 +530,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) proc_id = temp(i) call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -560,8 +560,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) n_col = n_col+1 proc_id = -desc_ov%idxmap%glob_to_loc(idx)-np-1 call psb_ensure_size(n_col,desc_ov%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -570,8 +570,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%idxmap%loc_to_glob(n_col) = idx call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -643,8 +643,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if tmp_halo(counter_h:counter_h+counter_t-1) = t_halo_in(1:counter_t) @@ -652,8 +652,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%halo_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if @@ -669,8 +669,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) @@ -678,15 +678,15 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(30,name,i_err=(/5,extype_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) goto 9999 end select @@ -703,18 +703,18 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) - if (info /= 0) then - call psb_errpush(4010,name,a_err='icdasdb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb') goto 9999 end if call psb_cd_set_ovl_asb(desc_ov,info) - if (info == 0) then + if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info ==0).and.allocated(icol)) deallocate(icol,stat=info) - if (info /= 0) then - call psb_errpush(4013,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) + if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) goto 9999 end if end if diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 index ebb09b274..48458ef1b 100644 --- a/base/tools/psb_sfree.f90 +++ b/base/tools/psb_sfree.f90 @@ -53,11 +53,11 @@ subroutine psb_sfree(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_sfree' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -67,13 +67,13 @@ subroutine psb_sfree(x, desc_a, info) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -81,7 +81,7 @@ subroutine psb_sfree(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -122,12 +122,12 @@ subroutine psb_sfreev(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_sfreev' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return end if @@ -135,13 +135,13 @@ subroutine psb_sfreev(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -149,7 +149,7 @@ subroutine psb_sfreev(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) endif diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index 2a25d3983..dbf62243d 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -71,7 +71,7 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_sinsvi' @@ -85,20 +85,20 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -110,15 +110,15 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) mglob = psb_cd_get_global_rows(desc_a) allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -253,7 +253,7 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_sinsi' @@ -267,20 +267,20 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -291,7 +291,7 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl) call psb_errpush(info,name,int_err) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) @@ -306,8 +306,8 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl) endif allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_sspalloc.f90 b/base/tools/psb_sspalloc.f90 index 57c0ab4b4..c83d5af54 100644 --- a/base/tools/psb_sspalloc.f90 +++ b/base/tools/psb_sspalloc.f90 @@ -60,7 +60,7 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_sspall' debug_unit = psb_get_debug_unit() @@ -72,7 +72,7 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -103,8 +103,8 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) !....allocate aspk, ia1, ia2..... call a%csall(loc_row,loc_col,info,nz=length_ia1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='sp_all' call psb_errpush(info,name,int_err) goto 9999 diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 index 092842c0c..3f17f998c 100644 --- a/base/tools/psb_sspasb.f90 +++ b/base/tools/psb_sspasb.f90 @@ -69,7 +69,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) integer :: debug_level, debug_unit character(len=20) :: name, ch_err - info = 0 + info = psb_success_ int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) @@ -83,13 +83,13 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) ! check on BLACS grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 600 + info = psb_err_spmat_invalid_state_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name) goto 9999 @@ -123,7 +123,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) end IF if (info /= psb_no_err_) then - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_sspfree.f90 b/base/tools/psb_sspfree.f90 index 4ec79d346..4c4188836 100644 --- a/base/tools/psb_sspfree.f90 +++ b/base/tools/psb_sspfree.f90 @@ -52,12 +52,12 @@ subroutine psb_sspfree(a, desc_a,info) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_sspfree' call psb_erractionsave(err_act) if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return else diff --git a/base/tools/psb_ssphalo.F90 b/base/tools/psb_ssphalo.F90 index cf01867d2..05ac2b7fe 100644 --- a/base/tools/psb_ssphalo.F90 +++ b/base/tools/psb_ssphalo.F90 @@ -92,7 +92,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_ssphalo' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -141,8 +141,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -160,7 +160,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! !$ idxv => desc_a%ovrlap_index ! Do not accept OVRLAP_INDEX any longer. case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') goto 9999 end select @@ -196,8 +196,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& Enddo call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -225,8 +225,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -234,8 +234,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& mat_recv = iszr iszs=sum(sdsz) call psb_ensure_size(max(iszs,1),iasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),jasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),valsnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) l1 = 0 ipx = 1 @@ -255,8 +255,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_getrow' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -270,8 +270,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_loc_to_glob' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -284,8 +284,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& & acoo%ia,rvsz,brvindx,mpi_integer,icomm,info) call mpi_alltoallv(jasnd,sdsz,bsdindx,mpi_integer,& & acoo%ja,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -297,8 +297,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psbglob_to_loc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -349,8 +349,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! Do we expect any duplicates to appear???? call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_sspins.f90 b/base/tools/psb_sspins.f90 index e4aae24a8..9682c5f6b 100644 --- a/base/tools/psb_sspins.f90 +++ b/base/tools/psb_sspins.f90 @@ -69,7 +69,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_sspins' call psb_erractionsave(err_act) @@ -79,7 +79,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -105,7 +105,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (present(rebuild)) then rebuild_ = rebuild @@ -117,15 +117,15 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -133,14 +133,14 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -148,9 +148,9 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) else call psb_cdins(nz,ia,ja,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -158,14 +158,14 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -177,9 +177,9 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -191,8 +191,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -203,15 +203,15 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ia,ja,val,1,nrow,1,ncol,& & info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -250,7 +250,7 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_sspins' call psb_erractionsave(err_act) @@ -260,12 +260,12 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_ar)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_ac)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -291,14 +291,14 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (psb_is_bld_desc(desc_ac)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if ila(1:nz) = ia(1:nz) @@ -307,9 +307,9 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -317,8 +317,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) ncol = psb_cd_get_local_cols(desc_ac) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -330,9 +330,9 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ if (psb_is_large_desc(desc_a)) then !!$ !!$ allocate(ila(nz),jla(nz),stat=info) -!!$ if (info /= 0) then +!!$ if (info /= psb_success_) then !!$ ch_err='allocate' -!!$ call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) +!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) !!$ goto 9999 !!$ end if !!$ @@ -345,8 +345,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ !!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& !!$ & info,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 @@ -357,15 +357,15 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ ncol = psb_cd_get_local_cols(desc_a) !!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& !!$ & info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if !!$ end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/tools/psb_ssprn.f90 b/base/tools/psb_ssprn.f90 index 503e3ce09..92bb68d3f 100644 --- a/base/tools/psb_ssprn.f90 +++ b/base/tools/psb_ssprn.f90 @@ -58,7 +58,7 @@ Subroutine psb_ssprn(a, desc_a,info,clear) character(len=20) :: name logical :: clear_ - info = 0 + info = psb_success_ err = 0 int_err(1)=0 name = 'psb_ssprn' @@ -83,7 +83,7 @@ Subroutine psb_ssprn(a, desc_a,info,clear) call a%reinit(clear=clear) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': done' diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index 6e08b757b..ba9e762bc 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -61,7 +61,7 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) name='psb_geall' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 int_err(1)=0 call psb_erractionsave(err_act) @@ -70,14 +70,14 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -94,7 +94,7 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) else call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then - info=550 + info=psb_err_parm_differs_among_procs_ int_err(1)=1 call psb_errpush(info,name,int_err) goto 9999 @@ -107,14 +107,14 @@ subroutine psb_zalloc(x, desc_a, info, n, lb) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr*n_ call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') goto 9999 @@ -193,7 +193,7 @@ subroutine psb_zallocv(x, desc_a,info,n) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_geall' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -204,14 +204,14 @@ subroutine psb_zallocv(x, desc_a,info,n) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check m and n parameters.... if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -224,14 +224,14 @@ subroutine psb_zallocv(x, desc_a,info,n) else if (psb_is_bld_desc(desc_a)) then nr = max(1,psb_cd_get_local_rows(desc_a)) else - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,int_err,a_err='Invalid desc_a') goto 9999 endif call psb_realloc(nr,x,info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=nr call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') goto 9999 diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 7e80122e7..bde13b335 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -57,14 +57,14 @@ subroutine psb_zasb(x, desc_a, info) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_zgeasb_m' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() if ((.not.allocated(desc_a%matrix_data))) then - info=3110 + info=psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -78,14 +78,14 @@ subroutine psb_zasb(x, desc_a, info) & psb_cd_get_dectype(desc_a) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),' error ',& & psb_cd_get_dectype(desc_a) - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -101,8 +101,8 @@ subroutine psb_zasb(x, desc_a, info) if (i1sz < ncol) then call psb_realloc(ncol,i2sz,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -110,8 +110,8 @@ subroutine psb_zasb(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_halo' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -189,7 +189,7 @@ subroutine psb_zasbv(x, desc_a, info) integer :: debug_level, debug_unit character(len=20) :: name,ch_err - info = 0 + info = psb_success_ int_err(1) = 0 name = 'psb_zgeasb_v' @@ -201,11 +201,11 @@ subroutine psb_zasbv(x, desc_a, info) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 else if (.not.psb_is_asb_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -219,8 +219,8 @@ subroutine psb_zasbv(x, desc_a, info) & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol if (i1sz < ncol) then call psb_realloc(ncol,x,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_realloc') goto 9999 endif @@ -228,8 +228,8 @@ subroutine psb_zasbv(x, desc_a, info) ! ..update halo elements.. call psb_halo(x,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='f90_pshalo' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_zcdbldext.F90 b/base/tools/psb_zcdbldext.F90 index b0cb02f3e..ebb087483 100644 --- a/base/tools/psb_zcdbldext.F90 +++ b/base/tools/psb_zcdbldext.F90 @@ -98,7 +98,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) character(len=20) :: name, ch_err name='psb_zcdbldext' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -122,7 +122,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) nhalo = n_col-m if (novr<0) then - info=10 + info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=novr call psb_errpush(info,name,i_err=int_err) @@ -133,8 +133,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':Calling desccpy' call psb_cdcpy(desc_a,desc_ov,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdcpy' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -143,7 +143,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) & write(debug_unit,*) me,' ',trim(name),& & ':From desccpy' - if (novr==0) then + if (novr == 0) then ! ! Just copy the input. ! @@ -192,22 +192,22 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(works(lworks),workr(lworkr),t_halo_in(l_tmp_halo),& & t_halo_out(l_tmp_halo), temp(lworkr),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),& & tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if halo(:) = desc_a%halo_index(:) @@ -237,8 +237,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((cntov_o+3),orig_ovr,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -338,8 +338,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -350,8 +350,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_ovr_idx(counter_o+3) = -1 counter_o=counter_o+3 call psb_ensure_size((counter_h+3),tmp_halo,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -382,8 +382,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 endif call psb_ensure_size((counter_o+3),tmp_ovr_idx,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -399,15 +399,15 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') goto 9999 end if call psb_ensure_size((idxs+tot_elem+n_elem),works,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -443,8 +443,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! matchings SENDs. ! call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -469,8 +469,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) iszr=sum(rvsz) if (max(iszr,1) > lworkr) then call psb_realloc(max(iszr,1),workr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_realloc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -480,8 +480,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& & workr,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -492,8 +492,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) if (psb_is_large_desc(desc_ov)) then call psb_ensure_size(iszr,maskr,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -530,8 +530,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) proc_id = temp(i) call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -560,8 +560,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) n_col = n_col+1 proc_id = -desc_ov%idxmap%glob_to_loc(idx)-np-1 call psb_ensure_size(n_col,desc_ov%idxmap%loc_to_glob,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -570,8 +570,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%idxmap%loc_to_glob(n_col) = idx call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-1) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if @@ -643,8 +643,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) desc_ov%matrix_data(psb_n_row_) = desc_a%matrix_data(psb_n_row_) call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) call psb_ensure_size((counter_h+counter_t+1),tmp_halo,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if tmp_halo(counter_h:counter_h+counter_t-1) = t_halo_in(1:counter_t) @@ -652,8 +652,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%halo_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if @@ -669,8 +669,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! 5. n_col(ov) current. ! call psb_ensure_size((cntov_o+counter_o+1),orig_ovr,info,pad=-1) - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_ensure_size') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_ensure_size') goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) @@ -678,15 +678,15 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='deallocate') goto 9999 end if tmp_halo(counter_h:) = -1 call psb_move_alloc(tmp_halo,desc_ov%ext_index,info) call psb_move_alloc(t_halo_in,desc_ov%halo_index,info) case default - call psb_errpush(30,name,i_err=(/5,extype_,0,0,0/)) + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/5,extype_,0,0,0/)) goto 9999 end select @@ -703,18 +703,18 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) end if call psb_icdasb(desc_ov,info,ext_hv=.true.) - if (info /= 0) then - call psb_errpush(4010,name,a_err='icdasdb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb') goto 9999 end if call psb_cd_set_ovl_asb(desc_ov,info) - if (info == 0) then + if (info == psb_success_) then if (allocated(irow)) deallocate(irow,stat=info) - if ((info ==0).and.allocated(icol)) deallocate(icol,stat=info) - if (info /= 0) then - call psb_errpush(4013,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) + if ((info == psb_success_).and.allocated(icol)) deallocate(icol,stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='deallocate',i_err=(/info,0,0,0,0/)) goto 9999 end if end if diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index 2f2a7c52e..de5fcb156 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -53,11 +53,11 @@ subroutine psb_zfree(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_zfree' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) return end if @@ -67,13 +67,13 @@ subroutine psb_zfree(x, desc_a, info) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -81,7 +81,7 @@ subroutine psb_zfree(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -123,13 +123,13 @@ subroutine psb_zfreev(x, desc_a, info) if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name='psb_zfreev' if (.not.allocated(desc_a%matrix_data)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -137,14 +137,14 @@ subroutine psb_zfreev(x, desc_a, info) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.allocated(x)) then - info=295 + info=psb_err_forgot_spall_ call psb_errpush(info,name) goto 9999 end if @@ -152,7 +152,7 @@ subroutine psb_zfreev(x, desc_a, info) !deallocate x deallocate(x,stat=info) if (info /= psb_no_err_) then - info=4000 + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) endif diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index ab83f3020..047f756b4 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -72,7 +72,7 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_zinsvi' @@ -86,20 +86,20 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -111,14 +111,14 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) mglob = psb_cd_get_global_rows(desc_a) allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -253,7 +253,7 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_zinsi' @@ -267,20 +267,20 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl) call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif !... check parameters.... if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,int_err) goto 9999 else if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name,int_err) goto 9999 @@ -291,7 +291,7 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl) call psb_errpush(info,name,int_err) goto 9999 endif - if (m==0) return + if (m == 0) return loc_rows = psb_cd_get_local_rows(desc_a) loc_cols = psb_cd_get_local_cols(desc_a) @@ -306,8 +306,8 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl) endif allocate(irl(m),stat=info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif diff --git a/base/tools/psb_zspalloc.f90 b/base/tools/psb_zspalloc.f90 index 2edeb4007..ae5413b35 100644 --- a/base/tools/psb_zspalloc.f90 +++ b/base/tools/psb_zspalloc.f90 @@ -60,7 +60,7 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) name = 'psb_zspall' debug_unit = psb_get_debug_unit() @@ -72,7 +72,7 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif @@ -103,8 +103,8 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) !....allocate aspk, ia1, ia2..... call a%csall(loc_row,loc_col,info,nz=length_ia1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='sp_all' call psb_errpush(info,name,int_err) goto 9999 diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index 864089a2a..1ff4f76c2 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -69,7 +69,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) integer :: debug_level, debug_unit character(len=20) :: name, ch_err - info = 0 + info = psb_success_ int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) @@ -83,13 +83,13 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) ! check on BLACS grid call psb_info(ictxt, me, np) if (np == -1) then - info = 2010 + info = psb_err_blacs_error_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_asb_desc(desc_a)) then - info = 600 + info = psb_err_spmat_invalid_state_ int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name) goto 9999 @@ -123,7 +123,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) end IF if (info /= psb_no_err_) then - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_zspfree.f90 b/base/tools/psb_zspfree.f90 index 7f5f548ba..a3f2e94f6 100644 --- a/base/tools/psb_zspfree.f90 +++ b/base/tools/psb_zspfree.f90 @@ -52,12 +52,12 @@ subroutine psb_zspfree(a, desc_a,info) character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_zspfree' call psb_erractionsave(err_act) if (.not.allocated(desc_a%matrix_data)) then - info = 295 + info = psb_err_forgot_spall_ call psb_errpush(info,name) return else diff --git a/base/tools/psb_zsphalo.F90 b/base/tools/psb_zsphalo.F90 index cd316eb56..15f2b9657 100644 --- a/base/tools/psb_zsphalo.F90 +++ b/base/tools/psb_zsphalo.F90 @@ -91,7 +91,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name='psb_zsphalo' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -140,8 +140,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),& & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -159,7 +159,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! !$ idxv => desc_a%ovrlap_index ! Do not accept OVRLAP_INDEX any longer. case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') goto 9999 end select @@ -195,8 +195,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Enddo call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -224,8 +224,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -233,8 +233,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& mat_recv = iszr iszs=sum(sdsz) call psb_ensure_size(max(iszs,1),iasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),jasnd,info) - if (info == 0) call psb_ensure_size(max(iszs,1),valsnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) l1 = 0 ipx = 1 @@ -254,8 +254,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& n_elem = a%get_nz_row(idx) call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& & append=.true.,nzin=tot_elem) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_getrow' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -269,8 +269,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_loc_to_glob' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -283,8 +283,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& & acoo%ia,rvsz,brvindx,mpi_integer,icomm,info) call mpi_alltoallv(jasnd,sdsz,bsdindx,mpi_integer,& & acoo%ja,rvsz,brvindx,mpi_integer,icomm,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mpi_alltoallv' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -296,8 +296,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psbglob_to_loc' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -348,8 +348,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! Do we expect any duplicates to appear???? call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spcnv' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/base/tools/psb_zspins.f90 b/base/tools/psb_zspins.f90 index 262fb1cbf..e9e7695f6 100644 --- a/base/tools/psb_zspins.f90 +++ b/base/tools/psb_zspins.f90 @@ -69,7 +69,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_zspins' call psb_erractionsave(err_act) @@ -79,7 +79,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_a)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -105,7 +105,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (present(rebuild)) then rebuild_ = rebuild @@ -117,15 +117,15 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -133,14 +133,14 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -148,9 +148,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) else call psb_cdins(nz,ia,ja,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if nrow = psb_cd_get_local_rows(desc_a) @@ -158,14 +158,14 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (a%is_bld()) then call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if else - info = 1123 + info = psb_err_invalid_a_and_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -177,9 +177,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) if (psb_is_large_desc(desc_a)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -191,8 +191,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -203,15 +203,15 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) ncol = psb_cd_get_local_cols(desc_a) call a%csput(nz,ia,ja,val,1,nrow,1,ncol,& & info,gtl=desc_a%idxmap%glob_to_loc) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if @@ -250,7 +250,7 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) integer, allocatable :: ila(:),jla(:) character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'psb_zspins' call psb_erractionsave(err_act) @@ -260,12 +260,12 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_info(ictxt, me, np) if (.not.psb_is_ok_desc(desc_ar)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif if (.not.psb_is_ok_desc(desc_ac)) then - info = 3110 + info = psb_err_input_matrix_unassembled_ call psb_errpush(info,name) goto 9999 endif @@ -291,14 +291,14 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_errpush(info,name) goto 9999 end if - if (nz==0) return + if (nz == 0) return if (psb_is_bld_desc(desc_ac)) then allocate(ila(nz),jla(nz),stat=info) - if (info /= 0) then + if (info /= psb_success_) then ch_err='allocate' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if ila(1:nz) = ia(1:nz) @@ -307,9 +307,9 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) - if (info /= 0) then + if (info /= psb_success_) then ch_err='psb_cdins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) goto 9999 end if @@ -317,8 +317,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) ncol = psb_cd_get_local_cols(desc_ac) call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_coins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -330,9 +330,9 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ if (psb_is_large_desc(desc_a)) then !!$ !!$ allocate(ila(nz),jla(nz),stat=info) -!!$ if (info /= 0) then +!!$ if (info /= psb_success_) then !!$ ch_err='allocate' -!!$ call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) +!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) !!$ goto 9999 !!$ end if !!$ @@ -345,8 +345,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ !!$ call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,& !!$ & info,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 @@ -357,15 +357,15 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) !!$ ncol = psb_cd_get_local_cols(desc_a) !!$ call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,& !!$ & info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_) -!!$ if (info /= 0) then -!!$ info=4010 +!!$ if (info /= psb_success_) then +!!$ info=psb_err_from_subroutine_ !!$ ch_err='psb_coins' !!$ call psb_errpush(info,name,a_err=ch_err) !!$ goto 9999 !!$ end if !!$ end if else - info = 1122 + info = psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 end if diff --git a/base/tools/psb_zsprn.f90 b/base/tools/psb_zsprn.f90 index d78e66d3d..84c0860a2 100644 --- a/base/tools/psb_zsprn.f90 +++ b/base/tools/psb_zsprn.f90 @@ -59,7 +59,7 @@ Subroutine psb_zsprn(a, desc_a,info,clear) character(len=20) :: name logical :: clear_ - info = 0 + info = psb_success_ err = 0 int_err(1)=0 name = 'psb_zsprn' @@ -84,7 +84,7 @@ Subroutine psb_zsprn(a, desc_a,info,clear) call a%reinit(clear=clear) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': done' diff --git a/krylov/psb_cbicg.f90 b/krylov/psb_cbicg.f90 index e4d122e6d..27dba3b92 100644 --- a/krylov/psb_cbicg.f90 +++ b/krylov/psb_cbicg.f90 @@ -127,7 +127,7 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name,ch_err character(len=*), parameter :: methdname='BiCG' - info = 0 + info = psb_success_ name = 'psb_cbicg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -157,7 +157,7 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -165,14 +165,14 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -181,10 +181,10 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) naux=4*n_col allocate(aux(naux),stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=9) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ ch_err='psb_asb' err=info call psb_errpush(info,name,a_err=ch_err) @@ -217,8 +217,8 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -229,12 +229,12 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(cone,b,czero,r,desc_a,info) - if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),' Cone spmm',info - if (info == 0) call psb_geaxpby(cone,r,czero,rt,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -243,8 +243,8 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -256,18 +256,18 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx call prec%apply(r,z,desc_a,info,work=aux) - if (info == 0) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) + if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) rho_old = rho rho = psb_gedot(rt,z,desc_a,info) - if (rho==czero) then + if (rho == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(cone,z,czero,p,desc_a,info) call psb_geaxpby(cone,zt,czero,pt,desc_a,info) else @@ -282,7 +282,7 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & work=aux,trans='c') sigma = psb_gedot(pt,q,desc_a,info) - if (sigma==czero) then + if (sigma == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -297,8 +297,8 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_geaxpby(-(alpha),qt,cone,rt,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -312,8 +312,8 @@ subroutine psb_cbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end if deallocate(aux, stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_ccg.f90 b/krylov/psb_ccg.f90 index 223ef534a..6af51fba6 100644 --- a/krylov/psb_ccg.f90 +++ b/krylov/psb_ccg.f90 @@ -124,7 +124,7 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='CG' - info = 0 + info = psb_success_ name = 'psb_ccg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -146,19 +146,19 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col allocate(aux(naux), stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=5) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -195,9 +195,9 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) it = 0 call psb_geaxpby(cone,b,czero,r,desc_a,info) - if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -205,8 +205,8 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho = czero call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -219,10 +219,10 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(r,z,desc_a,info) - if (it==1) then + if (it == 1) then call psb_geaxpby(cone,z,czero,p,desc_a,info) else - if (rho_old==czero) then + if (rho_old == czero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown rho' @@ -234,7 +234,7 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_spmm(cone,a,p,czero,q,desc_a,info,work=aux) sigma = psb_gedot(p,q,desc_a,info) - if (sigma==czero) then + if (sigma == czero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown sigma' @@ -246,8 +246,8 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_geaxpby(-alpha,q,cone,r,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -261,7 +261,7 @@ subroutine psb_ccg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end if call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_ccgs.f90 b/krylov/psb_ccgs.f90 index d7ea0253f..25890d8b9 100644 --- a/krylov/psb_ccgs.f90 +++ b/krylov/psb_ccgs.f90 @@ -123,7 +123,7 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='CGS' - info = 0 + info = psb_success_ name = 'psb_ccgs' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -145,19 +145,19 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col Allocate(aux(naux),stat=info) - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info /= 0) Then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -193,8 +193,8 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) itx = 0 call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -205,10 +205,10 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(cone,b,czero,r,desc_a,info) - if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(cone,r,czero,rt,desc_a,info) - if (info/=0) then - info=4011 + if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -216,8 +216,8 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -232,36 +232,36 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(rt,r,desc_a,info) - if (rho==czero) then + if (rho == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(cone,r,czero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(cone,r,czero,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,r,czero,p,desc_a,info) else beta = (rho/rho_old) call psb_geaxpby(cone,r,czero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(beta,q,cone,uv,desc_a,info) - if (info == 0) call psb_geaxpby(cone,q,beta,p,desc_a,info) - if (info == 0) call psb_geaxpby(cone,uv,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(beta,q,cone,uv,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,q,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,uv,beta,p,desc_a,info) end if - if (info == 0) call prec%apply(p,f,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) - if (info == 0) call psb_spmm(cone,a,f,czero,v,desc_a,info,& + if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info,& & work=aux) - if (info /= 0) then - call psb_errpush(4010,name,a_err='First loop part ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') goto 9999 end if sigma = psb_gedot(rt,v,desc_a,info) - if (sigma==czero) then + if (sigma == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -270,28 +270,28 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma - if (info == 0) call psb_geaxpby(cone,uv,czero,q,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,cone,q,desc_a,info) - if (info == 0) call psb_geaxpby(cone,uv,czero,s,desc_a,info) - if (info == 0) call psb_geaxpby(cone,q,cone,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,uv,czero,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,v,cone,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,uv,czero,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,q,cone,s,desc_a,info) - if (info == 0) call prec%apply(s,z,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(alpha,z,cone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(alpha,z,cone,x,desc_a,info) - if (info == 0) call psb_spmm(cone,a,z,czero,qt,desc_a,info,& + if (info == psb_success_) call psb_spmm(cone,a,z,czero,qt,desc_a,info,& & work=aux) - if (info == 0) call psb_geaxpby(-alpha,qt,cone,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,qt,cone,r,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='X update ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') goto 9999 end if if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -306,8 +306,8 @@ Subroutine psb_ccgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end if deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_ccgstab.f90 b/krylov/psb_ccgstab.f90 index 7ac3b3fea..3e7dc9015 100644 --- a/krylov/psb_ccgstab.f90 +++ b/krylov/psb_ccgstab.f90 @@ -126,7 +126,7 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab' - info = 0 + info = psb_success_ name = 'psb_ccgstab' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -147,24 +147,24 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if naux=6*n_col allocate(aux(naux),stat=info) - if (info==0) call psb_geall(wwrk,desc_a,info,n=8) - if (info==0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -197,8 +197,8 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -210,10 +210,10 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(cone,b,czero,r,desc_a,info) - if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(cone,r,czero,q,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_geaxpby(cone,r,czero,q,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -226,8 +226,8 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -241,33 +241,33 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(q,r,desc_a,info) - if (rho==czero) then + if (rho == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown R',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(cone,r,czero,p,desc_a,info) else beta = (rho/rho_old)*(alpha/omega) call psb_geaxpby(-omega,v,cone,p,desc_a,info) - if (info == 0) call psb_geaxpby(cone,r,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,r,beta,p,desc_a,info) end if - if (info == 0) call prec%apply(p,f,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) - if (info == 0) call psb_spmm(cone,a,f,czero,v,desc_a,info,& + if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info,& & work=aux) - if (info == 0) sigma = psb_gedot(q,v,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='First step') + if (info == psb_success_) sigma = psb_gedot(q,v,desc_a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='First step') goto 9999 end if - if (sigma==czero) then + if (sigma == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S1', sigma @@ -280,18 +280,18 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma call psb_geaxpby(cone,r,czero,s,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,cone,s,desc_a,info) - if (info == 0) call prec%apply(s,z,desc_a,info,work=aux) - if (info == 0) call psb_spmm(cone,a,z,czero,t,desc_a,info,& + if (info == psb_success_) call psb_geaxpby(-alpha,v,cone,s,desc_a,info) + if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(cone,a,z,czero,t,desc_a,info,& & work=aux) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Second step ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Second step ') goto 9999 end if sigma = psb_gedot(t,t,desc_a,info) - if (sigma==czero) then + if (sigma == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S2', sigma @@ -301,26 +301,26 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) tau = psb_gedot(t,s,desc_a,info) omega = tau/sigma - if (omega==czero) then + if (omega == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown O',omega exit iteration endif - if (info == 0) call psb_geaxpby(alpha,f,cone,x,desc_a,info) - if (info == 0) call psb_geaxpby(omega,z,cone,x,desc_a,info) - if (info == 0) call psb_geaxpby(cone,s,czero,r,desc_a,info) - if (info == 0) call psb_geaxpby(-omega,t,cone,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(alpha,f,cone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(omega,z,cone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,s,czero,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-omega,t,cone,r,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='X update ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') goto 9999 end if if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -334,8 +334,8 @@ subroutine psb_ccgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end if deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_ccgstabl.f90 b/krylov/psb_ccgstabl.f90 index 9e5400b16..3fe024e7f 100644 --- a/krylov/psb_ccgstabl.f90 +++ b/krylov/psb_ccgstabl.f90 @@ -138,7 +138,7 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab(L)' - info = 0 + info = psb_success_ name = 'psb_ccgstabl' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -184,7 +184,7 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -192,9 +192,9 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if @@ -203,19 +203,19 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is allocate(aux(naux),gamma(0:nl),gamma1(nl),& &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10) - if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info == 0) Call psb_geasb(uh,desc_a,info) - if (info == 0) Call psb_geasb(rh,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) + if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info == psb_success_) Call psb_geasb(uh,desc_a,info) + if (info == psb_success_) Call psb_geasb(rh,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -236,8 +236,8 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -252,15 +252,15 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is it = 0 call psb_geaxpby(cone,b,czero,r,desc_a,info) - if (info == 0) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux) - if (info == 0) call prec%apply(r,desc_a,info) + if (info == psb_success_) call prec%apply(r,desc_a,info) - if (info == 0) call psb_geaxpby(cone,r,czero,rt0,desc_a,info) - if (info == 0) call psb_geaxpby(cone,r,czero,rh(:,0),desc_a,info) - if (info == 0) call psb_geaxpby(czero,r,czero,uh(:,0),desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt0,desc_a,info) + if (info == psb_success_) call psb_geaxpby(cone,r,czero,rh(:,0),desc_a,info) + if (info == psb_success_) call psb_geaxpby(czero,r,czero,uh(:,0),desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -274,8 +274,8 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' on entry to amax: b: ',Size(b) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -294,7 +294,7 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is rho_old = rho rho = psb_gedot(rh(:,j),rt0,desc_a,info) - if (rho==czero) then + if (rho == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown r',rho @@ -310,7 +310,7 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) - if (gamma(j)==czero) then + if (gamma(j) == czero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown s2',gamma(j) @@ -372,8 +372,8 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is enddo if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -387,10 +387,10 @@ Subroutine psb_ccgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is end if deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info == 0) call psb_gefree(uh,desc_a,info) - if (info == 0) call psb_gefree(rh,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info == psb_success_) call psb_gefree(uh,desc_a,info) + if (info == psb_success_) call psb_gefree(rh,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_crgmres.f90 b/krylov/psb_crgmres.f90 index d73bbf760..43e03f167 100644 --- a/krylov/psb_crgmres.f90 +++ b/krylov/psb_crgmres.f90 @@ -138,7 +138,7 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist character(len=20) :: name character(len=*), parameter :: methdname='RGMRES' - info = 0 + info = psb_success_ name = 'psb_cgmres' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -164,7 +164,7 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -195,7 +195,7 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -203,14 +203,14 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -220,16 +220,16 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist allocate(aux(naux),h(nl+1,nl+1),& &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) - if (info == 0) Call psb_geall(v,desc_a,info,n=nl+1) - if (info == 0) Call psb_geall(w,desc_a,info) - if (info == 0) Call psb_geall(w1,desc_a,info) - if (info == 0) Call psb_geall(xt,desc_a,info) - if (info == 0) Call psb_geasb(v,desc_a,info) - if (info == 0) Call psb_geasb(w,desc_a,info) - if (info == 0) Call psb_geasb(w1,desc_a,info) - if (info == 0) Call psb_geasb(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) Call psb_geall(v,desc_a,info,n=nl+1) + if (info == psb_success_) Call psb_geall(w,desc_a,info) + if (info == psb_success_) Call psb_geall(w1,desc_a,info) + if (info == psb_success_) Call psb_geall(xt,desc_a,info) + if (info == psb_success_) Call psb_geasb(v,desc_a,info) + if (info == psb_success_) Call psb_geasb(w,desc_a,info) + if (info == psb_success_) Call psb_geasb(w1,desc_a,info) + if (info == psb_success_) Call psb_geasb(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -250,12 +250,12 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist errnum = dzero errden = done deps = eps - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if - if ((itrace_ > 0).and.(me==0)) call log_header(methdname) + if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) itx = 0 restart: do @@ -269,23 +269,23 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' restart: ',itx,it it = 0 call psb_geaxpby(cone,b,czero,v(:,1),desc_a,info) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if call psb_spmm(-cone,a,x,cone,v(:,1),desc_a,info,work=aux) - if (info /= 0) Then - info=4011 + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If rs(1) = psb_genrm2(v(:,1),desc_a,info) rs(2:) = czero - if (info /= 0) Then - info=4011 + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -308,8 +308,8 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist errnum = rni errden = bn2 endif - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -445,12 +445,12 @@ Subroutine psb_crgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist deallocate(aux,h,c,s,rs,rst, stat=info) - if (info == 0) call psb_gefree(v,desc_a,info) - if (info == 0) call psb_gefree(w,desc_a,info) - if (info == 0) call psb_gefree(w1,desc_a,info) - if (info == 0) call psb_gefree(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_gefree(v,desc_a,info) + if (info == psb_success_) call psb_gefree(w,desc_a,info) + if (info == psb_success_) call psb_gefree(w1,desc_a,info) + if (info == psb_success_) call psb_gefree(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -489,13 +489,13 @@ contains ! .. ! ! purpose - ! ======= + ! == = ==== ! ! zrot applies a plane rotation, where the cos (c) is real and the ! sin (s) is complex, and the vectors cx and cy are complex. ! ! arguments - ! ========= + ! == = ====== ! ! n (input) integer ! the number of elements in the vectors cx and cy. @@ -521,7 +521,7 @@ contains ! [ -conjg(s) c ] ! where c*c + s*conjg(s) = 1.0. ! - ! ===================================================================== + ! == = ================================================================== ! ! .. local scalars .. integer i, ix, iy diff --git a/krylov/psb_dbicg.f90 b/krylov/psb_dbicg.f90 index 8907ee8e7..3d0e214b2 100644 --- a/krylov/psb_dbicg.f90 +++ b/krylov/psb_dbicg.f90 @@ -126,7 +126,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name,ch_err character(len=*), parameter :: methdname='BiCG' - info = 0 + info = psb_success_ name = 'psb_dbicg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -156,7 +156,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -164,14 +164,14 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -180,10 +180,10 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) naux=4*n_col allocate(aux(naux),stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=9) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ ch_err='psb_asb' err=info call psb_errpush(info,name,a_err=ch_err) @@ -216,8 +216,8 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -228,12 +228,12 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(done,b,dzero,r,desc_a,info) - if (info == 0) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),' Done spmm',info - if (info == 0) call psb_geaxpby(done,r,dzero,rt,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -242,8 +242,8 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -255,18 +255,18 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx call prec%apply(r,z,desc_a,info,work=aux) - if (info == 0) call prec%apply(rt,zt,desc_a,info,trans='t',work=aux) + if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='t',work=aux) rho_old = rho rho = psb_gedot(rt,z,desc_a,info) - if (rho==dzero) then + if (rho == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(done,z,dzero,p,desc_a,info) call psb_geaxpby(done,zt,dzero,pt,desc_a,info) else @@ -281,7 +281,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & work=aux,trans='t') sigma = psb_gedot(pt,q,desc_a,info) - if (sigma==dzero) then + if (sigma == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -296,8 +296,8 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_geaxpby(-alpha,qt,done,rt,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -307,8 +307,8 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux, stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_dcg.F90 b/krylov/psb_dcg.F90 index 6b316b27f..3992ab40b 100644 --- a/krylov/psb_dcg.F90 +++ b/krylov/psb_dcg.F90 @@ -126,7 +126,7 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) character(len=20) :: name character(len=*), parameter :: methdname='CG' - info = 0 + info = psb_success_ name = 'psb_dcg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -149,19 +149,19 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col allocate(aux(naux), stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=5) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -191,8 +191,8 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) allocate(td(itmax_),tu(itmax_), eig(itmax_),& & ibl(itmax_),ispl(itmax_),iwrk(3*itmax_),ewrk(4*itmax_),& & stat=info) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -211,9 +211,9 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) it = 0 call psb_geaxpby(done,b,dzero,r,desc_a,info) - if (info == 0) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -221,8 +221,8 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) rho = dzero call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -235,10 +235,10 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) rho_old = rho rho = psb_gedot(r,z,desc_a,info) - if (it==1) then + if (it == 1) then call psb_geaxpby(done,z,dzero,p,desc_a,info) else - if (rho_old==dzero) then + if (rho_old == dzero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown rho' @@ -250,7 +250,7 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) call psb_spmm(done,a,p,dzero,q,desc_a,info,work=aux) sigma = psb_gedot(p,q,desc_a,info) - if (sigma==dzero) then + if (sigma == dzero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown sigma' @@ -272,8 +272,8 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) call psb_geaxpby(-alpha,q,done,r,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -281,27 +281,27 @@ subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) end do restart if (do_cond) then - if (me==0) then + if (me == 0) then #if defined(HAVE_LAPACK) call dstebz('A','E',istebz,dzero,dzero,0,0,-done,td,tu,& & ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info) if (info < 0) then - call psb_errpush(4013,name,a_err='dstebz',i_err=(/info,0,0,0,0/)) - info = 4013 + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='dstebz',i_err=(/info,0,0,0,0/)) + info = psb_err_from_subroutine_ai_ goto 9999 end if cond = eig(ieg)/eig(1) #else cond = -1.0 #endif - info = 0 + info = psb_success_ end if call psb_bcast(ictxt,cond,root=0) end if call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_dcgs.f90 b/krylov/psb_dcgs.f90 index 6a5b77c3b..34481edba 100644 --- a/krylov/psb_dcgs.f90 +++ b/krylov/psb_dcgs.f90 @@ -124,7 +124,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='CGS' - info = 0 + info = psb_success_ name = 'psb_dcgs' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -146,19 +146,19 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col Allocate(aux(naux),stat=info) - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info /= 0) Then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -194,8 +194,8 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) itx = 0 call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -206,10 +206,10 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(done,b,dzero,r,desc_a,info) - if (info == 0) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(done,r,dzero,rt,desc_a,info) - if (info/=0) then - info=4011 + if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -217,8 +217,8 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -233,36 +233,36 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(rt,r,desc_a,info) - if (rho==dzero) then + if (rho == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(done,r,dzero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(done,r,dzero,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,r,dzero,p,desc_a,info) else beta = (rho/rho_old) call psb_geaxpby(done,r,dzero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(beta,q,done,uv,desc_a,info) - if (info == 0) call psb_geaxpby(done,q,beta,p,desc_a,info) - if (info == 0) call psb_geaxpby(done,uv,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(beta,q,done,uv,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,q,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,uv,beta,p,desc_a,info) end if - if (info == 0) call prec%apply(p,f,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) - if (info == 0) call psb_spmm(done,a,f,dzero,v,desc_a,info,& + if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info,& & work=aux) - if (info /= 0) then - call psb_errpush(4010,name,a_err='First loop part ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') goto 9999 end if sigma = psb_gedot(rt,v,desc_a,info) - if (sigma==dzero) then + if (sigma == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -271,28 +271,28 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma - if (info == 0) call psb_geaxpby(done,uv,dzero,q,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,done,q,desc_a,info) - if (info == 0) call psb_geaxpby(done,uv,dzero,s,desc_a,info) - if (info == 0) call psb_geaxpby(done,q,done,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,uv,dzero,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,v,done,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,uv,dzero,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,q,done,s,desc_a,info) - if (info == 0) call prec%apply(s,z,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(alpha,z,done,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(alpha,z,done,x,desc_a,info) - if (info == 0) call psb_spmm(done,a,z,dzero,qt,desc_a,info,& + if (info == psb_success_) call psb_spmm(done,a,z,dzero,qt,desc_a,info,& & work=aux) - if (info == 0) call psb_geaxpby(-alpha,qt,done,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,qt,done,r,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='X update ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') goto 9999 end if if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -302,8 +302,8 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_dcgstab.F90 b/krylov/psb_dcgstab.F90 index 8a2969c4e..f7352a12b 100644 --- a/krylov/psb_dcgstab.F90 +++ b/krylov/psb_dcgstab.F90 @@ -132,7 +132,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab' - info = 0 + info = psb_success_ name = 'psb_dcgstab' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -151,7 +151,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ifcte = mpe_log_get_event_number() immb = mpe_log_get_event_number() imme = mpe_log_get_event_number() - if (irank==0) then + if (irank == 0) then info = mpe_describe_state(istpb,istpe,"Solver","WhiteSmoke") info = mpe_describe_state(ifctb,ifcte,"PREC","SteelBlue") info = mpe_describe_state(immb,imme,"SPMM","DarkOrange") @@ -178,24 +178,24 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if naux=6*n_col allocate(aux(naux),stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=8) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -226,8 +226,8 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) itx = 0 call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -240,21 +240,21 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) #ifdef MPE_KRYLOV imerr = MPE_Log_event( immb, 0, "st SPMM" ) #endif - if (info == 0) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) #ifdef MPE_KRYLOV imerr = MPE_Log_event( imme, 0, "ed SPMM" ) #endif - if (info == 0) call psb_geaxpby(done,r,dzero,q,desc_a,info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_geaxpby(done,r,dzero,q,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Init residual') goto 9999 end if ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -271,14 +271,14 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(q,r,desc_a,info) - if (rho==dzero) then + if (rho == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown R',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(done,r,dzero,p,desc_a,info) else beta = (rho/rho_old)*(alpha/omega) @@ -301,7 +301,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) #endif sigma = psb_gedot(q,v,desc_a,info) - if (sigma==dzero) then + if (sigma == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S1', sigma @@ -310,10 +310,10 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma call psb_geaxpby(done,r,dzero,s,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,done,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,v,done,s,desc_a,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psb_geaxpby') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_geaxpby') goto 9999 end if @@ -326,19 +326,19 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) imerr = MPE_Log_event( ifcte, 0, "ed PREC" ) imerr = MPE_Log_event( immb, 0, "st SPMM" ) #endif - if (info == 0) Call psb_spmm(done,a,z,dzero,t,desc_a,info,& + if (info == psb_success_) Call psb_spmm(done,a,z,dzero,t,desc_a,info,& & work=aux) #ifdef MPE_KRYLOV imerr = MPE_Log_event( imme, 0, "ed SPMM" ) #endif - if(info /= 0) then - call psb_errpush(4010,name,a_err='precaply/spmm') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm') goto 9999 end if sigma = psb_gedot(t,t,desc_a,info) - if (sigma==dzero) then + if (sigma == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S2', sigma @@ -348,7 +348,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) tau = psb_gedot(t,s,desc_a,info) omega = tau/sigma - if (omega==dzero) then + if (omega == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown O',omega @@ -356,17 +356,17 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_geaxpby(alpha,f,done,x,desc_a,info) - if (info == 0) call psb_geaxpby(omega,z,done,x,desc_a,info) - if (info == 0) call psb_geaxpby(done,s,dzero,r,desc_a,info) - if (info == 0) call psb_geaxpby(-omega,t,done,r,desc_a,info) - if (info /= 0) Then - call psb_errpush(4010,name,a_err='X/R update ') + if (info == psb_success_) call psb_geaxpby(omega,z,done,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,s,dzero,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-omega,t,done,r,desc_a,info) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ') goto 9999 End If if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -376,8 +376,8 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if(info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_dcgstabl.f90 b/krylov/psb_dcgstabl.f90 index ff266b8d6..4d5acbbe4 100644 --- a/krylov/psb_dcgstabl.f90 +++ b/krylov/psb_dcgstabl.f90 @@ -137,7 +137,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab(L)' - info = 0 + info = psb_success_ name = 'psb_dcgstabl' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -183,7 +183,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -191,9 +191,9 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if @@ -202,19 +202,19 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is allocate(aux(naux),gamma(0:nl),gamma1(nl),& &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10) - if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info == 0) Call psb_geasb(uh,desc_a,info) - if (info == 0) Call psb_geasb(rh,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) + if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info == psb_success_) Call psb_geasb(uh,desc_a,info) + if (info == psb_success_) Call psb_geasb(rh,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -235,8 +235,8 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -251,15 +251,15 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is it = 0 call psb_geaxpby(done,b,dzero,r,desc_a,info) - if (info == 0) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux) - if (info == 0) call prec%apply(r,desc_a,info) + if (info == psb_success_) call prec%apply(r,desc_a,info) - if (info == 0) call psb_geaxpby(done,r,dzero,rt0,desc_a,info) - if (info == 0) call psb_geaxpby(done,r,dzero,rh(:,0),desc_a,info) - if (info == 0) call psb_geaxpby(dzero,r,dzero,uh(:,0),desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt0,desc_a,info) + if (info == psb_success_) call psb_geaxpby(done,r,dzero,rh(:,0),desc_a,info) + if (info == psb_success_) call psb_geaxpby(dzero,r,dzero,uh(:,0),desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -273,8 +273,8 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' on entry to amax: b: ',Size(b) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -293,7 +293,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is rho_old = rho rho = psb_gedot(rh(:,j),rt0,desc_a,info) - if (rho==dzero) then + if (rho == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown r',rho @@ -309,7 +309,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) - if (gamma(j)==dzero) then + if (gamma(j) == dzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown s2',gamma(j) @@ -371,8 +371,8 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is enddo if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -382,10 +382,10 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info == 0) call psb_gefree(uh,desc_a,info) - if (info == 0) call psb_gefree(rh,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info == psb_success_) call psb_gefree(uh,desc_a,info) + if (info == psb_success_) call psb_gefree(rh,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_drgmres.f90 b/krylov/psb_drgmres.f90 index 10ec1f768..5ae68ae44 100644 --- a/krylov/psb_drgmres.f90 +++ b/krylov/psb_drgmres.f90 @@ -139,7 +139,7 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist character(len=20) :: name character(len=*), parameter :: methdname='RGMRES' - info = 0 + info = psb_success_ name = 'psb_dgmres' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -165,7 +165,7 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -196,7 +196,7 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -204,14 +204,14 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -221,16 +221,16 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist allocate(aux(naux),h(nl+1,nl+1),& &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) - if (info == 0) call psb_geall(v,desc_a,info,n=nl+1) - if (info == 0) call psb_geall(w,desc_a,info) - if (info == 0) call psb_geall(w1,desc_a,info) - if (info == 0) call psb_geall(xt,desc_a,info) - if (info == 0) call psb_geasb(v,desc_a,info) - if (info == 0) call psb_geasb(w,desc_a,info) - if (info == 0) call psb_geasb(w1,desc_a,info) - if (info == 0) call psb_geasb(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(v,desc_a,info,n=nl+1) + if (info == psb_success_) call psb_geall(w,desc_a,info) + if (info == psb_success_) call psb_geall(w1,desc_a,info) + if (info == psb_success_) call psb_geall(xt,desc_a,info) + if (info == psb_success_) call psb_geasb(v,desc_a,info) + if (info == psb_success_) call psb_geasb(w,desc_a,info) + if (info == psb_success_) call psb_geasb(w1,desc_a,info) + if (info == psb_success_) call psb_geasb(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -250,12 +250,12 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist endif errnum = dzero errden = done - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if - if ((itrace_ > 0).and.(me==0)) call log_header(methdname) + if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) itx = 0 restart: do @@ -269,23 +269,23 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' restart: ',itx,it it = 0 call psb_geaxpby(done,b,dzero,v(:,1),desc_a,info) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if call psb_spmm(-done,a,x,done,v(:,1),desc_a,info,work=aux) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if rs(1) = psb_genrm2(v(:,1),desc_a,info) rs(2:) = dzero - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -308,8 +308,8 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist errnum = rni errden = bn2 endif - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -439,12 +439,12 @@ subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist call log_end(methdname,me,itx,errnum,errden,eps,err=err,iter=iter) deallocate(aux,h,c,s,rs,rst, stat=info) - if (info == 0) call psb_gefree(v,desc_a,info) - if (info == 0) call psb_gefree(w,desc_a,info) - if (info == 0) call psb_gefree(w1,desc_a,info) - if (info == 0) call psb_gefree(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_gefree(v,desc_a,info) + if (info == psb_success_) call psb_gefree(w,desc_a,info) + if (info == psb_success_) call psb_gefree(w1,desc_a,info) + if (info == psb_success_) call psb_gefree(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_krylov_mod.f90 b/krylov/psb_krylov_mod.f90 index 35582de6a..432509906 100644 --- a/krylov/psb_krylov_mod.f90 +++ b/krylov/psb_krylov_mod.f90 @@ -512,7 +512,7 @@ contains integer :: ictxt,me,np,err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) @@ -541,13 +541,13 @@ contains call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) case default - if (me==0) write(0,*) trim(name),': Warning: Unknown method ',method,& + if (me == 0) write(0,*) trim(name),': Warning: Unknown method ',method,& & ', defaulting to BiCGSTAB' call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) end select - if(info/=0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -630,7 +630,7 @@ contains integer :: ictxt,me,np,err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) @@ -659,13 +659,13 @@ contains call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) case default - if (me==0) write(0,*) trim(name),': Warning: Unknown method ',method,& + if (me == 0) write(0,*) trim(name),': Warning: Unknown method ',method,& & ', defaulting to BiCGSTAB' call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) end select - if(info/=0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -746,7 +746,7 @@ contains integer :: ictxt,me,np,err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) @@ -776,13 +776,13 @@ contains call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) case default - if (me==0) write(0,*) trim(name),': Warning: Unknown method ',method,& + if (me == 0) write(0,*) trim(name),': Warning: Unknown method ',method,& & ', defaulting to BiCGSTAB' call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) end select - if(info/=0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -862,7 +862,7 @@ contains integer :: ictxt,me,np,err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_krylov' call psb_erractionsave(err_act) @@ -892,13 +892,13 @@ contains call psb_bicgstabl(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,irst,istop) case default - if (me==0) write(0,*) trim(name),': Warning: Unknown method ',method,& + if (me == 0) write(0,*) trim(name),': Warning: Unknown method ',method,& & ', defaulting to BiCGSTAB' call psb_bicgstab(a,prec,b,x,eps,desc_a,info,& &itmax,iter,err,itrace,istop) end select - if(info/=0) then + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -942,7 +942,7 @@ contains character(len=len(methdname)) :: mname character(len=outlen) :: outname - if ((mod(itx,itrace) == 0).and.(me==0)) then + if ((mod(itx,itrace) == 0).and.(me == 0)) then mname = adjustl(trim(methdname)) write(outname,'(a)') mname(1:min(len_trim(mname),outlen-1))//':' if (errden > dzero ) then @@ -968,7 +968,7 @@ contains if (errden == dzero) then if (errnum > eps) then - if (me==0) then + if (me == 0) then write(*,fmt) trim(methdname)//' failed to converge to ',eps,& & ' in ',it,' iterations. ' write(*,fmt1) 'Last iteration error estimate: ',& @@ -978,7 +978,7 @@ contains if (present(err)) err=errnum else if (errnum/errden > eps) then - if (me==0) then + if (me == 0) then write(*,fmt) trim(methdname)//' failed to converge to ',eps,& & ' in ',it,' iterations. ' write(*,fmt1) 'Last iteration error estimate: ',& @@ -1005,7 +1005,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_init_conv' call psb_erractionsave(err_act) @@ -1024,18 +1024,18 @@ contains select case(stopdat%controls(stopc_)) case (1) stopdat%values(ani_) = psb_spnrmi(a,desc_a,info) - if (info == 0) stopdat%values(bni_) = psb_geamax(b,desc_a,info) + if (info == psb_success_) stopdat%values(bni_) = psb_geamax(b,desc_a,info) case (2) stopdat%values(bn2_) = psb_genrm2(b,desc_a,info) case default - info=5001 + info=psb_err_invalid_istop_ call psb_errpush(info,name,i_err=(/stopc,0,0,0,0/)) goto 9999 end select - if (info /= 0) then - call psb_errpush(4001,name,a_err="Init conv check data") + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err="Init conv check data") goto 9999 end if @@ -1072,7 +1072,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_init_conv' call psb_erractionsave(err_act) @@ -1091,18 +1091,18 @@ contains select case(stopdat%controls(stopc_)) case (1) stopdat%values(ani_) = psb_spnrmi(a,desc_a,info) - if (info == 0) stopdat%values(bni_) = psb_geamax(b,desc_a,info) + if (info == psb_success_) stopdat%values(bni_) = psb_geamax(b,desc_a,info) case (2) stopdat%values(bn2_) = psb_genrm2(b,desc_a,info) case default - info=5001 + info=psb_err_invalid_istop_ call psb_errpush(info,name,i_err=(/stopc,0,0,0,0/)) goto 9999 end select - if (info /= 0) then - call psb_errpush(4001,name,a_err="Init conv check data") + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err="Init conv check data") goto 9999 end if @@ -1140,7 +1140,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_init_conv' call psb_erractionsave(err_act) @@ -1159,18 +1159,18 @@ contains select case(stopdat%controls(stopc_)) case (1) stopdat%values(ani_) = psb_spnrmi(a,desc_a,info) - if (info == 0) stopdat%values(bni_) = psb_geamax(b,desc_a,info) + if (info == psb_success_) stopdat%values(bni_) = psb_geamax(b,desc_a,info) case (2) stopdat%values(bn2_) = psb_genrm2(b,desc_a,info) case default - info=5001 + info=psb_err_invalid_istop_ call psb_errpush(info,name,i_err=(/stopc,0,0,0,0/)) goto 9999 end select - if (info /= 0) then - call psb_errpush(4001,name,a_err="Init conv check data") + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err="Init conv check data") goto 9999 end if @@ -1208,7 +1208,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_init_conv' call psb_erractionsave(err_act) @@ -1227,18 +1227,18 @@ contains select case(stopdat%controls(stopc_)) case (1) stopdat%values(ani_) = psb_spnrmi(a,desc_a,info) - if (info == 0) stopdat%values(bni_) = psb_geamax(b,desc_a,info) + if (info == psb_success_) stopdat%values(bni_) = psb_geamax(b,desc_a,info) case (2) stopdat%values(bn2_) = psb_genrm2(b,desc_a,info) case default - info=5001 + info=psb_err_invalid_istop_ call psb_errpush(info,name,i_err=(/stopc,0,0,0,0/)) goto 9999 end select - if (info /= 0) then - call psb_errpush(4001,name,a_err="Init conv check data") + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err="Init conv check data") goto 9999 end if @@ -1276,7 +1276,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) @@ -1288,7 +1288,7 @@ contains select case(stopdat%controls(stopc_)) case(1) stopdat%values(rni_) = psb_geamax(r,desc_a,info) - if (info == 0) stopdat%values(xni_) = psb_geamax(x,desc_a,info) + if (info == psb_success_) stopdat%values(xni_) = psb_geamax(x,desc_a,info) stopdat%values(errnum_) = stopdat%values(rni_) stopdat%values(errden_) = & & (stopdat%values(ani_)*stopdat%values(xni_)+stopdat%values(bni_)) @@ -1298,12 +1298,12 @@ contains stopdat%values(errden_) = stopdat%values(bn2_) case default - info=4001 + info=psb_err_internal_error_ call psb_errpush(info,name,a_err="Control data in stopdat messed up!") goto 9999 end select - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -1318,7 +1318,7 @@ contains psb_s_check_conv = (psb_s_check_conv.or.(stopdat%controls(itmax_) <= it)) if ( (stopdat%controls(trace_) > 0).and.& - & ((mod(it,stopdat%controls(trace_))==0).or.psb_s_check_conv)) then + & ((mod(it,stopdat%controls(trace_)) == 0).or.psb_s_check_conv)) then call log_conv(methdname,me,it,1,stopdat%values(errnum_),& & stopdat%values(errden_),stopdat%values(eps_)) end if @@ -1349,7 +1349,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) @@ -1361,7 +1361,7 @@ contains select case(stopdat%controls(stopc_)) case(1) stopdat%values(rni_) = psb_geamax(r,desc_a,info) - if (info == 0) stopdat%values(xni_) = psb_geamax(x,desc_a,info) + if (info == psb_success_) stopdat%values(xni_) = psb_geamax(x,desc_a,info) stopdat%values(errnum_) = stopdat%values(rni_) stopdat%values(errden_) = & & (stopdat%values(ani_)*stopdat%values(xni_)+stopdat%values(bni_)) @@ -1371,12 +1371,12 @@ contains stopdat%values(errden_) = stopdat%values(bn2_) case default - info=4001 + info=psb_err_internal_error_ call psb_errpush(info,name,a_err="Control data in stopdat messed up!") goto 9999 end select - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -1391,7 +1391,7 @@ contains psb_d_check_conv = (psb_d_check_conv.or.(stopdat%controls(itmax_) <= it)) if ( (stopdat%controls(trace_) > 0).and.& - & ((mod(it,stopdat%controls(trace_))==0).or.psb_d_check_conv)) then + & ((mod(it,stopdat%controls(trace_)) == 0).or.psb_d_check_conv)) then call log_conv(methdname,me,it,1,stopdat%values(errnum_),& & stopdat%values(errden_),stopdat%values(eps_)) end if @@ -1423,7 +1423,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) @@ -1434,7 +1434,7 @@ contains select case(stopdat%controls(stopc_)) case(1) stopdat%values(rni_) = psb_geamax(r,desc_a,info) - if (info == 0) stopdat%values(xni_) = psb_geamax(x,desc_a,info) + if (info == psb_success_) stopdat%values(xni_) = psb_geamax(x,desc_a,info) stopdat%values(errnum_) = stopdat%values(rni_) stopdat%values(errden_) = & & (stopdat%values(ani_)*stopdat%values(xni_)+stopdat%values(bni_)) @@ -1444,12 +1444,12 @@ contains stopdat%values(errden_) = stopdat%values(bn2_) case default - info=4001 + info=psb_err_internal_error_ call psb_errpush(info,name,a_err="Control data in stopdat messed up!") goto 9999 end select - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -1464,7 +1464,7 @@ contains psb_c_check_conv = (psb_c_check_conv.or.(stopdat%controls(itmax_) <= it)) if ( (stopdat%controls(trace_) > 0).and.& - & ((mod(it,stopdat%controls(trace_))==0).or.psb_c_check_conv)) then + & ((mod(it,stopdat%controls(trace_)) == 0).or.psb_c_check_conv)) then call log_conv(methdname,me,it,1,stopdat%values(errnum_),& & stopdat%values(errden_),stopdat%values(eps_)) end if @@ -1495,7 +1495,7 @@ contains integer :: ictxt, me, np, err_act character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_check_conv' call psb_erractionsave(err_act) @@ -1506,7 +1506,7 @@ contains select case(stopdat%controls(stopc_)) case(1) stopdat%values(rni_) = psb_geamax(r,desc_a,info) - if (info == 0) stopdat%values(xni_) = psb_geamax(x,desc_a,info) + if (info == psb_success_) stopdat%values(xni_) = psb_geamax(x,desc_a,info) stopdat%values(errnum_) = stopdat%values(rni_) stopdat%values(errden_) = & & (stopdat%values(ani_)*stopdat%values(xni_)+stopdat%values(bni_)) @@ -1516,12 +1516,12 @@ contains stopdat%values(errden_) = stopdat%values(bn2_) case default - info=4001 + info=psb_err_internal_error_ call psb_errpush(info,name,a_err="Control data in stopdat messed up!") goto 9999 end select - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -1536,7 +1536,7 @@ contains psb_z_check_conv = (psb_z_check_conv.or.(stopdat%controls(itmax_) <= it)) if ( (stopdat%controls(trace_) > 0).and.& - & ((mod(it,stopdat%controls(trace_))==0).or.psb_z_check_conv)) then + & ((mod(it,stopdat%controls(trace_)) == 0).or.psb_z_check_conv)) then call log_conv(methdname,me,it,1,stopdat%values(errnum_),& & stopdat%values(errden_),stopdat%values(eps_)) end if @@ -1568,7 +1568,7 @@ contains real(psb_dpk_) :: errnum, errden, eps character(len=20) :: name - info = 0 + info = psb_success_ name = 'psb_end_conv' ictxt = psb_cd_get_context(desc_a) diff --git a/krylov/psb_sbicg.f90 b/krylov/psb_sbicg.f90 index c1bf5b2d7..ff9a01419 100644 --- a/krylov/psb_sbicg.f90 +++ b/krylov/psb_sbicg.f90 @@ -128,7 +128,7 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name,ch_err character(len=*), parameter :: methdname='BiCG' - info = 0 + info = psb_success_ name = 'psb_sbicg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -158,7 +158,7 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -166,14 +166,14 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -182,10 +182,10 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) naux=4*n_col allocate(aux(naux),stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=9) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ ch_err='psb_asb' err=info call psb_errpush(info,name,a_err=ch_err) @@ -218,8 +218,8 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -230,12 +230,12 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(sone,b,szero,r,desc_a,info) - if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),' Done spmm',info - if (info == 0) call psb_geaxpby(sone,r,szero,rt,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -244,8 +244,8 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -257,18 +257,18 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx call prec%apply(r,z,desc_a,info,work=aux) - if (info == 0) call prec%apply(rt,zt,desc_a,info,trans='t',work=aux) + if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='t',work=aux) rho_old = rho rho = psb_gedot(rt,z,desc_a,info) - if (rho==szero) then + if (rho == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(sone,z,szero,p,desc_a,info) call psb_geaxpby(sone,zt,szero,pt,desc_a,info) else @@ -283,7 +283,7 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & work=aux,trans='t') sigma = psb_gedot(pt,q,desc_a,info) - if (sigma==szero) then + if (sigma == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -298,8 +298,8 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_geaxpby(-alpha,qt,sone,rt,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -313,8 +313,8 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end if deallocate(aux, stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_scg.F90 b/krylov/psb_scg.F90 index 9cb84d1e8..59b01d87f 100644 --- a/krylov/psb_scg.F90 +++ b/krylov/psb_scg.F90 @@ -126,7 +126,7 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) character(len=20) :: name character(len=*), parameter :: methdname='CG' - info = 0 + info = psb_success_ name = 'psb_scg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -149,19 +149,19 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col allocate(aux(naux), stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=5) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -191,8 +191,8 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) allocate(td(itmax_),tu(itmax_), eig(itmax_),& & ibl(itmax_),ispl(itmax_),iwrk(3*itmax_),ewrk(4*itmax_),& & stat=info) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -211,9 +211,9 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) it = 0 call psb_geaxpby(sone,b,szero,r,desc_a,info) - if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -221,8 +221,8 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) rho = szero call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -235,10 +235,10 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) rho_old = rho rho = psb_gedot(r,z,desc_a,info) - if (it==1) then + if (it == 1) then call psb_geaxpby(sone,z,szero,p,desc_a,info) else - if (rho_old==szero) then + if (rho_old == szero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown rho' @@ -250,7 +250,7 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) call psb_spmm(sone,a,p,szero,q,desc_a,info,work=aux) sigma = psb_gedot(p,q,desc_a,info) - if (sigma==szero) then + if (sigma == szero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown sigma' @@ -272,8 +272,8 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) call psb_geaxpby(-alpha,q,sone,r,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -281,20 +281,20 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) end do restart if (do_cond) then - if (me==0) then + if (me == 0) then #if defined(HAVE_LAPACK) call sstebz('A','E',istebz,szero,szero,0,0,-sone,td,tu,& & ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info) if (info < 0) then - call psb_errpush(4013,name,a_err='sstebz',i_err=(/info,0,0,0,0/)) - info = 4013 + call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='sstebz',i_err=(/info,0,0,0,0/)) + info = psb_err_from_subroutine_ai_ goto 9999 end if cond = eig(ieg)/eig(1) #else cond = -1.0 #endif - info = 0 + info = psb_success_ end if call psb_bcast(ictxt,cond,root=0) end if @@ -305,7 +305,7 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond) end if call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_scgs.f90 b/krylov/psb_scgs.f90 index 0ac47b8e6..55cddad09 100644 --- a/krylov/psb_scgs.f90 +++ b/krylov/psb_scgs.f90 @@ -125,7 +125,7 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='CGS' - info = 0 + info = psb_success_ name = 'psb_scgs' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -147,19 +147,19 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col Allocate(aux(naux),stat=info) - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info /= 0) Then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -195,8 +195,8 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) itx = 0 call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -207,10 +207,10 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(sone,b,szero,r,desc_a,info) - if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(sone,r,szero,rt,desc_a,info) - if (info/=0) then - info=4011 + if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -218,8 +218,8 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -234,36 +234,36 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(rt,r,desc_a,info) - if (rho==szero) then + if (rho == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(sone,r,szero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(sone,r,szero,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,r,szero,p,desc_a,info) else beta = (rho/rho_old) call psb_geaxpby(sone,r,szero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(beta,q,sone,uv,desc_a,info) - if (info == 0) call psb_geaxpby(sone,q,beta,p,desc_a,info) - if (info == 0) call psb_geaxpby(sone,uv,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(beta,q,sone,uv,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,q,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,uv,beta,p,desc_a,info) end if - if (info == 0) call prec%apply(p,f,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) - if (info == 0) call psb_spmm(sone,a,f,szero,v,desc_a,info,& + if (info == psb_success_) call psb_spmm(sone,a,f,szero,v,desc_a,info,& & work=aux) - if (info /= 0) then - call psb_errpush(4010,name,a_err='First loop part ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') goto 9999 end if sigma = psb_gedot(rt,v,desc_a,info) - if (sigma==szero) then + if (sigma == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -272,28 +272,28 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma - if (info == 0) call psb_geaxpby(sone,uv,szero,q,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,sone,q,desc_a,info) - if (info == 0) call psb_geaxpby(sone,uv,szero,s,desc_a,info) - if (info == 0) call psb_geaxpby(sone,q,sone,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,uv,szero,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,v,sone,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,uv,szero,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,q,sone,s,desc_a,info) - if (info == 0) call prec%apply(s,z,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(alpha,z,sone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(alpha,z,sone,x,desc_a,info) - if (info == 0) call psb_spmm(sone,a,z,szero,qt,desc_a,info,& + if (info == psb_success_) call psb_spmm(sone,a,z,szero,qt,desc_a,info,& & work=aux) - if (info == 0) call psb_geaxpby(-alpha,qt,sone,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,qt,sone,r,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='X update ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') goto 9999 end if if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -307,8 +307,8 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end if deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_scgstab.F90 b/krylov/psb_scgstab.F90 index 45dda57c4..79edfb443 100644 --- a/krylov/psb_scgstab.F90 +++ b/krylov/psb_scgstab.F90 @@ -133,7 +133,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab' - info = 0 + info = psb_success_ name = 'psb_scgstab' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -152,7 +152,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ifcte = mpe_log_get_event_number() immb = mpe_log_get_event_number() imme = mpe_log_get_event_number() - if (irank==0) then + if (irank == 0) then info = mpe_describe_state(istpb,istpe,"Solver","WhiteSmoke") info = mpe_describe_state(ifctb,ifcte,"PREC","SteelBlue") info = mpe_describe_state(immb,imme,"SPMM","DarkOrange") @@ -179,24 +179,24 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if naux=6*n_col allocate(aux(naux),stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=8) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -227,8 +227,8 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) itx = 0 call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -241,21 +241,21 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) #ifdef MPE_KRYLOV imerr = MPE_Log_event( immb, 0, "st SPMM" ) #endif - if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) #ifdef MPE_KRYLOV imerr = MPE_Log_event( imme, 0, "ed SPMM" ) #endif - if (info == 0) call psb_geaxpby(sone,r,szero,q,desc_a,info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_geaxpby(sone,r,szero,q,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Init residual') goto 9999 end if ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -272,14 +272,14 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(q,r,desc_a,info) - if (rho==szero) then + if (rho == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown R',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(sone,r,szero,p,desc_a,info) else beta = (rho/rho_old)*(alpha/omega) @@ -302,7 +302,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) #endif sigma = psb_gedot(q,v,desc_a,info) - if (sigma==szero) then + if (sigma == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S1', sigma @@ -311,10 +311,10 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma call psb_geaxpby(sone,r,szero,s,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,sone,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,v,sone,s,desc_a,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psb_geaxpby') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_geaxpby') goto 9999 end if @@ -327,19 +327,19 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) imerr = MPE_Log_event( ifcte, 0, "ed PREC" ) imerr = MPE_Log_event( immb, 0, "st SPMM" ) #endif - if (info == 0) Call psb_spmm(sone,a,z,szero,t,desc_a,info,& + if (info == psb_success_) Call psb_spmm(sone,a,z,szero,t,desc_a,info,& & work=aux) #ifdef MPE_KRYLOV imerr = MPE_Log_event( imme, 0, "ed SPMM" ) #endif - if(info /= 0) then - call psb_errpush(4010,name,a_err='precaply/spmm') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm') goto 9999 end if sigma = psb_gedot(t,t,desc_a,info) - if (sigma==szero) then + if (sigma == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S2', sigma @@ -349,7 +349,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) tau = psb_gedot(t,s,desc_a,info) omega = tau/sigma - if (omega==szero) then + if (omega == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown O',omega @@ -357,17 +357,17 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_geaxpby(alpha,f,sone,x,desc_a,info) - if (info == 0) call psb_geaxpby(omega,z,sone,x,desc_a,info) - if (info == 0) call psb_geaxpby(sone,s,szero,r,desc_a,info) - if (info == 0) call psb_geaxpby(-omega,t,sone,r,desc_a,info) - if (info /= 0) Then - call psb_errpush(4010,name,a_err='X/R update ') + if (info == psb_success_) call psb_geaxpby(omega,z,sone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,s,szero,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-omega,t,sone,r,desc_a,info) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ') goto 9999 End If if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -380,8 +380,8 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) end if deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if(info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if(info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_scgstabl.f90 b/krylov/psb_scgstabl.f90 index 142b11d0f..1abf0bf86 100644 --- a/krylov/psb_scgstabl.f90 +++ b/krylov/psb_scgstabl.f90 @@ -138,7 +138,7 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab(L)' - info = 0 + info = psb_success_ name = 'psb_scgstabl' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -184,7 +184,7 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -192,9 +192,9 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if @@ -203,19 +203,19 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is allocate(aux(naux),gamma(0:nl),gamma1(nl),& &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10) - if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info == 0) Call psb_geasb(uh,desc_a,info) - if (info == 0) Call psb_geasb(rh,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) + if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info == psb_success_) Call psb_geasb(uh,desc_a,info) + if (info == psb_success_) Call psb_geasb(rh,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -236,8 +236,8 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -252,15 +252,15 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is it = 0 call psb_geaxpby(sone,b,szero,r,desc_a,info) - if (info == 0) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux) - if (info == 0) call prec%apply(r,desc_a,info) + if (info == psb_success_) call prec%apply(r,desc_a,info) - if (info == 0) call psb_geaxpby(sone,r,szero,rt0,desc_a,info) - if (info == 0) call psb_geaxpby(sone,r,szero,rh(:,0),desc_a,info) - if (info == 0) call psb_geaxpby(szero,r,szero,uh(:,0),desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt0,desc_a,info) + if (info == psb_success_) call psb_geaxpby(sone,r,szero,rh(:,0),desc_a,info) + if (info == psb_success_) call psb_geaxpby(szero,r,szero,uh(:,0),desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -274,8 +274,8 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' on entry to amax: b: ',Size(b) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -294,7 +294,7 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is rho_old = rho rho = psb_gedot(rh(:,j),rt0,desc_a,info) - if (rho==szero) then + if (rho == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown r',rho @@ -310,7 +310,7 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) - if (gamma(j)==szero) then + if (gamma(j) == szero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown s2',gamma(j) @@ -372,8 +372,8 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is enddo if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -387,10 +387,10 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is end if deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info == 0) call psb_gefree(uh,desc_a,info) - if (info == 0) call psb_gefree(rh,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info == psb_success_) call psb_gefree(uh,desc_a,info) + if (info == psb_success_) call psb_gefree(rh,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_srgmres.f90 b/krylov/psb_srgmres.f90 index 1bf58448f..40aa7cd69 100644 --- a/krylov/psb_srgmres.f90 +++ b/krylov/psb_srgmres.f90 @@ -138,7 +138,7 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist character(len=20) :: name character(len=*), parameter :: methdname='RGMRES' - info = 0 + info = psb_success_ name = 'psb_sgmres' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -164,7 +164,7 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -195,7 +195,7 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -203,14 +203,14 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -220,16 +220,16 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist allocate(aux(naux),h(nl+1,nl+1),& &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) - if (info == 0) call psb_geall(v,desc_a,info,n=nl+1) - if (info == 0) call psb_geall(w,desc_a,info) - if (info == 0) call psb_geall(w1,desc_a,info) - if (info == 0) call psb_geall(xt,desc_a,info) - if (info == 0) call psb_geasb(v,desc_a,info) - if (info == 0) call psb_geasb(w,desc_a,info) - if (info == 0) call psb_geasb(w1,desc_a,info) - if (info == 0) call psb_geasb(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(v,desc_a,info,n=nl+1) + if (info == psb_success_) call psb_geall(w,desc_a,info) + if (info == psb_success_) call psb_geall(w1,desc_a,info) + if (info == psb_success_) call psb_geall(xt,desc_a,info) + if (info == psb_success_) call psb_geasb(v,desc_a,info) + if (info == psb_success_) call psb_geasb(w,desc_a,info) + if (info == psb_success_) call psb_geasb(w1,desc_a,info) + if (info == psb_success_) call psb_geasb(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -250,12 +250,12 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist errnum = dzero errden = done deps = eps - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if - if ((itrace_ > 0).and.(me==0)) call log_header(methdname) + if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) itx = 0 restart: do @@ -269,23 +269,23 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' restart: ',itx,it it = 0 call psb_geaxpby(sone,b,szero,v(:,1),desc_a,info) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if call psb_spmm(-sone,a,x,sone,v(:,1),desc_a,info,work=aux) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if rs(1) = psb_genrm2(v(:,1),desc_a,info) rs(2:) = szero - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -308,8 +308,8 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist errnum = rni errden = bn2 endif - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -397,7 +397,7 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Rebuild RS:',rs(1:i) - if ((debug_level >= psb_debug_ext_).and.(me==0)) then + if ((debug_level >= psb_debug_ext_).and.(me == 0)) then write(debug_unit,*) me,' ',trim(name),& & ' Rebuild RS H:' @@ -459,12 +459,12 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist end if deallocate(aux,h,c,s,rs,rst, stat=info) - if (info == 0) call psb_gefree(v,desc_a,info) - if (info == 0) call psb_gefree(w,desc_a,info) - if (info == 0) call psb_gefree(w1,desc_a,info) - if (info == 0) call psb_gefree(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_gefree(v,desc_a,info) + if (info == psb_success_) call psb_gefree(w,desc_a,info) + if (info == psb_success_) call psb_gefree(w1,desc_a,info) + if (info == psb_success_) call psb_gefree(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_zbicg.f90 b/krylov/psb_zbicg.f90 index 9a43f1f5f..8b318aaac 100644 --- a/krylov/psb_zbicg.f90 +++ b/krylov/psb_zbicg.f90 @@ -126,7 +126,7 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name,ch_err character(len=*), parameter :: methdname='BiCG' - info = 0 + info = psb_success_ name = 'psb_zbicg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -156,7 +156,7 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -164,14 +164,14 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -180,10 +180,10 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) naux=4*n_col allocate(aux(naux),stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=9) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ ch_err='psb_asb' err=info call psb_errpush(info,name,a_err=ch_err) @@ -216,8 +216,8 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -228,12 +228,12 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(zone,b,zzero,r,desc_a,info) - if (info == 0) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),' Zone spmm',info - if (info == 0) call psb_geaxpby(zone,r,zzero,rt,desc_a,info) - if(info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -242,8 +242,8 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -255,18 +255,18 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx call prec%apply(r,z,desc_a,info,work=aux) - if (info == 0) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) + if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux) rho_old = rho rho = psb_gedot(rt,z,desc_a,info) - if (rho==zzero) then + if (rho == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(zone,z,zzero,p,desc_a,info) call psb_geaxpby(zone,zt,zzero,pt,desc_a,info) else @@ -281,7 +281,7 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) & work=aux,trans='c') sigma = psb_gedot(pt,q,desc_a,info) - if (sigma==zzero) then + if (sigma == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -296,8 +296,8 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_geaxpby(-(alpha),qt,zone,rt,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -307,8 +307,8 @@ subroutine psb_zbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux, stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_zcg.F90 b/krylov/psb_zcg.F90 index eb51afe27..8a2593bc3 100644 --- a/krylov/psb_zcg.F90 +++ b/krylov/psb_zcg.F90 @@ -123,7 +123,7 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='CG' - info = 0 + info = psb_success_ name = 'psb_zcg' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -145,19 +145,19 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col allocate(aux(naux), stat=info) - if (info == 0) call psb_geall(wwrk,desc_a,info,n=5) - if (info == 0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -194,9 +194,9 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) it = 0 call psb_geaxpby(zone,b,zzero,r,desc_a,info) - if (info == 0) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -204,8 +204,8 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho = zzero call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -218,10 +218,10 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(r,z,desc_a,info) - if (it==1) then + if (it == 1) then call psb_geaxpby(zone,z,zzero,p,desc_a,info) else - if (rho_old==zzero) then + if (rho_old == zzero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown rho' @@ -233,7 +233,7 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_spmm(zone,a,p,zzero,q,desc_a,info,work=aux) sigma = psb_gedot(p,q,desc_a,info) - if (sigma==zzero) then + if (sigma == zzero) then if (debug_level >= psb_debug_ext_)& & write(debug_unit,*) me,' ',trim(name),& & ': CG Iteration breakdown sigma' @@ -245,8 +245,8 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_geaxpby(-alpha,q,zone,r,desc_a,info) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -256,7 +256,7 @@ subroutine psb_zcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_zcgs.f90 b/krylov/psb_zcgs.f90 index 0af58ee6e..7cd6b7a29 100644 --- a/krylov/psb_zcgs.f90 +++ b/krylov/psb_zcgs.f90 @@ -122,7 +122,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='CGS' - info = 0 + info = psb_success_ name = 'psb_zcgs' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -144,19 +144,19 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if naux=4*n_col Allocate(aux(naux),stat=info) - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=11) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info /= 0) Then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -192,8 +192,8 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) itx = 0 call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -204,10 +204,10 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(zone,b,zzero,r,desc_a,info) - if (info == 0) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(zone,r,zzero,rt,desc_a,info) - if (info/=0) then - info=4011 + if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -215,8 +215,8 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -231,36 +231,36 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(rt,r,desc_a,info) - if (rho==zzero) then + if (rho == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown r',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(zone,r,zzero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(zone,r,zzero,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,r,zzero,p,desc_a,info) else beta = (rho/rho_old) call psb_geaxpby(zone,r,zzero,uv,desc_a,info) - if (info == 0) call psb_geaxpby(beta,q,zone,uv,desc_a,info) - if (info == 0) call psb_geaxpby(zone,q,beta,p,desc_a,info) - if (info == 0) call psb_geaxpby(zone,uv,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(beta,q,zone,uv,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,q,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,uv,beta,p,desc_a,info) end if - if (info == 0) call prec%apply(p,f,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) - if (info == 0) call psb_spmm(zone,a,f,zzero,v,desc_a,info,& + if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info,& & work=aux) - if (info /= 0) then - call psb_errpush(4010,name,a_err='First loop part ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ') goto 9999 end if sigma = psb_gedot(rt,v,desc_a,info) - if (sigma==zzero) then + if (sigma == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' iteration breakdown s1', sigma @@ -269,28 +269,28 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma - if (info == 0) call psb_geaxpby(zone,uv,zzero,q,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,zone,q,desc_a,info) - if (info == 0) call psb_geaxpby(zone,uv,zzero,s,desc_a,info) - if (info == 0) call psb_geaxpby(zone,q,zone,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,uv,zzero,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,v,zone,q,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,uv,zzero,s,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,q,zone,s,desc_a,info) - if (info == 0) call prec%apply(s,z,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(alpha,z,zone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(alpha,z,zone,x,desc_a,info) - if (info == 0) call psb_spmm(zone,a,z,zzero,qt,desc_a,info,& + if (info == psb_success_) call psb_spmm(zone,a,z,zzero,qt,desc_a,info,& & work=aux) - if (info == 0) call psb_geaxpby(-alpha,qt,zone,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-alpha,qt,zone,r,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='X update ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') goto 9999 end if if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -300,8 +300,8 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info /= 0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_zcgstab.f90 b/krylov/psb_zcgstab.f90 index 51a193326..0ca61e6b5 100644 --- a/krylov/psb_zcgstab.f90 +++ b/krylov/psb_zcgstab.f90 @@ -125,7 +125,7 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab' - info = 0 + info = psb_success_ name = 'psb_zcgstab' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -146,24 +146,24 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) Endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if naux=6*n_col allocate(aux(naux),stat=info) - if (info==0) call psb_geall(wwrk,desc_a,info,n=8) - if (info==0) call psb_geasb(wwrk,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8) + if (info == psb_success_) call psb_geasb(wwrk,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If @@ -196,8 +196,8 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -209,10 +209,10 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) if (itx >= itmax_) exit restart it = 0 call psb_geaxpby(zone,b,zzero,r,desc_a,info) - if (info == 0) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) - if (info == 0) call psb_geaxpby(zone,r,zzero,q,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_geaxpby(zone,r,zzero,q,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -225,8 +225,8 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) ! Perhaps we already satisfy the convergence criterion... if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -240,33 +240,33 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) rho_old = rho rho = psb_gedot(q,r,desc_a,info) - if (rho==zzero) then + if (rho == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown R',rho exit iteration endif - if (it==1) then + if (it == 1) then call psb_geaxpby(zone,r,zzero,p,desc_a,info) else beta = (rho/rho_old)*(alpha/omega) call psb_geaxpby(-omega,v,zone,p,desc_a,info) - if (info == 0) call psb_geaxpby(zone,r,beta,p,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,r,beta,p,desc_a,info) end if - if (info == 0) call prec%apply(p,f,desc_a,info,work=aux) + if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux) - if (info == 0) call psb_spmm(zone,a,f,zzero,v,desc_a,info,& + if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info,& & work=aux) - if (info == 0) sigma = psb_gedot(q,v,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='First step') + if (info == psb_success_) sigma = psb_gedot(q,v,desc_a,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='First step') goto 9999 end if - if (sigma==zzero) then + if (sigma == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S1', sigma @@ -279,18 +279,18 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) alpha = rho/sigma call psb_geaxpby(zone,r,zzero,s,desc_a,info) - if (info == 0) call psb_geaxpby(-alpha,v,zone,s,desc_a,info) - if (info == 0) call prec%apply(s,z,desc_a,info,work=aux) - if (info == 0) call psb_spmm(zone,a,z,zzero,t,desc_a,info,& + if (info == psb_success_) call psb_geaxpby(-alpha,v,zone,s,desc_a,info) + if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(zone,a,z,zzero,t,desc_a,info,& & work=aux) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Second step ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Second step ') goto 9999 end if sigma = psb_gedot(t,t,desc_a,info) - if (sigma==zzero) then + if (sigma == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown S2', sigma @@ -300,26 +300,26 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) tau = psb_gedot(t,s,desc_a,info) omega = tau/sigma - if (omega==zzero) then + if (omega == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' Iteration breakdown O',omega exit iteration endif - if (info == 0) call psb_geaxpby(alpha,f,zone,x,desc_a,info) - if (info == 0) call psb_geaxpby(omega,z,zone,x,desc_a,info) - if (info == 0) call psb_geaxpby(zone,s,zzero,r,desc_a,info) - if (info == 0) call psb_geaxpby(-omega,t,zone,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(alpha,f,zone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(omega,z,zone,x,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,s,zzero,r,desc_a,info) + if (info == psb_success_) call psb_geaxpby(-omega,t,zone,r,desc_a,info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='X update ') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ') goto 9999 end if if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -329,8 +329,8 @@ subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop) call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_zcgstabl.f90 b/krylov/psb_zcgstabl.f90 index 0e2770bb8..ef1dfff71 100644 --- a/krylov/psb_zcgstabl.f90 +++ b/krylov/psb_zcgstabl.f90 @@ -137,7 +137,7 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is character(len=20) :: name character(len=*), parameter :: methdname='BiCGStab(L)' - info = 0 + info = psb_success_ name = 'psb_zcgstabl' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -183,7 +183,7 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -191,9 +191,9 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if (info == 0) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if (info /= 0) then - info=4010 + if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') goto 9999 end if @@ -202,19 +202,19 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is allocate(aux(naux),gamma(0:nl),gamma1(nl),& &gamma2(nl),taum(nl,nl),sigma(nl), stat=info) - if (info /= 0) then - info=4000 + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - if (info == 0) Call psb_geall(wwrk,desc_a,info,n=10) - if (info == 0) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) - if (info == 0) Call psb_geasb(wwrk,desc_a,info) - if (info == 0) Call psb_geasb(uh,desc_a,info) - if (info == 0) Call psb_geasb(rh,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=psb_err_iarg_neg_) + if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0) + if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info) + if (info == psb_success_) Call psb_geasb(uh,desc_a,info) + if (info == psb_success_) Call psb_geasb(rh,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -235,8 +235,8 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info) - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -251,15 +251,15 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is it = 0 call psb_geaxpby(zone,b,zzero,r,desc_a,info) - if (info == 0) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) + if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux) - if (info == 0) call prec%apply(r,desc_a,info) + if (info == psb_success_) call prec%apply(r,desc_a,info) - if (info == 0) call psb_geaxpby(zone,r,zzero,rt0,desc_a,info) - if (info == 0) call psb_geaxpby(zone,r,zzero,rh(:,0),desc_a,info) - if (info == 0) call psb_geaxpby(zzero,r,zzero,uh(:,0),desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt0,desc_a,info) + if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rh(:,0),desc_a,info) + if (info == psb_success_) call psb_geaxpby(zzero,r,zzero,uh(:,0),desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -273,8 +273,8 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is & ' on entry to amax: b: ',Size(b) if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -293,7 +293,7 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is rho_old = rho rho = psb_gedot(rh(:,j),rt0,desc_a,info) - if (rho==zzero) then + if (rho == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown r',rho @@ -309,7 +309,7 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info) - if (gamma(j)==zzero) then + if (gamma(j) == zzero) then if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),& & ' bi-cgstab iteration breakdown s2',gamma(j) @@ -371,8 +371,8 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is enddo if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart - if (info /= 0) Then - call psb_errpush(4011,name) + if (info /= psb_success_) Then + call psb_errpush(psb_err_from_subroutine_non_,name) goto 9999 End If @@ -382,10 +382,10 @@ Subroutine psb_zcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter) deallocate(aux,stat=info) - if (info == 0) call psb_gefree(wwrk,desc_a,info) - if (info == 0) call psb_gefree(uh,desc_a,info) - if (info == 0) call psb_gefree(rh,desc_a,info) - if (info/=0) then + if (info == psb_success_) call psb_gefree(wwrk,desc_a,info) + if (info == psb_success_) call psb_gefree(uh,desc_a,info) + if (info == psb_success_) call psb_gefree(rh,desc_a,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if diff --git a/krylov/psb_zrgmres.f90 b/krylov/psb_zrgmres.f90 index d919cff01..c9a1e270d 100644 --- a/krylov/psb_zrgmres.f90 +++ b/krylov/psb_zrgmres.f90 @@ -139,7 +139,7 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist character(len=20) :: name character(len=*), parameter :: methdname='RGMRES' - info = 0 + info = psb_success_ name = 'psb_zgmres' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() @@ -165,7 +165,7 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist ! if ((istop_ < 1 ).or.(istop_ > 2 ) ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=istop_ err=info call psb_errpush(info,name,i_err=int_err) @@ -196,7 +196,7 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' not present: irst: ',irst,nl endif if (nl <=0 ) then - info=5001 + info=psb_err_invalid_istop_ int_err(1)=nl err=info call psb_errpush(info,name,i_err=int_err) @@ -204,14 +204,14 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist endif call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') goto 9999 end if @@ -221,16 +221,16 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist allocate(aux(naux),h(nl+1,nl+1),& &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info) - if (info == 0) Call psb_geall(v,desc_a,info,n=nl+1) - if (info == 0) Call psb_geall(w,desc_a,info) - if (info == 0) Call psb_geall(w1,desc_a,info) - if (info == 0) Call psb_geall(xt,desc_a,info) - if (info == 0) Call psb_geasb(v,desc_a,info) - if (info == 0) Call psb_geasb(w,desc_a,info) - if (info == 0) Call psb_geasb(w1,desc_a,info) - if (info == 0) Call psb_geasb(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) Call psb_geall(v,desc_a,info,n=nl+1) + if (info == psb_success_) Call psb_geall(w,desc_a,info) + if (info == psb_success_) Call psb_geall(w1,desc_a,info) + if (info == psb_success_) Call psb_geall(xt,desc_a,info) + if (info == psb_success_) Call psb_geasb(v,desc_a,info) + if (info == psb_success_) Call psb_geasb(w,desc_a,info) + if (info == psb_success_) Call psb_geasb(w1,desc_a,info) + if (info == psb_success_) Call psb_geasb(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -250,12 +250,12 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist endif errnum = dzero errden = done - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if - if ((itrace_ > 0).and.(me==0)) call log_header(methdname) + if ((itrace_ > 0).and.(me == 0)) call log_header(methdname) itx = 0 restart: do @@ -269,23 +269,23 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist & ' restart: ',itx,it it = 0 call psb_geaxpby(zone,b,zzero,v(:,1),desc_a,info) - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if call psb_spmm(-zone,a,x,zone,v(:,1),desc_a,info,work=aux) - if (info /= 0) Then - info=4011 + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 End If rs(1) = psb_genrm2(v(:,1),desc_a,info) rs(2:) = zzero - if (info /= 0) Then - info=4011 + if (info /= psb_success_) Then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -308,8 +308,8 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist errnum = rni errden = bn2 endif - if (info /= 0) then - info=4011 + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -440,12 +440,12 @@ Subroutine psb_zrgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist call log_end(methdname,me,itx,errnum,errden,eps,err=err,iter=iter) deallocate(aux,h,c,s,rs,rst, stat=info) - if (info == 0) call psb_gefree(v,desc_a,info) - if (info == 0) call psb_gefree(w,desc_a,info) - if (info == 0) call psb_gefree(w1,desc_a,info) - if (info == 0) call psb_gefree(xt,desc_a,info) - if (info /= 0) then - info=4011 + if (info == psb_success_) call psb_gefree(v,desc_a,info) + if (info == psb_success_) call psb_gefree(w,desc_a,info) + if (info == psb_success_) call psb_gefree(w1,desc_a,info) + if (info == psb_success_) call psb_gefree(xt,desc_a,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_non_ call psb_errpush(info,name) goto 9999 end if @@ -484,13 +484,13 @@ contains ! .. ! ! purpose - ! ======= + ! == = ==== ! ! zrot applies a plane rotation, where the cos (c) is real and the ! sin (s) is complex, and the vectors cx and cy are complex. ! ! arguments - ! ========= + ! == = ====== ! ! n (input) integer ! the number of elements in the vectors cx and cy. @@ -516,7 +516,7 @@ contains ! [ -conjg(s) c ] ! where c*c + s*conjg(s) = 1.0. ! - ! ===================================================================== + ! == = ================================================================== ! ! .. local scalars .. integer i, ix, iy diff --git a/prec/psb_c_bjacprec.f03 b/prec/psb_c_bjacprec.f03 index cf01d1a7a..8953ad4ab 100644 --- a/prec/psb_c_bjacprec.f03 +++ b/prec/psb_c_bjacprec.f03 @@ -46,7 +46,7 @@ contains character(len=20) :: name='c_bjac_prec_apply' character(len=20) :: ch_err - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -59,7 +59,7 @@ contains case('N','T','C') ! Ok case default - call psb_errpush(40,name) + call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select @@ -95,16 +95,16 @@ contains aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif @@ -117,30 +117,30 @@ contains case('N') call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,& + & desc_data,info,trans=trans_,scale='U',choice=psb_none_, work=aux) case('T') call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,& + & desc_data,info,trans=trans_,scale='U',choice=psb_none_,work=aux) case('C') call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,& & trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,& + & desc_data,info,trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /=0) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if case default - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') goto 9999 end select @@ -184,10 +184,10 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 end if @@ -235,7 +235,7 @@ contains if(psb_get_errstatus() /= 0) return - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -244,7 +244,7 @@ contains m = a%get_nrows() if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,i_err=int_err) @@ -267,8 +267,8 @@ contains end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if endif @@ -281,11 +281,11 @@ contains n_row = nrow_a allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -298,8 +298,8 @@ contains endif if (.not.allocated(prec%d)) then allocate(prec%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -307,7 +307,7 @@ contains ! This is where we have no renumbering, thus no need call psb_ilu_fct(a,lf,uf,prec%d,info) - if(info==0) then + if(info == psb_success_) then call prec%av(psb_l_pr_)%mv_from(lf) call prec%av(psb_u_pr_)%mv_from(uf) call prec%av(psb_l_pr_)%set_asb() @@ -315,7 +315,7 @@ contains call prec%av(psb_l_pr_)%trim() call prec%av(psb_u_pr_)%trim() else - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_ilu_fct' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -328,13 +328,13 @@ contains !!$ end do case(psb_f_none_) - info=4010 + info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) goto 9999 case default - info=4010 + info=psb_err_from_subroutine_ ch_err='Unknown psb_f_type_' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -368,7 +368,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -423,7 +423,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -451,7 +451,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -478,7 +478,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) call prec%av(i)%free() @@ -516,7 +516,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -535,7 +535,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_c_diagprec.f03 b/prec/psb_c_diagprec.f03 index c38dedb98..7bae0018c 100644 --- a/prec/psb_c_diagprec.f03 +++ b/prec/psb_c_diagprec.f03 @@ -41,7 +41,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the DIAG preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) @@ -75,7 +75,7 @@ contains case('N') case('T','C') case default - info=40 + info=psb_err_iarg_invalid_i_ call psb_errpush(info,name,& & i_err=(/6,0,0,0,0/),a_err=trans_) goto 9999 @@ -85,15 +85,15 @@ contains ww => work else allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4025,name,& + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/size(x),0,0,0,0/),a_err='complex(psb_spk_)') goto 9999 end if end if - if (trans_=='C') then + if (trans_ == 'C') then ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow)) else ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) @@ -102,8 +102,8 @@ contains if (size(work) < size(x)) then deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') goto 9999 end if end if @@ -133,7 +133,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -164,25 +164,25 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nrow = psb_cd_get_local_cols(desc_a) if (allocated(prec%d)) then if (size(prec%d) < nrow) then deallocate(prec%d,stat=info) end if end if - if ((info == 0).and.(.not.allocated(prec%d))) then + if ((info == psb_success_).and.(.not.allocated(prec%d))) then allocate(prec%d(nrow), stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call a%get_diag(prec%d,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='get_diag') goto 9999 end if @@ -221,7 +221,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -249,7 +249,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -277,7 +277,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -304,7 +304,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -335,7 +335,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -347,7 +347,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_c_nullprec.f03 b/prec/psb_c_nullprec.f03 index 49e7db085..b42d8deaf 100644 --- a/prec/psb_c_nullprec.f03 +++ b/prec/psb_c_nullprec.f03 @@ -38,7 +38,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the NULL preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) if (size(x) < nrow) then @@ -53,8 +53,8 @@ contains end if call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= 0 ) then - info = 4010 + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ call psb_errpush(infoi,name,a_err="psb_geaxpby") goto 9999 end if @@ -85,7 +85,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -115,7 +115,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -144,7 +144,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -172,7 +172,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -200,7 +200,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -227,7 +227,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -257,7 +257,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout diff --git a/prec/psb_c_prec_type.f03 b/prec/psb_c_prec_type.f03 index 2482ad5ea..2bc8451c0 100644 --- a/prec/psb_c_prec_type.f03 +++ b/prec/psb_c_prec_type.f03 @@ -137,7 +137,7 @@ contains integer :: err_act,i character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) @@ -145,9 +145,9 @@ contains if (allocated(p%prec)) then call p%prec%precfree(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 deallocate(p%prec,stat=info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 end if call psb_erractionrestore(err_act) return @@ -196,7 +196,7 @@ contains character(len=20) :: name name='c_apply2v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_data) @@ -212,8 +212,8 @@ contains work_ => work else allocate(work_(4*psb_cd_get_local_cols(desc_data)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -229,8 +229,8 @@ contains if (present(work)) then else deallocate(work_,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if @@ -262,7 +262,7 @@ contains complex(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name name='c_apply1v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -280,17 +280,17 @@ contains goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(cone,x,czero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if diff --git a/prec/psb_cilu_fct.f90 b/prec/psb_cilu_fct.f90 index 240cd7e6b..c119397ff 100644 --- a/prec/psb_cilu_fct.f90 +++ b/prec/psb_cilu_fct.f90 @@ -50,7 +50,7 @@ subroutine psb_cilu_fct(a,l,u,d,info,blck) type(psb_c_sparse_mat), pointer :: blck_ character(len=20) :: name, ch_err name='psb_ilu_fct' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ! .. Executable Statements .. ! @@ -59,8 +59,8 @@ subroutine psb_cilu_fct(a,l,u,d,info,blck) blck_ => blck else allocate(blck_,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -70,8 +70,8 @@ subroutine psb_cilu_fct(a,l,u,d,info,blck) call psb_cilu_fctint(m,a%get_nrows(),a,blck_%get_nrows(),blck_,& & d,l%val,l%ja,l%irp,u%val,u%ja,u%irp,l1,l2,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cilu_fctint' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -92,8 +92,8 @@ subroutine psb_cilu_fct(a,l,u,d,info,blck) blck_ => null() else call blck_%free() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_free' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -131,11 +131,11 @@ contains name='psb_cilu_fctint' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) call trw%allocate(0,0,1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -172,11 +172,11 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call a%a%csget(i,i+irb-1,trw,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -271,7 +271,7 @@ contains ! ! Pivot too small: unstable factorization ! - info = 2 + info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') abs(dia) call psb_errpush(info,name,i_err=int_err,a_err=ch_err) @@ -310,12 +310,12 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call b%a%csget(i-ma,i-ma+irb-1,trw,info) nz = trw%get_nzeros() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -409,7 +409,7 @@ contains ! int_err(1) = i write(ch_err,'(g20.10)') abs(dia) - info = 2 + info = psb_err_pivot_too_small_ call psb_errpush(info,name,i_err=int_err,a_err=ch_err) goto 9999 else diff --git a/prec/psb_cprc_aply.f90 b/prec/psb_cprc_aply.f90 index 40bcfc6e0..4b97281b4 100644 --- a/prec/psb_cprc_aply.f90 +++ b/prec/psb_cprc_aply.f90 @@ -51,7 +51,7 @@ subroutine psb_cprc_aply(prec,x,y,desc_data,info,trans, work) character(len=20) :: name name='psb_prc_aply' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) @@ -67,8 +67,8 @@ subroutine psb_cprc_aply(prec,x,y,desc_data,info,trans, work) work_ => work else allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -154,7 +154,7 @@ subroutine psb_cprc_aply1(prec,x,desc_data,info,trans) complex(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_prc_aply1' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -172,12 +172,12 @@ subroutine psb_cprc_aply1(prec,x,desc_data,info,trans) goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(cone,x,czero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_cprecbld.f90 b/prec/psb_cprecbld.f90 index b369c9229..f7c56e001 100644 --- a/prec/psb_cprecbld.f90 +++ b/prec/psb_cprecbld.f90 @@ -52,12 +52,12 @@ subroutine psb_cprecbld(a,desc_a,p,info,upd) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 call psb_erractionsave(err_act) name = 'psb_precbld' - info = 0 + info = psb_success_ int_err(1) = 0 ictxt = psb_cd_get_context(desc_a) @@ -89,7 +89,7 @@ subroutine psb_cprecbld(a,desc_a,p,info,upd) end if call p%prec%precbld(a,desc_a,info,upd) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/prec/psb_cprecinit.f90 b/prec/psb_cprecinit.f90 index ab4656fa6..e554afe7d 100644 --- a/prec/psb_cprecinit.f90 +++ b/prec/psb_cprecinit.f90 @@ -42,12 +42,12 @@ subroutine psb_cprecinit(p,ptype,info) character(len=*), intent(in) :: ptype integer, intent(out) :: info - info = 0 + info = psb_success_ if (allocated(p%prec) ) then call p%prec%precfree(info) - if (info == 0) deallocate(p%prec,stat=info) - if (info /= 0) return + if (info == psb_success_) deallocate(p%prec,stat=info) + if (info /= psb_success_) return end if select case(psb_toupper(ptype(1:len_trim(ptype)))) @@ -63,9 +63,9 @@ subroutine psb_cprecinit(p,ptype,info) case default write(0,*) 'Unknown preconditioner type request "',ptype,'"' - info = 2 + info = psb_err_pivot_too_small_ end select - if (info == 0) call p%prec%precinit(info) + if (info == psb_success_) call p%prec%precinit(info) end subroutine psb_cprecinit diff --git a/prec/psb_cprecset.f90 b/prec/psb_cprecset.f90 index 6dd8e1333..ff620aafe 100644 --- a/prec/psb_cprecset.f90 +++ b/prec/psb_cprecset.f90 @@ -39,7 +39,7 @@ subroutine psb_cprecseti(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -65,7 +65,7 @@ subroutine psb_cprecsets(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") diff --git a/prec/psb_d_bjacprec.f03 b/prec/psb_d_bjacprec.f03 index eecc324fa..ac4e2d0d4 100644 --- a/prec/psb_d_bjacprec.f03 +++ b/prec/psb_d_bjacprec.f03 @@ -46,7 +46,7 @@ contains character(len=20) :: name='d_bjac_prec_apply' character(len=20) :: ch_err - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -59,7 +59,7 @@ contains case('N','T','C') ! Ok case default - call psb_errpush(40,name) + call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select @@ -95,16 +95,16 @@ contains aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif @@ -117,24 +117,24 @@ contains case('N') call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) case('T','C') call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /=0) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if case default - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') goto 9999 end select @@ -178,10 +178,10 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 end if @@ -229,7 +229,7 @@ contains if(psb_get_errstatus() /= 0) return - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -238,7 +238,7 @@ contains m = a%get_nrows() if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,i_err=int_err) @@ -261,8 +261,8 @@ contains end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if endif @@ -275,11 +275,11 @@ contains n_row = nrow_a allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -292,8 +292,8 @@ contains endif if (.not.allocated(prec%d)) then allocate(prec%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -301,7 +301,7 @@ contains ! This is where we have no renumbering, thus no need call psb_ilu_fct(a,lf,uf,prec%d,info) - if(info==0) then + if(info == psb_success_) then call prec%av(psb_l_pr_)%mv_from(lf) call prec%av(psb_u_pr_)%mv_from(uf) call prec%av(psb_l_pr_)%set_asb() @@ -309,7 +309,7 @@ contains call prec%av(psb_l_pr_)%trim() call prec%av(psb_u_pr_)%trim() else - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_ilu_fct' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -322,13 +322,13 @@ contains !!$ end do case(psb_f_none_) - info=4010 + info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) goto 9999 case default - info=4010 + info=psb_err_from_subroutine_ ch_err='Unknown psb_f_type_' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -362,7 +362,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -417,7 +417,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -445,7 +445,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -472,7 +472,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) call prec%av(i)%free() @@ -510,7 +510,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -529,7 +529,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_d_diagprec.f03 b/prec/psb_d_diagprec.f03 index dd6f917e3..06ba56907 100644 --- a/prec/psb_d_diagprec.f03 +++ b/prec/psb_d_diagprec.f03 @@ -40,7 +40,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the DIAG preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) if (size(x) < nrow) then @@ -68,8 +68,8 @@ contains ww => work else allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4025,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_dpk_)') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_dpk_)') goto 9999 end if end if @@ -79,8 +79,8 @@ contains if (size(work) < size(x)) then deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') goto 9999 end if end if @@ -110,7 +110,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -141,25 +141,25 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nrow = psb_cd_get_local_cols(desc_a) if (allocated(prec%d)) then if (size(prec%d) < nrow) then deallocate(prec%d,stat=info) end if end if - if ((info == 0).and.(.not.allocated(prec%d))) then + if ((info == psb_success_).and.(.not.allocated(prec%d))) then allocate(prec%d(nrow), stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call a%get_diag(prec%d,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='get_diag') goto 9999 end if @@ -198,7 +198,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -226,7 +226,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -254,7 +254,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -281,7 +281,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -312,7 +312,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -324,7 +324,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_d_nullprec.f03 b/prec/psb_d_nullprec.f03 index f4d7504a4..1820cdbbb 100644 --- a/prec/psb_d_nullprec.f03 +++ b/prec/psb_d_nullprec.f03 @@ -38,7 +38,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the NULL preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) if (size(x) < nrow) then @@ -53,8 +53,8 @@ contains end if call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= 0 ) then - info = 4010 + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ call psb_errpush(infoi,name,a_err="psb_geaxpby") goto 9999 end if @@ -85,7 +85,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -115,7 +115,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -144,7 +144,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -172,7 +172,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -200,7 +200,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -227,7 +227,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -257,7 +257,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout diff --git a/prec/psb_d_prec_type.f03 b/prec/psb_d_prec_type.f03 index 972588a82..5d7d972c4 100644 --- a/prec/psb_d_prec_type.f03 +++ b/prec/psb_d_prec_type.f03 @@ -138,7 +138,7 @@ contains integer :: me, err_act,i character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) @@ -146,9 +146,9 @@ contains if (allocated(p%prec)) then call p%prec%precfree(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 deallocate(p%prec,stat=info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 end if call psb_erractionrestore(err_act) return @@ -199,7 +199,7 @@ contains character(len=20) :: name name='d_apply2v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_data) @@ -215,8 +215,8 @@ contains work_ => work else allocate(work_(4*psb_cd_get_local_cols(desc_data)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -232,8 +232,8 @@ contains if (present(work)) then else deallocate(work_,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if @@ -265,7 +265,7 @@ contains real(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name name='d_apply1v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -283,17 +283,17 @@ contains goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(done,x,dzero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if diff --git a/prec/psb_dilu_fct.f90 b/prec/psb_dilu_fct.f90 index c4e4befd7..b922c0ee3 100644 --- a/prec/psb_dilu_fct.f90 +++ b/prec/psb_dilu_fct.f90 @@ -50,7 +50,7 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck) type(psb_d_sparse_mat), pointer :: blck_ character(len=20) :: name, ch_err name='psb_ilu_fct' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ! .. Executable Statements .. ! @@ -59,8 +59,8 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck) blck_ => blck else allocate(blck_,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -70,8 +70,8 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck) call psb_dilu_fctint(m,a%get_nrows(),a,blck_%get_nrows(),blck_,& & d,l%val,l%ja,l%irp,u%val,u%ja,u%irp,l1,l2,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_dilu_fctint' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -92,8 +92,8 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck) blck_ => null() else call blck_%free() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_free' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -135,11 +135,11 @@ contains name='psb_dilu_fctint' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) call trw%allocate(0,0,1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -175,11 +175,11 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call a%a%csget(i,i+irb-1,trw,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -274,7 +274,7 @@ contains ! ! Pivot too small: unstable factorization ! - info = 2 + info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') dia call psb_errpush(info,name,i_err=int_err,a_err=ch_err) @@ -313,12 +313,12 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call b%a%csget(i-ma,i-ma+irb-1,trw,info) nz = trw%get_nzeros() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -412,7 +412,7 @@ contains ! int_err(1) = i write(ch_err,'(g20.10)') dia - info = 2 + info = psb_err_pivot_too_small_ call psb_errpush(info,name,i_err=int_err,a_err=ch_err) goto 9999 else diff --git a/prec/psb_dprc_aply.f90 b/prec/psb_dprc_aply.f90 index 76d8f4f29..53a9eb884 100644 --- a/prec/psb_dprc_aply.f90 +++ b/prec/psb_dprc_aply.f90 @@ -50,7 +50,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) character(len=20) :: name name='psb_prc_aply' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) @@ -66,8 +66,8 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work) work_ => work else allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -153,7 +153,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) real(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_prc_aply1' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -171,12 +171,12 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans) goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(done,x,dzero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_dprecbld.f90 b/prec/psb_dprecbld.f90 index 1090e9a5b..f1d702475 100644 --- a/prec/psb_dprecbld.f90 +++ b/prec/psb_dprecbld.f90 @@ -51,12 +51,12 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 call psb_erractionsave(err_act) name = 'psb_precbld' - info = 0 + info = psb_success_ int_err(1) = 0 ictxt = psb_cd_get_context(desc_a) @@ -88,7 +88,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd) end if call p%prec%precbld(a,desc_a,info,upd) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/prec/psb_dprecinit.f90 b/prec/psb_dprecinit.f90 index bde882631..da5aa1be9 100644 --- a/prec/psb_dprecinit.f90 +++ b/prec/psb_dprecinit.f90 @@ -41,12 +41,12 @@ subroutine psb_dprecinit(p,ptype,info) character(len=*), intent(in) :: ptype integer, intent(out) :: info - info = 0 + info = psb_success_ if (allocated(p%prec) ) then call p%prec%precfree(info) - if (info == 0) deallocate(p%prec,stat=info) - if (info /= 0) return + if (info == psb_success_) deallocate(p%prec,stat=info) + if (info /= psb_success_) return end if select case(psb_toupper(ptype(1:len_trim(ptype)))) @@ -62,9 +62,9 @@ subroutine psb_dprecinit(p,ptype,info) case default write(0,*) 'Unknown preconditioner type request "',ptype,'"' - info = 2 + info = psb_err_pivot_too_small_ end select - if (info == 0) call p%prec%precinit(info) + if (info == psb_success_) call p%prec%precinit(info) end subroutine psb_dprecinit diff --git a/prec/psb_dprecset.f90 b/prec/psb_dprecset.f90 index a8edbb571..83529a14b 100644 --- a/prec/psb_dprecset.f90 +++ b/prec/psb_dprecset.f90 @@ -39,7 +39,7 @@ subroutine psb_dprecseti(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -65,7 +65,7 @@ subroutine psb_dprecsetd(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") diff --git a/prec/psb_prec_const_mod.f03 b/prec/psb_prec_const_mod.f03 index 2640fb7ef..8f64ab2e5 100644 --- a/prec/psb_prec_const_mod.f03 +++ b/prec/psb_prec_const_mod.f03 @@ -97,7 +97,7 @@ contains integer, intent(in) :: ip logical :: is_legal_ml_fact - is_legal_ml_fact = (ip==psb_f_ilu_n_) + is_legal_ml_fact = (ip == psb_f_ilu_n_) return end function is_legal_ml_fact function is_legal_ml_eps(ip) diff --git a/prec/psb_s_bjacprec.f03 b/prec/psb_s_bjacprec.f03 index 2026b83de..57093fe6d 100644 --- a/prec/psb_s_bjacprec.f03 +++ b/prec/psb_s_bjacprec.f03 @@ -46,7 +46,7 @@ contains character(len=20) :: name='s_bjac_prec_apply' character(len=20) :: ch_err - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -59,7 +59,7 @@ contains case('N','T','C') ! Ok case default - call psb_errpush(40,name) + call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select @@ -95,16 +95,16 @@ contains aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif @@ -117,24 +117,24 @@ contains case('N') call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) case('T','C') call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /=0) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if case default - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') goto 9999 end select @@ -178,10 +178,10 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 end if @@ -229,7 +229,7 @@ contains if(psb_get_errstatus() /= 0) return - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -238,7 +238,7 @@ contains m = a%get_nrows() if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,i_err=int_err) @@ -261,8 +261,8 @@ contains end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if endif @@ -275,11 +275,11 @@ contains n_row = nrow_a allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -292,8 +292,8 @@ contains endif if (.not.allocated(prec%d)) then allocate(prec%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -301,7 +301,7 @@ contains ! This is where we have no renumbering, thus no need call psb_ilu_fct(a,lf,uf,prec%d,info) - if(info==0) then + if(info == psb_success_) then call prec%av(psb_l_pr_)%mv_from(lf) call prec%av(psb_u_pr_)%mv_from(uf) call prec%av(psb_l_pr_)%set_asb() @@ -309,7 +309,7 @@ contains call prec%av(psb_l_pr_)%trim() call prec%av(psb_u_pr_)%trim() else - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_ilu_fct' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -322,13 +322,13 @@ contains !!$ end do case(psb_f_none_) - info=4010 + info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) goto 9999 case default - info=4010 + info=psb_err_from_subroutine_ ch_err='Unknown psb_f_type_' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -362,7 +362,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -417,7 +417,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -445,7 +445,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -472,7 +472,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) call prec%av(i)%free() @@ -510,7 +510,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -529,7 +529,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_s_diagprec.f03 b/prec/psb_s_diagprec.f03 index 2da19d40f..bd3f6ee11 100644 --- a/prec/psb_s_diagprec.f03 +++ b/prec/psb_s_diagprec.f03 @@ -40,7 +40,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the DIAG preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) if (size(x) < nrow) then @@ -68,8 +68,8 @@ contains ww => work else allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4025,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)') + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)') goto 9999 end if end if @@ -79,8 +79,8 @@ contains if (size(work) < size(x)) then deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') goto 9999 end if end if @@ -110,7 +110,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -141,25 +141,25 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nrow = psb_cd_get_local_cols(desc_a) if (allocated(prec%d)) then if (size(prec%d) < nrow) then deallocate(prec%d,stat=info) end if end if - if ((info == 0).and.(.not.allocated(prec%d))) then + if ((info == psb_success_).and.(.not.allocated(prec%d))) then allocate(prec%d(nrow), stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call a%get_diag(prec%d,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='get_diag') goto 9999 end if @@ -198,7 +198,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -226,7 +226,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -254,7 +254,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -281,7 +281,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -312,7 +312,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -324,7 +324,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_s_nullprec.f03 b/prec/psb_s_nullprec.f03 index 8afcade9e..cab73b49f 100644 --- a/prec/psb_s_nullprec.f03 +++ b/prec/psb_s_nullprec.f03 @@ -38,7 +38,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the NULL preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) if (size(x) < nrow) then @@ -53,8 +53,8 @@ contains end if call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= 0 ) then - info = 4010 + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ call psb_errpush(infoi,name,a_err="psb_geaxpby") goto 9999 end if @@ -85,7 +85,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -115,7 +115,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -144,7 +144,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -172,7 +172,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -200,7 +200,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -227,7 +227,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -257,7 +257,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout diff --git a/prec/psb_s_prec_type.f03 b/prec/psb_s_prec_type.f03 index a1d29dc7e..c2dfd46c1 100644 --- a/prec/psb_s_prec_type.f03 +++ b/prec/psb_s_prec_type.f03 @@ -141,7 +141,7 @@ contains integer :: me, err_act,i character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) @@ -149,9 +149,9 @@ contains if (allocated(p%prec)) then call p%prec%precfree(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 deallocate(p%prec,stat=info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 end if call psb_erractionrestore(err_act) return @@ -201,7 +201,7 @@ contains character(len=20) :: name name='s_apply2v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_data) @@ -217,8 +217,8 @@ contains work_ => work else allocate(work_(4*psb_cd_get_local_cols(desc_data)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -234,8 +234,8 @@ contains if (present(work)) then else deallocate(work_,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if @@ -267,7 +267,7 @@ contains real(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name name='s_apply1v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -285,17 +285,17 @@ contains goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(sone,x,szero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if diff --git a/prec/psb_silu_fct.f90 b/prec/psb_silu_fct.f90 index 1dda11b4b..c2bfcc5b1 100644 --- a/prec/psb_silu_fct.f90 +++ b/prec/psb_silu_fct.f90 @@ -50,7 +50,7 @@ subroutine psb_silu_fct(a,l,u,d,info,blck) type(psb_s_sparse_mat), pointer :: blck_ character(len=20) :: name, ch_err name='psb_ilu_fct' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ! .. Executable Statements .. ! @@ -59,8 +59,8 @@ subroutine psb_silu_fct(a,l,u,d,info,blck) blck_ => blck else allocate(blck_,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -70,8 +70,8 @@ subroutine psb_silu_fct(a,l,u,d,info,blck) call psb_silu_fctint(m,a%get_nrows(),a,blck_%get_nrows(),blck_,& & d,l%val,l%ja,l%irp,u%val,u%ja,u%irp,l1,l2,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_silu_fctint' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -92,8 +92,8 @@ subroutine psb_silu_fct(a,l,u,d,info,blck) blck_ => null() else call blck_%free() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_free' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -134,11 +134,11 @@ contains name='psb_silu_fctint' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) call trw%allocate(0,0,1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -174,11 +174,11 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call a%a%csget(i,i+irb-1,trw,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -273,7 +273,7 @@ contains ! ! Pivot too small: unstable factorization ! - info = 2 + info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') dia call psb_errpush(info,name,i_err=int_err,a_err=ch_err) @@ -312,12 +312,12 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call b%a%csget(i-ma,i-ma+irb-1,trw,info) nz = trw%get_nzeros() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -411,7 +411,7 @@ contains ! int_err(1) = i write(ch_err,'(g20.10)') dia - info = 2 + info = psb_err_pivot_too_small_ call psb_errpush(info,name,i_err=int_err,a_err=ch_err) goto 9999 else diff --git a/prec/psb_sprc_aply.f90 b/prec/psb_sprc_aply.f90 index 19904b179..6384c77d9 100644 --- a/prec/psb_sprc_aply.f90 +++ b/prec/psb_sprc_aply.f90 @@ -50,7 +50,7 @@ subroutine psb_sprc_aply(prec,x,y,desc_data,info,trans, work) character(len=20) :: name name='psb_prc_aply' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) @@ -66,8 +66,8 @@ subroutine psb_sprc_aply(prec,x,y,desc_data,info,trans, work) work_ => work else allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -153,7 +153,7 @@ subroutine psb_sprc_aply1(prec,x,desc_data,info,trans) real(psb_spk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_prc_aply1' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -171,12 +171,12 @@ subroutine psb_sprc_aply1(prec,x,desc_data,info,trans) goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(sone,x,szero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_sprecbld.f90 b/prec/psb_sprecbld.f90 index 14d4cd8fc..1e5b685ab 100644 --- a/prec/psb_sprecbld.f90 +++ b/prec/psb_sprecbld.f90 @@ -51,12 +51,12 @@ subroutine psb_sprecbld(a,desc_a,p,info,upd) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 call psb_erractionsave(err_act) name = 'psb_precbld' - info = 0 + info = psb_success_ int_err(1) = 0 ictxt = psb_cd_get_context(desc_a) @@ -88,7 +88,7 @@ subroutine psb_sprecbld(a,desc_a,p,info,upd) end if call p%prec%precbld(a,desc_a,info,upd) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/prec/psb_sprecinit.f90 b/prec/psb_sprecinit.f90 index 1692e9c41..bd2a9ad75 100644 --- a/prec/psb_sprecinit.f90 +++ b/prec/psb_sprecinit.f90 @@ -41,12 +41,12 @@ subroutine psb_sprecinit(p,ptype,info) character(len=*), intent(in) :: ptype integer, intent(out) :: info - info = 0 + info = psb_success_ if (allocated(p%prec) ) then call p%prec%precfree(info) - if (info == 0) deallocate(p%prec,stat=info) - if (info /= 0) return + if (info == psb_success_) deallocate(p%prec,stat=info) + if (info /= psb_success_) return end if select case(psb_toupper(ptype(1:len_trim(ptype)))) @@ -62,9 +62,9 @@ subroutine psb_sprecinit(p,ptype,info) case default write(0,*) 'Unknown preconditioner type request "',ptype,'"' - info = 2 + info = psb_err_pivot_too_small_ end select - if (info == 0) call p%prec%precinit(info) + if (info == psb_success_) call p%prec%precinit(info) end subroutine psb_sprecinit diff --git a/prec/psb_sprecset.f90 b/prec/psb_sprecset.f90 index 93070d1e8..1ea58b7c7 100644 --- a/prec/psb_sprecset.f90 +++ b/prec/psb_sprecset.f90 @@ -39,7 +39,7 @@ subroutine psb_sprecseti(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -65,7 +65,7 @@ subroutine psb_sprecsets(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") diff --git a/prec/psb_z_bjacprec.f03 b/prec/psb_z_bjacprec.f03 index 28ea584bf..79e6c0476 100644 --- a/prec/psb_z_bjacprec.f03 +++ b/prec/psb_z_bjacprec.f03 @@ -46,7 +46,7 @@ contains character(len=20) :: name='z_bjac_prec_apply' character(len=20) :: ch_err - info = 0 + info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -59,7 +59,7 @@ contains case('N','T','C') ! Ok case default - call psb_errpush(40,name) + call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select @@ -95,16 +95,16 @@ contains aux => work(n_col+1:) else allocate(aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif else allocate(ww(n_col),aux(4*n_col),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if endif @@ -117,30 +117,30 @@ contains case('N') call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) case('T') call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& & trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case('C') call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,& & trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux) - if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& + if(info == psb_success_) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) end select - if (info /=0) then + if (info /= psb_success_) then ch_err="psb_spsm" goto 9999 end if case default - info = 4001 + info = psb_err_internal_error_ call psb_errpush(info,name,a_err='Invalid factorization') goto 9999 end select @@ -184,10 +184,10 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_realloc(psb_ifpsz,prec%iprcparm,info) - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_Errpush(info,name) goto 9999 end if @@ -235,7 +235,7 @@ contains if(psb_get_errstatus() /= 0) return - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -244,7 +244,7 @@ contains m = a%get_nrows() if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1) = 1 int_err(2) = m call psb_errpush(info,name,i_err=int_err) @@ -267,8 +267,8 @@ contains end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if endif @@ -281,11 +281,11 @@ contains n_row = nrow_a allocate(lf,uf,stat=info) - if (info == 0) call lf%allocate(n_row,n_row,nztota) - if (info == 0) call uf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call lf%allocate(n_row,n_row,nztota) + if (info == psb_success_) call uf%allocate(n_row,n_row,nztota) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -298,8 +298,8 @@ contains endif if (.not.allocated(prec%d)) then allocate(prec%d(n_row),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -307,7 +307,7 @@ contains ! This is where we have no renumbering, thus no need call psb_ilu_fct(a,lf,uf,prec%d,info) - if(info==0) then + if(info == psb_success_) then call prec%av(psb_l_pr_)%mv_from(lf) call prec%av(psb_u_pr_)%mv_from(uf) call prec%av(psb_l_pr_)%set_asb() @@ -315,7 +315,7 @@ contains call prec%av(psb_l_pr_)%trim() call prec%av(psb_u_pr_)%trim() else - info=4010 + info=psb_err_from_subroutine_ ch_err='psb_ilu_fct' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -328,13 +328,13 @@ contains !!$ end do case(psb_f_none_) - info=4010 + info=psb_err_from_subroutine_ ch_err='Inconsistent prec psb_f_none_' call psb_errpush(info,name,a_err=ch_err) goto 9999 case default - info=4010 + info=psb_err_from_subroutine_ ch_err='Unknown psb_f_type_' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -368,7 +368,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (.not.allocated(prec%iprcparm)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -423,7 +423,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -451,7 +451,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -478,7 +478,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (allocated(prec%av)) then do i=1,size(prec%av) call prec%av(i)%free() @@ -516,7 +516,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -535,7 +535,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_z_diagprec.f03 b/prec/psb_z_diagprec.f03 index f11003ffb..f34108d11 100644 --- a/prec/psb_z_diagprec.f03 +++ b/prec/psb_z_diagprec.f03 @@ -41,7 +41,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the DIAG preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) @@ -75,7 +75,7 @@ contains case('N') case('T','C') case default - info=40 + info=psb_err_iarg_invalid_i_ call psb_errpush(info,name,& & i_err=(/6,0,0,0,0/),a_err=trans_) goto 9999 @@ -85,15 +85,15 @@ contains ww => work else allocate(ww(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4025,name,& + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/size(x),0,0,0,0/),a_err='complex(psb_dpk_)') goto 9999 end if end if - if (trans_=='C') then + if (trans_ == 'C') then ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow)) else ww(1:nrow) = x(1:nrow)*prec%d(1:nrow) @@ -102,8 +102,8 @@ contains if (size(work) < size(x)) then deallocate(ww,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Deallocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') goto 9999 end if end if @@ -133,7 +133,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -164,25 +164,25 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nrow = psb_cd_get_local_cols(desc_a) if (allocated(prec%d)) then if (size(prec%d) < nrow) then deallocate(prec%d,stat=info) end if end if - if ((info == 0).and.(.not.allocated(prec%d))) then + if ((info == psb_success_).and.(.not.allocated(prec%d))) then allocate(prec%d(nrow), stat=info) end if - if (info /= 0) then - info = 4000 + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if call a%get_diag(prec%d,info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='get_diag') goto 9999 end if @@ -221,7 +221,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -249,7 +249,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -277,7 +277,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -304,7 +304,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -335,7 +335,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout @@ -347,7 +347,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return diff --git a/prec/psb_z_nullprec.f03 b/prec/psb_z_nullprec.f03 index e373aa73c..1c78153e8 100644 --- a/prec/psb_z_nullprec.f03 +++ b/prec/psb_z_nullprec.f03 @@ -38,7 +38,7 @@ contains ! This is the base version and we should throw an error. ! Or should it be the NULL preonditioner??? ! - info = 0 + info = psb_success_ nrow = psb_cd_get_local_rows(desc_data) if (size(x) < nrow) then @@ -53,8 +53,8 @@ contains end if call psb_geaxpby(alpha,x,beta,y,desc_data,info) - if (info /= 0 ) then - info = 4010 + if (info /= psb_success_ ) then + info = psb_err_from_subroutine_ call psb_errpush(infoi,name,a_err="psb_geaxpby") goto 9999 end if @@ -85,7 +85,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -115,7 +115,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) @@ -144,7 +144,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -172,7 +172,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -200,7 +200,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -227,7 +227,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call psb_erractionrestore(err_act) return @@ -257,7 +257,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(iout)) then iout_ = iout diff --git a/prec/psb_z_prec_type.f03 b/prec/psb_z_prec_type.f03 index 8e115d092..4fe28ba12 100644 --- a/prec/psb_z_prec_type.f03 +++ b/prec/psb_z_prec_type.f03 @@ -137,7 +137,7 @@ contains integer :: err_act,i character(len=20) :: name if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) @@ -145,9 +145,9 @@ contains if (allocated(p%prec)) then call p%prec%precfree(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 deallocate(p%prec,stat=info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 end if call psb_erractionrestore(err_act) return @@ -196,7 +196,7 @@ contains character(len=20) :: name name='z_apply2v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_data) @@ -212,8 +212,8 @@ contains work_ => work else allocate(work_(4*psb_cd_get_local_cols(desc_data)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if @@ -229,8 +229,8 @@ contains if (present(work)) then else deallocate(work_,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if @@ -262,7 +262,7 @@ contains complex(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name name='z_apply1v' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -280,17 +280,17 @@ contains goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(zone,x,zzero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1,stat=info) - if (info /= 0) then - info = 4010 + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name,a_err='DeAllocate') goto 9999 end if diff --git a/prec/psb_zilu_fct.f90 b/prec/psb_zilu_fct.f90 index e720511bd..8fa0b7a68 100644 --- a/prec/psb_zilu_fct.f90 +++ b/prec/psb_zilu_fct.f90 @@ -50,7 +50,7 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck) type(psb_z_sparse_mat), pointer :: blck_ character(len=20) :: name, ch_err name='psb_ilu_fct' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ! .. Executable Statements .. ! @@ -59,8 +59,8 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck) blck_ => blck else allocate(blck_,stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -70,8 +70,8 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck) call psb_zilu_fctint(m,a%get_nrows(),a,blck_%get_nrows(),blck_,& & d,l%val,l%ja,l%irp,u%val,u%ja,u%irp,l1,l2,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_zilu_fctint' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -92,8 +92,8 @@ subroutine psb_zilu_fct(a,l,u,d,info,blck) blck_ => null() else call blck_%free() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_free' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -131,11 +131,11 @@ contains name='psb_zilu_fctint' if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ call psb_erractionsave(err_act) call trw%allocate(0,0,1) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -172,11 +172,11 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call a%a%csget(i,i+irb-1,trw,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -271,7 +271,7 @@ contains ! ! Pivot too small: unstable factorization ! - info = 2 + info = psb_err_pivot_too_small_ int_err(1) = i write(ch_err,'(g20.10)') abs(dia) call psb_errpush(info,name,i_err=int_err,a_err=ch_err) @@ -310,12 +310,12 @@ contains class default - if ((mod(i,nrb) == 1).or.(nrb==1)) then + if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(ma-i+1,nrb) call b%a%csget(i-ma,i-ma+irb-1,trw,info) nz = trw%get_nzeros() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='a%csget' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -409,7 +409,7 @@ contains ! int_err(1) = i write(ch_err,'(g20.10)') abs(dia) - info = 2 + info = psb_err_pivot_too_small_ call psb_errpush(info,name,i_err=int_err,a_err=ch_err) goto 9999 else diff --git a/prec/psb_zprc_aply.f90 b/prec/psb_zprc_aply.f90 index 9dfbb5d8a..37ba1782a 100644 --- a/prec/psb_zprc_aply.f90 +++ b/prec/psb_zprc_aply.f90 @@ -51,7 +51,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) character(len=20) :: name name='psb_prc_aply' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) ictxt=desc_data%matrix_data(psb_ctxt_) @@ -67,8 +67,8 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work) work_ => work else allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if @@ -154,7 +154,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) complex(psb_dpk_), pointer :: WW(:), w1(:) character(len=20) :: name name='psb_prc_aply1' - info = 0 + info = psb_success_ call psb_erractionsave(err_act) @@ -172,12 +172,12 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans) goto 9999 end if allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if call prec%prec%apply(zone,x,zzero,ww,desc_data,info,trans_,work=w1) - if(info /=0) goto 9999 + if(info /= psb_success_) goto 9999 x(:) = ww(:) deallocate(ww,W1) diff --git a/prec/psb_zprecbld.f90 b/prec/psb_zprecbld.f90 index f6c7db377..4ac8b263a 100644 --- a/prec/psb_zprecbld.f90 +++ b/prec/psb_zprecbld.f90 @@ -52,12 +52,12 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd) character(len=20) :: name, ch_err if(psb_get_errstatus() /= 0) return - info=0 + info=psb_success_ err=0 call psb_erractionsave(err_act) name = 'psb_precbld' - info = 0 + info = psb_success_ int_err(1) = 0 ictxt = psb_cd_get_context(desc_a) @@ -89,7 +89,7 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd) end if call p%prec%precbld(a,desc_a,info,upd) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/prec/psb_zprecinit.f90 b/prec/psb_zprecinit.f90 index bb5841ad2..fc79ba256 100644 --- a/prec/psb_zprecinit.f90 +++ b/prec/psb_zprecinit.f90 @@ -42,12 +42,12 @@ subroutine psb_zprecinit(p,ptype,info) character(len=*), intent(in) :: ptype integer, intent(out) :: info - info = 0 + info = psb_success_ if (allocated(p%prec) ) then call p%prec%precfree(info) - if (info == 0) deallocate(p%prec,stat=info) - if (info /= 0) return + if (info == psb_success_) deallocate(p%prec,stat=info) + if (info /= psb_success_) return end if select case(psb_toupper(ptype(1:len_trim(ptype)))) @@ -63,9 +63,9 @@ subroutine psb_zprecinit(p,ptype,info) case default write(0,*) 'Unknown preconditioner type request "',ptype,'"' - info = 2 + info = psb_err_pivot_too_small_ end select - if (info == 0) call p%prec%precinit(info) + if (info == psb_success_) call p%prec%precinit(info) end subroutine psb_zprecinit diff --git a/prec/psb_zprecset.f90 b/prec/psb_zprecset.f90 index 853526de0..48a770a33 100644 --- a/prec/psb_zprecset.f90 +++ b/prec/psb_zprecset.f90 @@ -39,7 +39,7 @@ subroutine psb_zprecseti(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") @@ -65,7 +65,7 @@ subroutine psb_zprecsetd(p,what,val,info) integer, intent(out) :: info character(len=20) :: name='precset' - info = 0 + info = psb_success_ if (.not.allocated(p%prec)) then info = 1124 call psb_errpush(info,name,a_err="preconditioner") diff --git a/test/fileread/cf_sample.f90 b/test/fileread/cf_sample.f90 index 94f2b08bb..2e8efed4e 100644 --- a/test/fileread/cf_sample.f90 +++ b/test/fileread/cf_sample.f90 @@ -90,7 +90,7 @@ program cf_sample name='cf_sample' if(psb_get_errstatus() /= 0) goto 9999 - info=0 + info=psb_success_ call psb_set_errverbosity(2) ! ! get parameters @@ -103,13 +103,13 @@ program cf_sample ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 - if (iam==psb_root_) then + if (iam == psb_root_) then select case(psb_toupper(filefmt)) case('MM') ! For Matrix Market we have an input file for the matrix ! and an (optional) second file for the RHS. call mm_mat_read(aux_a,info,iunit=iunit,filename=mtrx_file) - if (info == 0) then + if (info == psb_success_) then if (rhs_file /= 'NONE') then call mm_vet_read(aux_b,info,iunit=iunit,filename=rhs_file) end if @@ -124,7 +124,7 @@ program cf_sample info = -1 write(0,*) 'Wrong choice for fileformat ', filefmt end select - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Error while reading input matrix ' call psb_abort(ictxt) end if @@ -133,7 +133,7 @@ program cf_sample call psb_bcast(ictxt,m_problem) ! At this point aux_b may still be unallocated - if (psb_size(aux_b,dim=1)==m_problem) then + if (psb_size(aux_b,dim=1) == m_problem) then ! if any rhs were present, broadcast the first one write(0,'("Ok, got an rhs ")') b_col_glob =>aux_b(:,1) @@ -142,7 +142,7 @@ program cf_sample write(*,'(" ")') call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif @@ -156,7 +156,7 @@ program cf_sample call psb_bcast(ictxt,m_problem) call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif b_col_glob =>aux_b(:,1) @@ -166,7 +166,7 @@ program cf_sample ! switch over different partition types if (ipart == 0) then call psb_barrier(ictxt) - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') allocate(ivg(m_problem),ipv(np)) do i=1,m_problem call part_block(i,m_problem,np,ipv,nv) @@ -175,7 +175,7 @@ program cf_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else if (ipart == 2) then - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'("Partition type: graph")') write(*,'(" ")') ! write(0,'("Build type: graph")') @@ -188,7 +188,7 @@ program cf_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,parts=part_block) end if @@ -204,7 +204,7 @@ program cf_sample call psb_amx(ictxt, t2) - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'(" ")') write(*,'("Time to read and partition matrix : ",es12.5)')t2 write(*,'(" ")') @@ -218,15 +218,15 @@ program cf_sample t1 = psb_wtime() call psb_precbld(a,desc_a,prec,info) tprec = psb_wtime()-t1 - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_precbld') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld') goto 9999 end if call psb_amx(ictxt,tprec) - if(iam==psb_root_) then + if(iam == psb_root_) then write(*,'("Preconditioner time: ",es12.5)')tprec write(*,'(" ")') end if @@ -250,7 +250,7 @@ program cf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - if (iam==psb_root_) then + if (iam == psb_root_) then call psb_precdescr(prec) write(*,'("Matrix: ",a)')mtrx_file write(*,'("Computed solution on ",i8," processors")')np @@ -274,7 +274,7 @@ program cf_sample else call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) - if (iam==psb_root_) then + if (iam == psb_root_) then write(0,'(" ")') write(0,'("Saving x on file")') write(20,*) 'matrix: ',mtrx_file @@ -301,7 +301,7 @@ program cf_sample call psb_cdfree(desc_a,info) 9999 continue - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if call psb_exit(ictxt) diff --git a/test/fileread/df_sample.f90 b/test/fileread/df_sample.f90 index 562b81411..368c45234 100644 --- a/test/fileread/df_sample.f90 +++ b/test/fileread/df_sample.f90 @@ -90,7 +90,7 @@ program df_sample name='df_sample' if(psb_get_errstatus() /= 0) goto 9999 - info=0 + info=psb_success_ call psb_set_errverbosity(2) ! ! get parameters @@ -103,13 +103,13 @@ program df_sample ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 - if (iam==psb_root_) then + if (iam == psb_root_) then select case(psb_toupper(filefmt)) case('MM') ! For Matrix Market we have an input file for the matrix ! and an (optional) second file for the RHS. call mm_mat_read(aux_a,info,iunit=iunit,filename=mtrx_file) - if (info == 0) then + if (info == psb_success_) then if (rhs_file /= 'NONE') then call mm_vet_read(aux_b,info,iunit=iunit,filename=rhs_file) end if @@ -124,7 +124,7 @@ program df_sample info = -1 write(0,*) 'Wrong choice for fileformat ', filefmt end select - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Error while reading input matrix ' call psb_abort(ictxt) end if @@ -133,7 +133,7 @@ program df_sample call psb_bcast(ictxt,m_problem) ! At this point aux_b may still be unallocated - if (psb_size(aux_b,dim=1)==m_problem) then + if (psb_size(aux_b,dim=1) == m_problem) then ! if any rhs were present, broadcast the first one write(0,'("Ok, got an rhs ")') b_col_glob =>aux_b(:,1) @@ -142,7 +142,7 @@ program df_sample write(*,'(" ")') call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif @@ -158,7 +158,7 @@ program df_sample call psb_bcast(ictxt,m_problem) call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif b_col_glob =>aux_b(:,1) @@ -169,7 +169,7 @@ program df_sample ! switch over different partition types if (ipart == 0) then call psb_barrier(ictxt) - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') allocate(ivg(m_problem),ipv(np)) do i=1,m_problem call part_block(i,m_problem,np,ipv,nv) @@ -178,7 +178,7 @@ program df_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else if (ipart == 2) then - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'("Partition type: graph")') write(*,'(" ")') ! write(0,'("Build type: graph")') @@ -191,7 +191,7 @@ program df_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,parts=part_block) end if @@ -207,7 +207,7 @@ program df_sample call psb_amx(ictxt, t2) - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'(" ")') write(*,'("Time to read and partition matrix : ",es12.5)')t2 write(*,'(" ")') @@ -221,15 +221,15 @@ program df_sample t1 = psb_wtime() call psb_precbld(a,desc_a,prec,info) tprec = psb_wtime()-t1 - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_precbld') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld') goto 9999 end if call psb_amx(ictxt, tprec) - if(iam==psb_root_) then + if(iam == psb_root_) then write(*,'("Preconditioner time: ",es12.5)')tprec write(*,'(" ")') end if @@ -255,7 +255,7 @@ program df_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - if (iam==psb_root_) then + if (iam == psb_root_) then call psb_precdescr(prec) write(*,'("Matrix: ",a)')mtrx_file write(*,'("Computed solution on ",i8," processors")')np @@ -279,7 +279,7 @@ program df_sample else call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) - if (iam==psb_root_) then + if (iam == psb_root_) then write(0,'(" ")') write(0,'("Saving x on file")') write(20,*) 'matrix: ',mtrx_file @@ -306,7 +306,7 @@ program df_sample call psb_cdfree(desc_a,info) 9999 continue - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if call psb_exit(ictxt) diff --git a/test/fileread/getp.f90 b/test/fileread/getp.f90 index 72b06538d..b448b59e4 100644 --- a/test/fileread/getp.f90 +++ b/test/fileread/getp.f90 @@ -52,7 +52,7 @@ contains integer :: inparms(40), ip call psb_info(ictxt,iam,np) - if (iam==0) then + if (iam == 0) then ! Read Input Parameters read(*,*) ip if (ip >= 5) then @@ -153,7 +153,7 @@ contains integer :: inparms(40), ip call psb_info(ictxt,iam,np) - if (iam==0) then + if (iam == 0) then ! Read Input Parameters read(*,*) ip if (ip >= 5) then diff --git a/test/fileread/sf_sample.f90 b/test/fileread/sf_sample.f90 index 48bd2e111..457ac379f 100644 --- a/test/fileread/sf_sample.f90 +++ b/test/fileread/sf_sample.f90 @@ -90,7 +90,7 @@ program sf_sample name='df_sample' if(psb_get_errstatus() /= 0) goto 9999 - info=0 + info=psb_success_ call psb_set_errverbosity(2) ! ! get parameters @@ -103,13 +103,13 @@ program sf_sample ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 - if (iam==psb_root_) then + if (iam == psb_root_) then select case(psb_toupper(filefmt)) case('MM') ! For Matrix Market we have an input file for the matrix ! and an (optional) second file for the RHS. call mm_mat_read(aux_a,info,iunit=iunit,filename=mtrx_file) - if (info == 0) then + if (info == psb_success_) then if (rhs_file /= 'NONE') then call mm_vet_read(aux_b,info,iunit=iunit,filename=rhs_file) end if @@ -124,7 +124,7 @@ program sf_sample info = -1 write(0,*) 'Wrong choice for fileformat ', filefmt end select - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Error while reading input matrix ' call psb_abort(ictxt) end if @@ -133,7 +133,7 @@ program sf_sample call psb_bcast(ictxt,m_problem) ! At this point aux_b may still be unallocated - if (psb_size(aux_b,dim=1)==m_problem) then + if (psb_size(aux_b,dim=1) == m_problem) then ! if any rhs were present, broadcast the first one write(0,'("Ok, got an rhs ")') b_col_glob =>aux_b(:,1) @@ -142,7 +142,7 @@ program sf_sample write(*,'(" ")') call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif @@ -156,7 +156,7 @@ program sf_sample call psb_bcast(ictxt,m_problem) call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif b_col_glob =>aux_b(:,1) @@ -166,7 +166,7 @@ program sf_sample ! switch over different partition types if (ipart == 0) then call psb_barrier(ictxt) - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') allocate(ivg(m_problem),ipv(np)) do i=1,m_problem call part_block(i,m_problem,np,ipv,nv) @@ -175,7 +175,7 @@ program sf_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else if (ipart == 2) then - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'("Partition type: graph")') write(*,'(" ")') ! write(0,'("Build type: graph")') @@ -188,7 +188,7 @@ program sf_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,parts=part_block) end if @@ -204,7 +204,7 @@ program sf_sample call psb_amx(ictxt, t2) - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'(" ")') write(*,'("Time to read and partition matrix : ",es12.5)')t2 write(*,'(" ")') @@ -218,15 +218,15 @@ program sf_sample t1 = psb_wtime() call psb_precbld(a,desc_a,prec,info) tprec = psb_wtime()-t1 - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_precbld') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld') goto 9999 end if call psb_amx(ictxt, tprec) - if(iam==psb_root_) then + if(iam == psb_root_) then write(*,'("Preconditioner time: ",es12.5)')tprec write(*,'(" ")') end if @@ -252,7 +252,7 @@ program sf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - if (iam==psb_root_) then + if (iam == psb_root_) then call psb_precdescr(prec) write(*,'("Matrix: ",a)')mtrx_file write(*,'("Computed solution on ",i8," processors")')np @@ -276,7 +276,7 @@ program sf_sample else call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) - if (iam==psb_root_) then + if (iam == psb_root_) then write(0,'(" ")') write(0,'("Saving x on file")') write(20,*) 'matrix: ',mtrx_file @@ -303,7 +303,7 @@ program sf_sample call psb_cdfree(desc_a,info) 9999 continue - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if call psb_exit(ictxt) diff --git a/test/fileread/zf_sample.f90 b/test/fileread/zf_sample.f90 index 06fb66482..caf4c8151 100644 --- a/test/fileread/zf_sample.f90 +++ b/test/fileread/zf_sample.f90 @@ -90,7 +90,7 @@ program zf_sample name='zf_sample' if(psb_get_errstatus() /= 0) goto 9999 - info=0 + info=psb_success_ call psb_set_errverbosity(2) ! ! get parameters @@ -103,13 +103,13 @@ program zf_sample ! read the input matrix to be processed and (possibly) the rhs nrhs = 1 - if (iam==psb_root_) then + if (iam == psb_root_) then select case(psb_toupper(filefmt)) case('MM') ! For Matrix Market we have an input file for the matrix ! and an (optional) second file for the RHS. call mm_mat_read(aux_a,info,iunit=iunit,filename=mtrx_file) - if (info == 0) then + if (info == psb_success_) then if (rhs_file /= 'NONE') then call mm_vet_read(aux_b,info,iunit=iunit,filename=rhs_file) end if @@ -124,7 +124,7 @@ program zf_sample info = -1 write(0,*) 'Wrong choice for fileformat ', filefmt end select - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Error while reading input matrix ' call psb_abort(ictxt) end if @@ -133,7 +133,7 @@ program zf_sample call psb_bcast(ictxt,m_problem) ! At this point aux_b may still be unallocated - if (psb_size(aux_b,dim=1)==m_problem) then + if (psb_size(aux_b,dim=1) == m_problem) then ! if any rhs were present, broadcast the first one write(0,'("Ok, got an rhs ")') b_col_glob =>aux_b(:,1) @@ -142,7 +142,7 @@ program zf_sample write(*,'(" ")') call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif @@ -156,7 +156,7 @@ program zf_sample call psb_bcast(ictxt,m_problem) call psb_realloc(m_problem,1,aux_b,ircode) if (ircode /= 0) then - call psb_errpush(4000,name) + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 endif b_col_glob =>aux_b(:,1) @@ -166,7 +166,7 @@ program zf_sample ! switch over different partition types if (ipart == 0) then call psb_barrier(ictxt) - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') allocate(ivg(m_problem),ipv(np)) do i=1,m_problem call part_block(i,m_problem,np,ipv,nv) @@ -175,7 +175,7 @@ program zf_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else if (ipart == 2) then - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'("Partition type: graph")') write(*,'(" ")') ! write(0,'("Build type: graph")') @@ -188,7 +188,7 @@ program zf_sample call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,v=ivg) else - if (iam==psb_root_) write(*,'("Partition type: block")') + if (iam == psb_root_) write(*,'("Partition type: block")') call psb_matdist(aux_a, a, ictxt, & & desc_a,b_col_glob,b_col,info,fmt=afmt,parts=part_block) end if @@ -204,7 +204,7 @@ program zf_sample call psb_amx(ictxt, t2) - if (iam==psb_root_) then + if (iam == psb_root_) then write(*,'(" ")') write(*,'("Time to read and partition matrix : ",es12.5)')t2 write(*,'(" ")') @@ -218,15 +218,15 @@ program zf_sample t1 = psb_wtime() call psb_precbld(a,desc_a,prec,info) tprec = psb_wtime()-t1 - if (info /= 0) then - call psb_errpush(4010,name,a_err='psb_precbld') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_precbld') goto 9999 end if call psb_amx(ictxt,tprec) - if(iam==psb_root_) then + if(iam == psb_root_) then write(*,'("Preconditioner time: ",es12.5)')tprec write(*,'(" ")') end if @@ -250,7 +250,7 @@ program zf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - if (iam==psb_root_) then + if (iam == psb_root_) then call psb_precdescr(prec) write(*,'("Matrix: ",a)')mtrx_file write(*,'("Computed solution on ",i8," processors")')np @@ -274,7 +274,7 @@ program zf_sample else call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) call psb_gather(r_col_glob,r_col,desc_a,info,root=psb_root_) - if (iam==psb_root_) then + if (iam == psb_root_) then write(0,'(" ")') write(0,'("Saving x on file")') write(20,*) 'matrix: ',mtrx_file @@ -301,7 +301,7 @@ program zf_sample call psb_cdfree(desc_a,info) 9999 continue - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if call psb_exit(ictxt) diff --git a/test/pargen/ppde.f90 b/test/pargen/ppde.f90 index ef149ebba..979fc53e2 100644 --- a/test/pargen/ppde.f90 +++ b/test/pargen/ppde.f90 @@ -95,9 +95,9 @@ program ppde integer :: info, i character(len=20) :: name,ch_err - info=0 - + info=psb_success_ + call psb_init(ictxt) call psb_info(ictxt,iam,np) @@ -122,8 +122,8 @@ program ppde call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info) call psb_barrier(ictxt) t2 = psb_wtime() - t1 - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='create_matrix' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -139,8 +139,8 @@ program ppde call psb_barrier(ictxt) t1 = psb_wtime() call psb_precbld(a,desc_a,prec,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_precbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -162,8 +162,8 @@ program ppde call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='solver routine' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -200,15 +200,15 @@ program ppde call psb_spfree(a,desc_a,info) call psb_precfree(prec,info) call psb_cdfree(desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='free routine' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if 9999 continue - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if call psb_exit(ictxt) @@ -227,7 +227,7 @@ contains call psb_info(ictxt, iam, np) - if (iam==0) then + if (iam == 0) then read(*,*) ip if (ip >= 3) then read(*,*) kmethd @@ -371,7 +371,7 @@ contains character(len=20) :: name, ch_err,tmpfmt - info = 0 + info = psb_success_ name = 'create_matrix' call psb_erractionsave(err_act) @@ -399,16 +399,16 @@ contains call psb_barrier(ictxt) t0 = psb_wtime() call psb_cdall(ictxt,desc_a,info,nl=nr) - if (info == 0) call psb_spall(a,desc_a,info,nnz=nnz) + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) ! define rhs from boundary conditions; also build initial guess - if (info == 0) call psb_geall(b,desc_a,info) - if (info == 0) call psb_geall(xv,desc_a,info) + if (info == psb_success_) call psb_geall(b,desc_a,info) + if (info == psb_success_) call psb_geall(xv,desc_a,info) nlr = psb_cd_get_local_rows(desc_a) call psb_barrier(ictxt) talc = psb_wtime()-t0 - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='allocation rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -420,8 +420,8 @@ contains ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),myidx(nlr),stat=info) - if (info /= 0 ) then - info=4000 + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -468,7 +468,7 @@ contains ! ! term depending on (x-1,y,z) ! - if (ix==1) then + if (ix == 1) then val(element)=-b1(x,y,z)-a1(x,y,z) val(element) = val(element)/(deltah*& & deltah) @@ -482,7 +482,7 @@ contains element = element+1 endif ! term depending on (x,y-1,z) - if (iy==1) then + if (iy == 1) then val(element)=-b2(x,y,z)-a2(x,y,z) val(element) = val(element)/(deltah*& & deltah) @@ -495,7 +495,7 @@ contains element = element+1 endif ! term depending on (x,y,z-1) - if (iz==1) then + if (iz == 1) then val(element)=-b3(x,y,z)-a3(x,y,z) val(element) = val(element)/(deltah*deltah) zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) @@ -515,7 +515,7 @@ contains irow(element) = glob_row element = element+1 ! term depending on (x,y,z+1) - if (iz==idim) then + if (iz == idim) then val(element)=-b1(x,y,z) val(element) = val(element)/(deltah*deltah) zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) @@ -527,7 +527,7 @@ contains element = element+1 endif ! term depending on (x,y+1,z) - if (iy==idim) then + if (iy == idim) then val(element)=-b2(x,y,z) val(element) = val(element)/(deltah*deltah) zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) @@ -549,17 +549,17 @@ contains end do call psb_spins(element-1,irow,icol,val,a,desc_a,info) - if(info /= 0) exit + if(info /= psb_success_) exit call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),b,desc_a,info) - if(info /= 0) exit + if(info /= psb_success_) exit zt(:)=0.d0 call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= 0) exit + if(info /= psb_success_) exit end do tgen = psb_wtime()-t1 - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='insert rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -570,19 +570,19 @@ contains call psb_barrier(ictxt) t1 = psb_wtime() call psb_cdasb(desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=acsr) call psb_barrier(ictxt) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='asb rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geasb(b,desc_a,info) call psb_geasb(xv,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='asb rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/test/pargen/spde.f90 b/test/pargen/spde.f90 index a9aee94b2..f9ff96afd 100644 --- a/test/pargen/spde.f90 +++ b/test/pargen/spde.f90 @@ -95,7 +95,7 @@ program ppde integer :: info, i character(len=20) :: name,ch_err - info=0 + info=psb_success_ call psb_init(ictxt) @@ -122,8 +122,8 @@ program ppde call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info) call psb_barrier(ictxt) t2 = psb_wtime() - t1 - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='create_matrix' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -139,8 +139,8 @@ program ppde call psb_barrier(ictxt) t1 = psb_wtime() call psb_precbld(a,desc_a,prec,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_precbld' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -162,8 +162,8 @@ program ppde call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,& & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='solver routine' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -200,15 +200,15 @@ program ppde call psb_spfree(a,desc_a,info) call psb_precfree(prec,info) call psb_cdfree(desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='free routine' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if 9999 continue - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if call psb_exit(ictxt) @@ -227,7 +227,7 @@ contains call psb_info(ictxt, iam, np) - if (iam==0) then + if (iam == 0) then read(*,*) ip if (ip >= 3) then read(*,*) kmethd @@ -369,7 +369,7 @@ contains character(len=20) :: name, ch_err,tmpfmt - info = 0 + info = psb_success_ name = 'create_matrix' call psb_erractionsave(err_act) @@ -397,16 +397,16 @@ contains call psb_barrier(ictxt) t0 = psb_wtime() call psb_cdall(ictxt,desc_a,info,nl=nr) - if (info == 0) call psb_spall(a,desc_a,info,nnz=nnz) + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) ! define rhs from boundary conditions; also build initial guess - if (info == 0) call psb_geall(b,desc_a,info) - if (info == 0) call psb_geall(xv,desc_a,info) + if (info == psb_success_) call psb_geall(b,desc_a,info) + if (info == psb_success_) call psb_geall(xv,desc_a,info) nlr = psb_cd_get_local_rows(desc_a) call psb_barrier(ictxt) talc = psb_wtime()-t0 - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='allocation rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -418,8 +418,8 @@ contains ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),myidx(nlr),stat=info) - if (info /= 0 ) then - info=4000 + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -466,7 +466,7 @@ contains ! ! term depending on (x-1,y,z) ! - if (ix==1) then + if (ix == 1) then val(element)=-b1(x,y,z)-a1(x,y,z) val(element) = val(element)/(deltah*& & deltah) @@ -480,7 +480,7 @@ contains element = element+1 endif ! term depending on (x,y-1,z) - if (iy==1) then + if (iy == 1) then val(element)=-b2(x,y,z)-a2(x,y,z) val(element) = val(element)/(deltah*& & deltah) @@ -493,7 +493,7 @@ contains element = element+1 endif ! term depending on (x,y,z-1) - if (iz==1) then + if (iz == 1) then val(element)=-b3(x,y,z)-a3(x,y,z) val(element) = val(element)/(deltah*deltah) zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) @@ -513,7 +513,7 @@ contains irow(element) = glob_row element = element+1 ! term depending on (x,y,z+1) - if (iz==idim) then + if (iz == idim) then val(element)=-b1(x,y,z) val(element) = val(element)/(deltah*deltah) zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) @@ -525,7 +525,7 @@ contains element = element+1 endif ! term depending on (x,y+1,z) - if (iy==idim) then + if (iy == idim) then val(element)=-b2(x,y,z) val(element) = val(element)/(deltah*deltah) zt(k) = exp(-y**2-z**2)*exp(-x)*(-val(element)) @@ -547,17 +547,17 @@ contains end do call psb_spins(element-1,irow,icol,val,a,desc_a,info) - if(info /= 0) exit + if(info /= psb_success_) exit call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),b,desc_a,info) - if(info /= 0) exit + if(info /= psb_success_) exit zt(:)=0.d0 call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) - if(info /= 0) exit + if(info /= psb_success_) exit end do tgen = psb_wtime()-t1 - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='insert rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -568,19 +568,19 @@ contains call psb_barrier(ictxt) t1 = psb_wtime() call psb_cdasb(desc_a,info) - if (info == 0) & + if (info == psb_success_) & & call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=acsr) call psb_barrier(ictxt) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='asb rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geasb(b,desc_a,info) call psb_geasb(xv,desc_a,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='asb rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/test/serial/d_coo_matgen.f03 b/test/serial/d_coo_matgen.f03 index 1099632f6..d36ca76ab 100644 --- a/test/serial/d_coo_matgen.f03 +++ b/test/serial/d_coo_matgen.f03 @@ -35,7 +35,7 @@ program d_coo_matgen integer :: info, err_act character(len=20) :: name,ch_err - info=0 + info=psb_success_ call psb_init(ictxt) @@ -63,7 +63,7 @@ program d_coo_matgen call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info) call psb_barrier(ictxt) t2 = psb_wtime() - t1 - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if @@ -166,7 +166,7 @@ contains character(len=20) :: name, ch_err, asbfmt - info = 0 + info = psb_success_ name = 'create_matrix' call psb_erractionsave(err_act) @@ -204,8 +204,8 @@ contains !!$ write(*,*) 'Test get size:',d_coo_get_size(acoo) !!$ write(*,*) 'Test 2 get size:',acoo%get_size(),acoo%get_nzeros() - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='allocation rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -217,8 +217,8 @@ contains ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),myidx(nlr),stat=info) - if (info /= 0 ) then - info=4000 + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -259,7 +259,7 @@ contains ! ! term depending on (x-1,y,z) ! - if (x==1) then + if (x == 1) then val(element)=-b1(glob_x,glob_y,glob_z)& & -a1(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& @@ -275,7 +275,7 @@ contains element = element+1 endif ! term depending on (x,y-1,z) - if (y==1) then + if (y == 1) then val(element)=-b2(glob_x,glob_y,glob_z)& & -a2(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& @@ -291,7 +291,7 @@ contains element = element+1 endif ! term depending on (x,y,z-1) - if (z==1) then + if (z == 1) then val(element)=-b3(glob_x,glob_y,glob_z)& & -a3(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& @@ -319,7 +319,7 @@ contains irow(element) = glob_row element = element+1 ! term depending on (x,y,z+1) - if (z==idim) then + if (z == idim) then val(element)=-b1(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& & deltah) @@ -333,7 +333,7 @@ contains element = element+1 endif ! term depending on (x,y+1,z) - if (y==idim) then + if (y == idim) then val(element)=-b2(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& & deltah) @@ -362,8 +362,8 @@ contains end do tgen = psb_wtime()-t1 - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='insert rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -375,8 +375,8 @@ contains call acoo%fix(info) !!$ write(0,*) '2 out of loop ',acoo%get_nzeros() - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='asb rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -385,8 +385,8 @@ contains !!$ call acoo%print(20) t1 = psb_wtime() call acsr%cp_from_coo(acoo,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='cp rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -395,8 +395,8 @@ contains !!$ call acsr%print(21) t1 = psb_wtime() call acsr%mv_from_coo(acoo,info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='mv rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/test/serial/d_matgen.f03 b/test/serial/d_matgen.f03 index 94980bb73..989987c00 100644 --- a/test/serial/d_matgen.f03 +++ b/test/serial/d_matgen.f03 @@ -36,7 +36,7 @@ program d_matgen integer :: info, err_act character(len=20) :: name,ch_err - info=0 + info=psb_success_ call psb_init(ictxt) @@ -64,7 +64,7 @@ program d_matgen call create_matrix(idim,a,b,x,desc_a,ictxt,afmt,info) call psb_barrier(ictxt) t2 = psb_wtime() - t1 - if(info /= 0) then + if(info /= psb_success_) then call psb_error(ictxt) end if @@ -170,7 +170,7 @@ contains character(len=20) :: name, ch_err - info = 0 + info = psb_success_ name = 'create_matrix' !!$ call psb_erractionsave(err_act) @@ -205,8 +205,8 @@ contains talc = psb_wtime()-t0 - if (info /= 0) then - info=4010 + if (info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='allocation rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -218,8 +218,8 @@ contains ! allocate(val(20*nb),irow(20*nb),& &icol(20*nb),myidx(nlr),stat=info) - if (info /= 0 ) then - info=4000 + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 endif @@ -259,7 +259,7 @@ contains ! ! term depending on (x-1,y,z) ! - if (x==1) then + if (x == 1) then val(element)=-b1(glob_x,glob_y,glob_z)& & -a1(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& @@ -275,7 +275,7 @@ contains element = element+1 endif ! term depending on (x,y-1,z) - if (y==1) then + if (y == 1) then val(element)=-b2(glob_x,glob_y,glob_z)& & -a2(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& @@ -291,7 +291,7 @@ contains element = element+1 endif ! term depending on (x,y,z-1) - if (z==1) then + if (z == 1) then val(element)=-b3(glob_x,glob_y,glob_z)& & -a3(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& @@ -319,7 +319,7 @@ contains irow(element) = glob_row element = element+1 ! term depending on (x,y,z+1) - if (z==idim) then + if (z == idim) then val(element)=-b1(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& & deltah) @@ -333,7 +333,7 @@ contains element = element+1 endif ! term depending on (x,y+1,z) - if (y==idim) then + if (y == idim) then val(element)=-b2(glob_x,glob_y,glob_z) val(element) = val(element)/(deltah*& & deltah) @@ -362,8 +362,8 @@ contains end do tgen = psb_wtime()-t1 - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='insert rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -372,8 +372,8 @@ contains t1 = psb_wtime() call a_n%cscnv(info,mold=acsr) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='asb rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -384,7 +384,7 @@ contains write(0,*) 'Nrm infinity ',anorm call a_n%csget(2,3,element,irow,icol,val,info) write(0,*) 'From csget ',element,info - if (info == 0) then + if (info == psb_success_) then do i=1,element write(0,*) irow(i),icol(i),val(i) end do @@ -399,15 +399,15 @@ contains allocate(diag(nlr),stat=info) - if (info == 0) then + if (info == psb_success_) then call a_n%get_diag(diag,info) end if !!$ t1 = psb_wtime() call a_n%cscnv(info,mold=acxx) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='asb rout.' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/test/serial/psb_d_cxx_impl.f03 b/test/serial/psb_d_cxx_impl.f03 index cdca88a6c..edf035419 100644 --- a/test/serial/psb_d_cxx_impl.f03 +++ b/test/serial/psb_d_cxx_impl.f03 @@ -1,5 +1,5 @@ -!===================================== +! == =================================== ! ! ! @@ -10,7 +10,7 @@ ! ! ! -!===================================== +! == =================================== subroutine d_cxx_csmv_impl(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -32,7 +32,7 @@ subroutine d_cxx_csmv_impl(alpha,a,x,beta,y,info,trans) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(trans)) then trans_ = trans @@ -47,7 +47,7 @@ subroutine d_cxx_csmv_impl(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() @@ -316,7 +316,7 @@ subroutine d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_cxx_csmm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -330,7 +330,7 @@ subroutine d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) call psb_errpush(info,name) goto 9999 endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') if (tra) then m = a%get_ncols() @@ -343,8 +343,8 @@ subroutine d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) nc = min(size(x,2) , size(y,2) ) allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -607,7 +607,7 @@ subroutine d_cxx_cssv_impl(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_cxx_cssv' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then trans_ = trans @@ -620,7 +620,7 @@ subroutine d_cxx_cssv_impl(alpha,a,x,beta,y,info,trans) goto 9999 endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() if (.not. (a%is_triangle())) then @@ -671,7 +671,7 @@ subroutine d_cxx_cssv_impl(alpha,a,x,beta,y,info,trans) end if else allocate(tmp(m), stat=info) - if (info /= 0) then + if (info /= psb_success_) then return end if @@ -823,7 +823,7 @@ subroutine d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) character(len=20) :: name='d_cxx_cssm' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) if (present(trans)) then @@ -838,7 +838,7 @@ subroutine d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) endif - tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C') + tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() nc = min(size(x,2) , size(y,2)) @@ -871,8 +871,8 @@ subroutine d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) end do else allocate(tmp(m,nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 end if @@ -884,8 +884,8 @@ subroutine d_cxx_cssm_impl(alpha,a,x,beta,y,info,trans) end do end if - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='inner_cxxsm') goto 9999 end if @@ -917,10 +917,10 @@ contains integer :: i,j,k,m, ir, jc real(psb_dpk_), allocatable :: acc(:) - info = 0 + info = psb_success_ allocate(acc(nc), stat=info) - if(info /= 0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ return end if @@ -1046,7 +1046,7 @@ function d_cxx_csnmi_impl(a) result(res) end function d_cxx_csnmi_impl -!===================================== +! == =================================== ! ! ! @@ -1056,7 +1056,7 @@ end function d_cxx_csnmi_impl ! ! ! -!===================================== +! == =================================== subroutine d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& @@ -1085,7 +1085,7 @@ subroutine d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1124,7 +1124,7 @@ subroutine d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1142,7 +1142,7 @@ subroutine d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1186,7 +1186,7 @@ contains irw = imin lrw = min(imax,a%get_nrows()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1201,9 +1201,9 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) - if (info /= 0) return + if (info /= psb_success_) return if (present(iren)) then do i=irw, lrw @@ -1261,7 +1261,7 @@ subroutine d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(jmin)) then jmin_ = jmin @@ -1300,7 +1300,7 @@ subroutine d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& cscale_ = .false. endif if ((rscale_.or.cscale_).and.(present(iren))) then - info = 583 + info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if @@ -1319,7 +1319,7 @@ subroutine d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& end do end if - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1364,7 +1364,7 @@ contains irw = imin lrw = min(imax,a%get_nrows()) if (irw<0) then - info = 2 + info = psb_err_pivot_too_small_ return end if @@ -1379,10 +1379,10 @@ contains call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return + if (info /= psb_success_) return if (present(iren)) then do i=irw, lrw @@ -1434,7 +1434,7 @@ subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) - info = 0 + info = psb_success_ nza = a%get_nzeros() if (a%is_bld()) then @@ -1445,7 +1445,7 @@ subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) call d_cxx_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info,gtl) - if (info /= 0) then + if (info /= psb_success_) then info = 1121 end if @@ -1454,7 +1454,7 @@ subroutine d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) ! State is wrong. info = 1121 end if - if (info /= 0) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -1494,7 +1494,7 @@ contains integer :: debug_level, debug_unit character(len=20) :: name='d_cxx_srch_upd' - info = 0 + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -1693,10 +1693,10 @@ subroutine d_cp_cxx_from_coo_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) - if (info ==0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end subroutine d_cp_cxx_from_coo_impl @@ -1720,7 +1720,7 @@ subroutine d_cp_cxx_to_coo_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -1762,7 +1762,7 @@ subroutine d_mv_cxx_to_coo_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ nr = a%get_nrows() nc = a%get_ncols() @@ -1773,7 +1773,7 @@ subroutine d_mv_cxx_to_coo_impl(a,b,info) call move_alloc(a%ja,b%ja) call move_alloc(a%val,b%val) call psb_realloc(nza,b%ia,info) - if (info /= 0) return + if (info /= psb_success_) return do i=1, nr do j=a%irp(i),a%irp(i+1)-1 b%ia(j) = i @@ -1806,10 +1806,10 @@ subroutine d_mv_cxx_from_coo_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ call b%fix(info) - if (info /= 0) return + if (info /= psb_success_) return nr = b%get_nrows() nc = b%get_ncols() @@ -1896,7 +1896,7 @@ subroutine d_mv_cxx_to_fmt_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_d_coo_sparse_mat) @@ -1911,7 +1911,7 @@ subroutine d_mv_cxx_to_fmt_impl(a,b,info) class default call tmp%mv_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine d_mv_cxx_to_fmt_impl @@ -1936,7 +1936,7 @@ subroutine d_cp_cxx_to_fmt_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) @@ -1951,7 +1951,7 @@ subroutine d_cp_cxx_to_fmt_impl(a,b,info) class default call tmp%cp_from_fmt(a,info) - if (info == 0) call b%mv_from_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) end select end subroutine d_cp_cxx_to_fmt_impl @@ -1976,7 +1976,7 @@ subroutine d_mv_cxx_from_fmt_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_d_coo_sparse_mat) @@ -1991,7 +1991,7 @@ subroutine d_mv_cxx_from_fmt_impl(a,b,info) class default call tmp%mv_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine d_mv_cxx_from_fmt_impl @@ -2017,7 +2017,7 @@ subroutine d_cp_cxx_from_fmt_impl(a,b,info) integer :: debug_level, debug_unit character(len=20) :: name - info = 0 + info = psb_success_ select type (b) type is (psb_d_coo_sparse_mat) @@ -2031,7 +2031,7 @@ subroutine d_cp_cxx_from_fmt_impl(a,b,info) class default call tmp%cp_from_fmt(b,info) - if (info == 0) call a%mv_from_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) end select end subroutine d_cp_cxx_from_fmt_impl diff --git a/test/serial/psb_d_cxx_mat_mod.f03 b/test/serial/psb_d_cxx_mat_mod.f03 index 0b9c129bb..bb4526249 100644 --- a/test/serial/psb_d_cxx_mat_mod.f03 +++ b/test/serial/psb_d_cxx_mat_mod.f03 @@ -252,7 +252,7 @@ module psb_d_cxx_mat_mod contains - !===================================== + ! == =================================== ! ! ! @@ -262,7 +262,7 @@ contains ! ! ! - !===================================== + ! == =================================== function d_cxx_sizeof(a) result(res) @@ -334,7 +334,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -344,7 +344,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine d_cxx_reallocate_nz(nz,a) @@ -360,11 +360,11 @@ contains call psb_erractionsave(err_act) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) - if (info == 0) call psb_realloc(& + if (info == psb_success_) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(& & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) - if (info /= 0) then - call psb_errpush(4000,name) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -399,29 +399,29 @@ contains integer :: nza, i,j,k, nzl, isza, int_err(5) call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (nz <= 0) then - info = 10 + info = psb_err_iarg_neg_ int_err(1)=1 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ia) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=2 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(ja) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=3 call psb_errpush(info,name,i_err=int_err) goto 9999 end if if (size(val) < nz) then - info = 35 + info = psb_err_input_asize_invalid_i_ int_err(1)=4 call psb_errpush(info,name,i_err=int_err) goto 9999 @@ -430,7 +430,7 @@ contains if (nz == 0) return call d_cxx_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -466,12 +466,12 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -510,12 +510,12 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -553,7 +553,7 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(append)) then append_ = append @@ -570,11 +570,11 @@ contains & jmin=jmin, jmax=jmax, iren=iren, append=append_, & & nzin=nzin, rscale=rscale, cscale=cscale) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -610,7 +610,7 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ nzin = 0 if (present(imin)) then @@ -660,12 +660,12 @@ contains & jmin=jmin_, jmax=jmax_, append=.false., & & nzin=nzin, rscale=rscale_, cscale=cscale_) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call b%set_nzeros(nzin+nzout) call b%fix(info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -710,7 +710,7 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (present(clear)) then @@ -756,14 +756,14 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ m = a%get_nrows() nz = a%get_nzeros() - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz,a%ja,info) - if (info == 0) call psb_realloc(nz,a%val,info) + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -792,9 +792,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_cp_cxx_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -824,9 +824,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_cp_cxx_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -857,9 +857,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_cp_cxx_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -889,9 +889,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_cp_cxx_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -922,9 +922,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_mv_cxx_to_coo_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -954,9 +954,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_mv_cxx_from_coo_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -987,9 +987,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_mv_cxx_to_fmt_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1019,9 +1019,9 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call d_mv_cxx_from_fmt_impl(a,b,info) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1051,14 +1051,14 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ if (m < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) goto 9999 endif if (n < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) goto 9999 endif @@ -1068,15 +1068,15 @@ contains nz_ = max(7*m,7*n,1) end if if (nz_ < 0) then - info = 10 + info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) goto 9999 endif - if (info == 0) call psb_realloc(m+1,a%irp,info) - if (info == 0) call psb_realloc(nz_,a%ja,info) - if (info == 0) call psb_realloc(nz_,a%val,info) - if (info == 0) then + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -1195,7 +1195,7 @@ contains call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) @@ -1203,7 +1203,7 @@ contains a%ja = b%ja a%val = b%val - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1232,7 +1232,7 @@ contains logical, parameter :: debug=.false. call psb_erractionsave(err_act) - info = 0 + info = psb_success_ call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) call move_alloc(b%irp, a%irp) call move_alloc(b%ja, a%ja) @@ -1256,7 +1256,7 @@ contains - !===================================== + ! == =================================== ! ! ! @@ -1267,7 +1267,7 @@ contains ! ! ! - !===================================== + ! == =================================== subroutine d_cxx_csmv(alpha,a,x,beta,y,info,trans) @@ -1298,7 +1298,7 @@ contains call d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1337,7 +1337,7 @@ contains call d_cxx_csmm_impl(alpha,a,x,beta,y,info,trans) - if (info /= 0) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1486,12 +1486,12 @@ contains character(len=20) :: name='get_diag' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1500,7 +1500,7 @@ contains do i=1, mnm do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j==i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo @@ -1534,12 +1534,12 @@ contains character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) m = a%get_nrows() if (size(d) < m) then - info=35 + info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) goto 9999 end if @@ -1576,7 +1576,7 @@ contains character(len=20) :: name='scal' logical, parameter :: debug=.false. - info = 0 + info = psb_success_ call psb_erractionsave(err_act) diff --git a/test/torture/psb_mvsv_tester.f90 b/test/torture/psb_mvsv_tester.f90 index 10573758b..5963a75ff 100644 --- a/test/torture/psb_mvsv_tester.f90 +++ b/test/torture/psb_mvsv_tester.f90 @@ -40,14 +40,14 @@ subroutine s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -56,24 +56,24 @@ subroutine s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_ap3_bp1_ix1_iy1 ! @@ -116,14 +116,14 @@ subroutine s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -132,24 +132,24 @@ subroutine s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_ap3_bp1_ix1_iy1 ! @@ -192,14 +192,14 @@ subroutine s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -208,24 +208,24 @@ subroutine s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_ap3_bp1_ix1_iy1 ! @@ -268,14 +268,14 @@ subroutine s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -284,24 +284,24 @@ subroutine s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_ap3_bm0_ix1_iy1 ! @@ -344,14 +344,14 @@ subroutine s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -360,24 +360,24 @@ subroutine s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_ap3_bm0_ix1_iy1 ! @@ -420,14 +420,14 @@ subroutine s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -436,24 +436,24 @@ subroutine s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_ap3_bm0_ix1_iy1 ! @@ -496,14 +496,14 @@ subroutine s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -512,24 +512,24 @@ subroutine s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_ap1_bp1_ix1_iy1 ! @@ -572,14 +572,14 @@ subroutine s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -588,24 +588,24 @@ subroutine s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_ap1_bp1_ix1_iy1 ! @@ -648,14 +648,14 @@ subroutine s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -664,24 +664,24 @@ subroutine s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_ap1_bp1_ix1_iy1 ! @@ -724,14 +724,14 @@ subroutine s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -740,24 +740,24 @@ subroutine s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_ap1_bm0_ix1_iy1 ! @@ -800,14 +800,14 @@ subroutine s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -816,24 +816,24 @@ subroutine s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_ap1_bm0_ix1_iy1 ! @@ -876,14 +876,14 @@ subroutine s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -892,24 +892,24 @@ subroutine s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_ap1_bm0_ix1_iy1 ! @@ -952,14 +952,14 @@ subroutine s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -968,24 +968,24 @@ subroutine s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_am1_bp1_ix1_iy1 ! @@ -1028,14 +1028,14 @@ subroutine s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1044,24 +1044,24 @@ subroutine s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_am1_bp1_ix1_iy1 ! @@ -1104,14 +1104,14 @@ subroutine s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1120,24 +1120,24 @@ subroutine s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_am1_bp1_ix1_iy1 ! @@ -1180,14 +1180,14 @@ subroutine s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1196,24 +1196,24 @@ subroutine s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_am1_bm0_ix1_iy1 ! @@ -1256,14 +1256,14 @@ subroutine s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1272,24 +1272,24 @@ subroutine s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_am1_bm0_ix1_iy1 ! @@ -1332,14 +1332,14 @@ subroutine s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1348,24 +1348,24 @@ subroutine s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_am1_bm0_ix1_iy1 ! @@ -1408,14 +1408,14 @@ subroutine s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1424,24 +1424,24 @@ subroutine s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_am3_bp1_ix1_iy1 ! @@ -1484,14 +1484,14 @@ subroutine s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1500,24 +1500,24 @@ subroutine s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_am3_bp1_ix1_iy1 ! @@ -1560,14 +1560,14 @@ subroutine s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1576,24 +1576,24 @@ subroutine s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_am3_bp1_ix1_iy1 ! @@ -1636,14 +1636,14 @@ subroutine s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1652,24 +1652,24 @@ subroutine s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_usmv_2_n_am3_bm0_ix1_iy1 ! @@ -1712,14 +1712,14 @@ subroutine s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1728,24 +1728,24 @@ subroutine s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_usmv_2_t_am3_bm0_ix1_iy1 ! @@ -1788,14 +1788,14 @@ subroutine s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1804,24 +1804,24 @@ subroutine s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_usmv_2_c_am3_bm0_ix1_iy1 ! @@ -1863,17 +1863,17 @@ subroutine s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1882,24 +1882,24 @@ subroutine s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_ussv_2_n_ap3_bm0_ix1_iy1 ! @@ -1941,18 +1941,18 @@ subroutine s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -1961,24 +1961,24 @@ subroutine s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_ussv_2_t_ap3_bm0_ix1_iy1 ! @@ -2020,18 +2020,18 @@ subroutine s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2040,24 +2040,24 @@ subroutine s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,i,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,i,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_ussv_2_c_ap3_bm0_ix1_iy1 ! @@ -2099,18 +2099,18 @@ subroutine s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2119,24 +2119,24 @@ subroutine s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_ussv_2_n_ap1_bm0_ix1_iy1 ! @@ -2178,18 +2178,18 @@ subroutine s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2198,24 +2198,24 @@ subroutine s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_ussv_2_t_ap1_bm0_ix1_iy1 ! @@ -2257,18 +2257,18 @@ subroutine s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2277,24 +2277,24 @@ subroutine s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_ussv_2_c_ap1_bm0_ix1_iy1 ! @@ -2336,18 +2336,18 @@ subroutine s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2356,24 +2356,24 @@ subroutine s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_ussv_2_n_am1_bm0_ix1_iy1 ! @@ -2415,18 +2415,18 @@ subroutine s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2435,24 +2435,24 @@ subroutine s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_ussv_2_t_am1_bm0_ix1_iy1 ! @@ -2494,18 +2494,18 @@ subroutine s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2514,24 +2514,24 @@ subroutine s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_ussv_2_c_am1_bm0_ix1_iy1 ! @@ -2573,18 +2573,18 @@ subroutine s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2593,24 +2593,24 @@ subroutine s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine s_ussv_2_n_am3_bm0_ix1_iy1 ! @@ -2652,18 +2652,18 @@ subroutine s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2672,24 +2672,24 @@ subroutine s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine s_ussv_2_t_am3_bm0_ix1_iy1 ! @@ -2731,18 +2731,18 @@ subroutine s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2751,24 +2751,24 @@ subroutine s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on s matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine s_ussv_2_c_am3_bm0_ix1_iy1 ! @@ -2811,14 +2811,14 @@ subroutine d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2827,24 +2827,24 @@ subroutine d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_ap3_bp1_ix1_iy1 ! @@ -2887,14 +2887,14 @@ subroutine d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2903,24 +2903,24 @@ subroutine d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_ap3_bp1_ix1_iy1 ! @@ -2963,14 +2963,14 @@ subroutine d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -2979,24 +2979,24 @@ subroutine d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_ap3_bp1_ix1_iy1 ! @@ -3039,14 +3039,14 @@ subroutine d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3055,24 +3055,24 @@ subroutine d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_ap3_bm0_ix1_iy1 ! @@ -3115,14 +3115,14 @@ subroutine d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3131,24 +3131,24 @@ subroutine d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_ap3_bm0_ix1_iy1 ! @@ -3191,14 +3191,14 @@ subroutine d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3207,24 +3207,24 @@ subroutine d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_ap3_bm0_ix1_iy1 ! @@ -3267,14 +3267,14 @@ subroutine d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3283,24 +3283,24 @@ subroutine d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_ap1_bp1_ix1_iy1 ! @@ -3343,14 +3343,14 @@ subroutine d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3359,24 +3359,24 @@ subroutine d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_ap1_bp1_ix1_iy1 ! @@ -3419,14 +3419,14 @@ subroutine d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3435,24 +3435,24 @@ subroutine d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_ap1_bp1_ix1_iy1 ! @@ -3495,14 +3495,14 @@ subroutine d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3511,24 +3511,24 @@ subroutine d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_ap1_bm0_ix1_iy1 ! @@ -3571,14 +3571,14 @@ subroutine d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3587,24 +3587,24 @@ subroutine d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_ap1_bm0_ix1_iy1 ! @@ -3647,14 +3647,14 @@ subroutine d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3663,24 +3663,24 @@ subroutine d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_ap1_bm0_ix1_iy1 ! @@ -3723,14 +3723,14 @@ subroutine d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3739,24 +3739,24 @@ subroutine d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_am1_bp1_ix1_iy1 ! @@ -3799,14 +3799,14 @@ subroutine d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3815,24 +3815,24 @@ subroutine d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_am1_bp1_ix1_iy1 ! @@ -3875,14 +3875,14 @@ subroutine d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3891,24 +3891,24 @@ subroutine d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_am1_bp1_ix1_iy1 ! @@ -3951,14 +3951,14 @@ subroutine d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -3967,24 +3967,24 @@ subroutine d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_am1_bm0_ix1_iy1 ! @@ -4027,14 +4027,14 @@ subroutine d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4043,24 +4043,24 @@ subroutine d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_am1_bm0_ix1_iy1 ! @@ -4103,14 +4103,14 @@ subroutine d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4119,24 +4119,24 @@ subroutine d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_am1_bm0_ix1_iy1 ! @@ -4179,14 +4179,14 @@ subroutine d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4195,24 +4195,24 @@ subroutine d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_am3_bp1_ix1_iy1 ! @@ -4255,14 +4255,14 @@ subroutine d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4271,24 +4271,24 @@ subroutine d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_am3_bp1_ix1_iy1 ! @@ -4331,14 +4331,14 @@ subroutine d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4347,24 +4347,24 @@ subroutine d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_am3_bp1_ix1_iy1 ! @@ -4407,14 +4407,14 @@ subroutine d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4423,24 +4423,24 @@ subroutine d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_usmv_2_n_am3_bm0_ix1_iy1 ! @@ -4483,14 +4483,14 @@ subroutine d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4499,24 +4499,24 @@ subroutine d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_usmv_2_t_am3_bm0_ix1_iy1 ! @@ -4559,14 +4559,14 @@ subroutine d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4575,24 +4575,24 @@ subroutine d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_usmv_2_c_am3_bm0_ix1_iy1 ! @@ -4634,18 +4634,18 @@ subroutine d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4654,24 +4654,24 @@ subroutine d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_ussv_2_n_ap3_bm0_ix1_iy1 ! @@ -4713,18 +4713,18 @@ subroutine d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4733,24 +4733,24 @@ subroutine d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_ussv_2_t_ap3_bm0_ix1_iy1 ! @@ -4792,18 +4792,18 @@ subroutine d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4812,24 +4812,24 @@ subroutine d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_ussv_2_c_ap3_bm0_ix1_iy1 ! @@ -4871,18 +4871,18 @@ subroutine d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4891,24 +4891,24 @@ subroutine d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_ussv_2_n_ap1_bm0_ix1_iy1 ! @@ -4950,18 +4950,18 @@ subroutine d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -4970,24 +4970,24 @@ subroutine d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_ussv_2_t_ap1_bm0_ix1_iy1 ! @@ -5029,18 +5029,18 @@ subroutine d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5049,24 +5049,24 @@ subroutine d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_ussv_2_c_ap1_bm0_ix1_iy1 ! @@ -5108,18 +5108,18 @@ subroutine d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5128,24 +5128,24 @@ subroutine d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_ussv_2_n_am1_bm0_ix1_iy1 ! @@ -5187,18 +5187,18 @@ subroutine d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5207,24 +5207,24 @@ subroutine d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_ussv_2_t_am1_bm0_ix1_iy1 ! @@ -5266,18 +5266,18 @@ subroutine d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5286,24 +5286,24 @@ subroutine d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_ussv_2_c_am1_bm0_ix1_iy1 ! @@ -5345,18 +5345,18 @@ subroutine d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5365,24 +5365,24 @@ subroutine d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine d_ussv_2_n_am3_bm0_ix1_iy1 ! @@ -5424,18 +5424,18 @@ subroutine d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5444,24 +5444,24 @@ subroutine d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine d_ussv_2_t_am3_bm0_ix1_iy1 ! @@ -5503,18 +5503,18 @@ subroutine d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5523,24 +5523,24 @@ subroutine d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on d matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine d_ussv_2_c_am3_bm0_ix1_iy1 ! @@ -5583,14 +5583,14 @@ subroutine c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5599,24 +5599,24 @@ subroutine c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_ap3_bp1_ix1_iy1 ! @@ -5659,14 +5659,14 @@ subroutine c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5675,24 +5675,24 @@ subroutine c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_ap3_bp1_ix1_iy1 ! @@ -5735,14 +5735,14 @@ subroutine c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5751,24 +5751,24 @@ subroutine c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_ap3_bp1_ix1_iy1 ! @@ -5811,14 +5811,14 @@ subroutine c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5827,24 +5827,24 @@ subroutine c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_ap3_bm0_ix1_iy1 ! @@ -5887,14 +5887,14 @@ subroutine c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5903,24 +5903,24 @@ subroutine c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_ap3_bm0_ix1_iy1 ! @@ -5963,14 +5963,14 @@ subroutine c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -5979,24 +5979,24 @@ subroutine c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_ap3_bm0_ix1_iy1 ! @@ -6039,14 +6039,14 @@ subroutine c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6055,24 +6055,24 @@ subroutine c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_ap1_bp1_ix1_iy1 ! @@ -6115,14 +6115,14 @@ subroutine c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6131,24 +6131,24 @@ subroutine c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_ap1_bp1_ix1_iy1 ! @@ -6191,14 +6191,14 @@ subroutine c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6207,24 +6207,24 @@ subroutine c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_ap1_bp1_ix1_iy1 ! @@ -6267,14 +6267,14 @@ subroutine c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6283,24 +6283,24 @@ subroutine c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_ap1_bm0_ix1_iy1 ! @@ -6343,14 +6343,14 @@ subroutine c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6359,24 +6359,24 @@ subroutine c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_ap1_bm0_ix1_iy1 ! @@ -6419,14 +6419,14 @@ subroutine c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6435,24 +6435,24 @@ subroutine c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_ap1_bm0_ix1_iy1 ! @@ -6495,14 +6495,14 @@ subroutine c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6511,24 +6511,24 @@ subroutine c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_am1_bp1_ix1_iy1 ! @@ -6571,14 +6571,14 @@ subroutine c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6587,24 +6587,24 @@ subroutine c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_am1_bp1_ix1_iy1 ! @@ -6647,14 +6647,14 @@ subroutine c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6663,24 +6663,24 @@ subroutine c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_am1_bp1_ix1_iy1 ! @@ -6723,14 +6723,14 @@ subroutine c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6739,24 +6739,24 @@ subroutine c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_am1_bm0_ix1_iy1 ! @@ -6799,14 +6799,14 @@ subroutine c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6815,24 +6815,24 @@ subroutine c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_am1_bm0_ix1_iy1 ! @@ -6875,14 +6875,14 @@ subroutine c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6891,24 +6891,24 @@ subroutine c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_am1_bm0_ix1_iy1 ! @@ -6951,14 +6951,14 @@ subroutine c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -6967,24 +6967,24 @@ subroutine c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_am3_bp1_ix1_iy1 ! @@ -7027,14 +7027,14 @@ subroutine c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7043,24 +7043,24 @@ subroutine c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_am3_bp1_ix1_iy1 ! @@ -7103,14 +7103,14 @@ subroutine c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7119,24 +7119,24 @@ subroutine c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_am3_bp1_ix1_iy1 ! @@ -7179,14 +7179,14 @@ subroutine c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7195,24 +7195,24 @@ subroutine c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_usmv_2_n_am3_bm0_ix1_iy1 ! @@ -7255,14 +7255,14 @@ subroutine c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7271,24 +7271,24 @@ subroutine c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_usmv_2_t_am3_bm0_ix1_iy1 ! @@ -7331,14 +7331,14 @@ subroutine c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7347,24 +7347,24 @@ subroutine c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_usmv_2_c_am3_bm0_ix1_iy1 ! @@ -7406,18 +7406,18 @@ subroutine c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7426,24 +7426,24 @@ subroutine c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_ussv_2_n_ap3_bm0_ix1_iy1 ! @@ -7485,18 +7485,18 @@ subroutine c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7505,24 +7505,24 @@ subroutine c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_ussv_2_t_ap3_bm0_ix1_iy1 ! @@ -7564,18 +7564,18 @@ subroutine c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7584,24 +7584,24 @@ subroutine c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_ussv_2_c_ap3_bm0_ix1_iy1 ! @@ -7643,18 +7643,18 @@ subroutine c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7663,24 +7663,24 @@ subroutine c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_ussv_2_n_ap1_bm0_ix1_iy1 ! @@ -7722,18 +7722,18 @@ subroutine c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7742,24 +7742,24 @@ subroutine c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_ussv_2_t_ap1_bm0_ix1_iy1 ! @@ -7801,18 +7801,18 @@ subroutine c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7821,24 +7821,24 @@ subroutine c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_ussv_2_c_ap1_bm0_ix1_iy1 ! @@ -7880,18 +7880,18 @@ subroutine c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7900,24 +7900,24 @@ subroutine c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_ussv_2_n_am1_bm0_ix1_iy1 ! @@ -7959,18 +7959,18 @@ subroutine c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -7979,24 +7979,24 @@ subroutine c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_ussv_2_t_am1_bm0_ix1_iy1 ! @@ -8038,18 +8038,18 @@ subroutine c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8058,24 +8058,24 @@ subroutine c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_ussv_2_c_am1_bm0_ix1_iy1 ! @@ -8117,18 +8117,18 @@ subroutine c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8137,24 +8137,24 @@ subroutine c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine c_ussv_2_n_am3_bm0_ix1_iy1 ! @@ -8196,18 +8196,18 @@ subroutine c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8216,24 +8216,24 @@ subroutine c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine c_ussv_2_t_am3_bm0_ix1_iy1 ! @@ -8275,18 +8275,18 @@ subroutine c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8295,24 +8295,24 @@ subroutine c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on c matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine c_ussv_2_c_am3_bm0_ix1_iy1 ! @@ -8355,14 +8355,14 @@ subroutine z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8371,24 +8371,24 @@ subroutine z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_ap3_bp1_ix1_iy1 ! @@ -8431,14 +8431,14 @@ subroutine z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8447,24 +8447,24 @@ subroutine z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_ap3_bp1_ix1_iy1 ! @@ -8507,14 +8507,14 @@ subroutine z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8523,24 +8523,24 @@ subroutine z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_ap3_bp1_ix1_iy1 ! @@ -8583,14 +8583,14 @@ subroutine z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8599,24 +8599,24 @@ subroutine z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_ap3_bm0_ix1_iy1 ! @@ -8659,14 +8659,14 @@ subroutine z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8675,24 +8675,24 @@ subroutine z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_ap3_bm0_ix1_iy1 ! @@ -8735,14 +8735,14 @@ subroutine z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8751,24 +8751,24 @@ subroutine z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_ap3_bm0_ix1_iy1 ! @@ -8811,14 +8811,14 @@ subroutine z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8827,24 +8827,24 @@ subroutine z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_ap1_bp1_ix1_iy1 ! @@ -8887,14 +8887,14 @@ subroutine z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8903,24 +8903,24 @@ subroutine z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_ap1_bp1_ix1_iy1 ! @@ -8963,14 +8963,14 @@ subroutine z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -8979,24 +8979,24 @@ subroutine z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_ap1_bp1_ix1_iy1 ! @@ -9039,14 +9039,14 @@ subroutine z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9055,24 +9055,24 @@ subroutine z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_ap1_bm0_ix1_iy1 ! @@ -9115,14 +9115,14 @@ subroutine z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9131,24 +9131,24 @@ subroutine z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_ap1_bm0_ix1_iy1 ! @@ -9191,14 +9191,14 @@ subroutine z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9207,24 +9207,24 @@ subroutine z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_ap1_bm0_ix1_iy1 ! @@ -9267,14 +9267,14 @@ subroutine z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9283,24 +9283,24 @@ subroutine z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_am1_bp1_ix1_iy1 ! @@ -9343,14 +9343,14 @@ subroutine z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9359,24 +9359,24 @@ subroutine z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_am1_bp1_ix1_iy1 ! @@ -9419,14 +9419,14 @@ subroutine z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9435,24 +9435,24 @@ subroutine z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_am1_bp1_ix1_iy1 ! @@ -9495,14 +9495,14 @@ subroutine z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9511,24 +9511,24 @@ subroutine z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_am1_bm0_ix1_iy1 ! @@ -9571,14 +9571,14 @@ subroutine z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9587,24 +9587,24 @@ subroutine z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_am1_bm0_ix1_iy1 ! @@ -9647,14 +9647,14 @@ subroutine z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9663,24 +9663,24 @@ subroutine z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_am1_bm0_ix1_iy1 ! @@ -9723,14 +9723,14 @@ subroutine z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9739,24 +9739,24 @@ subroutine z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_am3_bp1_ix1_iy1 ! @@ -9799,14 +9799,14 @@ subroutine z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9815,24 +9815,24 @@ subroutine z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_am3_bp1_ix1_iy1 ! @@ -9875,14 +9875,14 @@ subroutine z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9891,24 +9891,24 @@ subroutine z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 1 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_am3_bp1_ix1_iy1 ! @@ -9951,14 +9951,14 @@ subroutine z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -9967,24 +9967,24 @@ subroutine z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_usmv_2_n_am3_bm0_ix1_iy1 ! @@ -10027,14 +10027,14 @@ subroutine z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10043,24 +10043,24 @@ subroutine z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_usmv_2_t_am3_bm0_ix1_iy1 ! @@ -10103,14 +10103,14 @@ subroutine z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10119,24 +10119,24 @@ subroutine z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spmm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 usmv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_usmv_2_c_am3_bm0_ix1_iy1 ! @@ -10178,18 +10178,18 @@ subroutine z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10198,24 +10198,24 @@ subroutine z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_ussv_2_n_ap3_bm0_ix1_iy1 ! @@ -10257,18 +10257,18 @@ subroutine z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10277,24 +10277,24 @@ subroutine z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_ussv_2_t_ap3_bm0_ix1_iy1 ! @@ -10336,18 +10336,18 @@ subroutine z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10356,24 +10356,24 @@ subroutine z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_ussv_2_c_ap3_bm0_ix1_iy1 ! @@ -10415,18 +10415,18 @@ subroutine z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10435,24 +10435,24 @@ subroutine z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_ussv_2_n_ap1_bm0_ix1_iy1 ! @@ -10494,18 +10494,18 @@ subroutine z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10514,24 +10514,24 @@ subroutine z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_ussv_2_t_ap1_bm0_ix1_iy1 ! @@ -10573,18 +10573,18 @@ subroutine z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10593,24 +10593,24 @@ subroutine z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha= 1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_ussv_2_c_ap1_bm0_ix1_iy1 ! @@ -10652,18 +10652,18 @@ subroutine z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10672,24 +10672,24 @@ subroutine z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_ussv_2_n_am1_bm0_ix1_iy1 ! @@ -10731,18 +10731,18 @@ subroutine z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10751,24 +10751,24 @@ subroutine z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_ussv_2_t_am1_bm0_ix1_iy1 ! @@ -10810,18 +10810,18 @@ subroutine z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10830,24 +10830,24 @@ subroutine z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-1 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_ussv_2_c_am1_bm0_ix1_iy1 ! @@ -10889,18 +10889,18 @@ subroutine z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10909,24 +10909,24 @@ subroutine z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=n is ok" end subroutine z_ussv_2_n_am3_bm0_ix1_iy1 ! @@ -10968,18 +10968,18 @@ subroutine z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -10988,24 +10988,24 @@ subroutine z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=t is ok" end subroutine z_ussv_2_t_am3_bm0_ix1_iy1 ! @@ -11047,18 +11047,18 @@ subroutine z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) endif call psb_barrier(ictxt) call psb_cdall(ictxt,desc_a,info,nl=m) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spall(a,desc_a,info,nnz=nnz) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call a%set_triangle() call a%set_lower() call a%set_unit(.false.) call psb_barrier(ictxt) call psb_spins(nnz,IA,JA,VA,a,desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_cdasb(desc_a,info) - if (info /= 0)goto 9996 + if (info /= psb_success_)goto 9996 call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) if(info.ne.0)print *,"matrix assembly failed" if(info.ne.0)goto 9996 @@ -11067,23 +11067,23 @@ subroutine z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) if(info.ne.0)print *,"psb_spsm failed" if(info.ne.0)goto 9996 do i=1,2 - if(y(i)/=cy(i))print*,"results mismatch:",y,"instead of",cy - if(y(i)/=cy(i))info=-1 - if(y(i)/=cy(i))goto 9996 + if(y(i) /= cy(i))print*,"results mismatch:",y,"instead of",cy + if(y(i) /= cy(i))info=-1 + if(y(i) /= cy(i))goto 9996 enddo 9996 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_spfree(a,desc_a,info) - if (info /= 0)goto 9997 + if (info /= psb_success_)goto 9997 9997 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 call psb_cdfree(desc_a,info) - if (info /= 0)goto 9998 + if (info /= psb_success_)goto 9998 9998 continue - if(info /= 0)res=res+1 + if(info /= psb_success_)res=res+1 9999 continue - if(info /= 0)res=res+1 - if(res/=0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" - if(res==0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" + if(info /= psb_success_)res=res+1 + if(res /= 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is not ok" + if(res == 0)print*,"on z matrix 2 x 2 blocked 1 x 1 ussv alpha=-3 beta= 0 incx=1 incy=1 trans=c is ok" end subroutine z_ussv_2_c_am3_bm0_ix1_iy1 end module psb_mvsv_tester diff --git a/test/torture/psbtf.f90 b/test/torture/psbtf.f90 index aedb22922..bb64a51c1 100644 --- a/test/torture/psbtf.f90 +++ b/test/torture/psbtf.f90 @@ -24,722 +24,722 @@ program main goto 9999 endif call s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 call z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt) - if(res/=0)failed=failed+1 + if(res /= 0)failed=failed+1 if(res.eq.0)passed=passed+1 res=0 diff --git a/util/psb_hbio_impl.f90 b/util/psb_hbio_impl.f90 index 13d1bae84..034d98db9 100644 --- a/util/psb_hbio_impl.f90 +++ b/util/psb_hbio_impl.f90 @@ -54,7 +54,7 @@ subroutine shb_read(a, iret, iunit, filename,b,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -158,8 +158,8 @@ subroutine shb_read(a, iret, iunit, filename,b,g,x,mtitle) end do call acoo%set_nzeros(nzr) call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 else write(0,*) 'read_matrix: matrix type not yet supported' @@ -171,7 +171,7 @@ subroutine shb_read(a, iret, iunit, filename,b,g,x,mtitle) end if call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return @@ -220,7 +220,7 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then @@ -258,7 +258,7 @@ subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) class default call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return + if (iret /= 0) return acpnt => acsc end select @@ -353,7 +353,7 @@ subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -457,8 +457,8 @@ subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle) end do call acoo%set_nzeros(nzr) call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 else write(0,*) 'read_matrix: matrix type not yet supported' @@ -470,7 +470,7 @@ subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle) end if call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return @@ -519,7 +519,7 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then @@ -557,7 +557,7 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) class default call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return + if (iret /= 0) return acpnt => acsc end select @@ -653,7 +653,7 @@ subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -757,8 +757,8 @@ subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) end do call acoo%set_nzeros(nzr) call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 else if (psb_tolower(type(2:2)) == 'h') then @@ -804,8 +804,8 @@ subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) end do call acoo%set_nzeros(nzr) call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 else write(0,*) 'read_matrix: matrix type not yet supported' @@ -817,7 +817,7 @@ subroutine chb_read(a, iret, iunit, filename,b,g,x,mtitle) end if call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return @@ -866,7 +866,7 @@ subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then @@ -904,7 +904,7 @@ subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) class default call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return + if (iret /= 0) return acpnt => acsc end select @@ -999,7 +999,7 @@ subroutine zhb_read(a, iret, iunit, filename,b,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -1103,8 +1103,8 @@ subroutine zhb_read(a, iret, iunit, filename,b,g,x,mtitle) end do call acoo%set_nzeros(nzr) call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 else if (psb_tolower(type(2:2)) == 'h') then @@ -1150,8 +1150,8 @@ subroutine zhb_read(a, iret, iunit, filename,b,g,x,mtitle) end do call acoo%set_nzeros(nzr) call acoo%fix(ircode) - if (ircode==0) call a%mv_from(acoo) - if (ircode/=0) goto 993 + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 else write(0,*) 'read_matrix: matrix type not yet supported' @@ -1163,7 +1163,7 @@ subroutine zhb_read(a, iret, iunit, filename,b,g,x,mtitle) end if call a%cscnv(ircode,type='csr') - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return @@ -1212,7 +1212,7 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) iret = 0 if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then @@ -1250,7 +1250,7 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) class default call acsc%cp_from_fmt(aa, iret) - if (iret/=0) return + if (iret /= 0) return acpnt => acsc end select diff --git a/util/psb_mat_dist_impl.f90 b/util/psb_mat_dist_impl.f90 index 4b0edb327..552b7f2b6 100644 --- a/util/psb_mat_dist_impl.f90 +++ b/util/psb_mat_dist_impl.f90 @@ -38,7 +38,7 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers @@ -127,7 +127,7 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 character(len=20) :: name, ch_err - info = 0 + info = psb_success_ err = 0 name = 'mat_distf' call psb_erractionsave(err_act) @@ -155,7 +155,7 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& use_parts = present(parts) use_v = present(v) if (count((/ use_parts, use_v /)) /= 1) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name,a_err=" v, parts") goto 9999 endif @@ -167,8 +167,8 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& call psb_bcast(ictxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=liwork call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -182,22 +182,22 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& else call psb_cdall(ictxt,desc_a,info,vg=v) end if - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psspall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psdsall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -207,8 +207,8 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& isize = 3*nb*max(((nnzero+nrow)/nrow),nb) allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -255,7 +255,7 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& do i= i_count, j_count-1 call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -267,16 +267,16 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& if (iproc == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_ins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -299,8 +299,8 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& write(0,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -313,16 +313,16 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -343,7 +343,7 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& do i= i_count, i_count call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -356,16 +356,16 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& if (k_count == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -387,16 +387,16 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -418,8 +418,8 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_cdasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -429,8 +429,8 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) t3 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_spasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -443,15 +443,15 @@ subroutine smatdist(a_glob, a, ictxt, desc_a,& end if call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psdsasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='deallocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -483,7 +483,7 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers @@ -572,7 +572,7 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 character(len=20) :: name, ch_err - info = 0 + info = psb_success_ err = 0 name = 'mat_distf' call psb_erractionsave(err_act) @@ -600,7 +600,7 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& use_parts = present(parts) use_v = present(v) if (count((/ use_parts, use_v /)) /= 1) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name,a_err=" v, parts") goto 9999 endif @@ -612,8 +612,8 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& call psb_bcast(ictxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=liwork call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -627,22 +627,22 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& else call psb_cdall(ictxt,desc_a,info,vg=v) end if - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psspall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psdsall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -652,8 +652,8 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& isize = 3*nb*max(((nnzero+nrow)/nrow),nb) allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -700,7 +700,7 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& do i= i_count, j_count-1 call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -712,16 +712,16 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& if (iproc == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_ins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -744,8 +744,8 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& write(0,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -758,16 +758,16 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -788,7 +788,7 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& do i= i_count, i_count call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -801,16 +801,16 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& if (k_count == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -832,16 +832,16 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -863,8 +863,8 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_cdasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -874,8 +874,8 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) t3 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_spasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -888,15 +888,15 @@ subroutine dmatdist(a_glob, a, ictxt, desc_a,& end if call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psdsasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='deallocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -928,7 +928,7 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers @@ -1017,7 +1017,7 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 character(len=20) :: name, ch_err - info = 0 + info = psb_success_ err = 0 name = 'mat_distf' call psb_erractionsave(err_act) @@ -1045,7 +1045,7 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& use_parts = present(parts) use_v = present(v) if (count((/ use_parts, use_v /)) /= 1) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name,a_err=" v, parts") goto 9999 endif @@ -1057,8 +1057,8 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& call psb_bcast(ictxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=liwork call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -1072,22 +1072,22 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& else call psb_cdall(ictxt,desc_a,info,vg=v) end if - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psspall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psdsall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1097,8 +1097,8 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& isize = 3*nb*max(((nnzero+nrow)/nrow),nb) allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1145,7 +1145,7 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& do i= i_count, j_count-1 call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -1157,16 +1157,16 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& if (iproc == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_ins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1189,8 +1189,8 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& write(0,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1203,16 +1203,16 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1233,7 +1233,7 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& do i= i_count, i_count call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -1246,16 +1246,16 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& if (k_count == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1277,16 +1277,16 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1308,8 +1308,8 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_cdasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1319,8 +1319,8 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) t3 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_spasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1333,15 +1333,15 @@ subroutine cmatdist(a_glob, a, ictxt, desc_a,& end if call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psdsasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='deallocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1373,7 +1373,7 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers @@ -1462,7 +1462,7 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 character(len=20) :: name, ch_err - info = 0 + info = psb_success_ err = 0 name = 'mat_distf' call psb_erractionsave(err_act) @@ -1490,7 +1490,7 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& use_parts = present(parts) use_v = present(v) if (count((/ use_parts, use_v /)) /= 1) then - info=581 + info=psb_err_no_optional_arg_ call psb_errpush(info,name,a_err=" v, parts") goto 9999 endif @@ -1502,8 +1502,8 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& call psb_bcast(ictxt,nrhs, root) liwork = max(np, nrow + ncol) allocate(iwork(liwork), stat = info) - if (info /= 0) then - info=4025 + if (info /= psb_success_) then + info=psb_err_alloc_request_ int_err(1)=liwork call psb_errpush(info,name,i_err=int_err,a_err='integer') goto 9999 @@ -1517,22 +1517,22 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& else call psb_cdall(ictxt,desc_a,info,vg=v) end if - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_cdall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_spall(a,desc_a,info,nnz=((nnzero+np-1)/np)) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psspall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geall(b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_psdsall' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1542,8 +1542,8 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& isize = 3*nb*max(((nnzero+nrow)/nrow),nb) allocate(val(isize),irow(isize),icol(isize),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1590,7 +1590,7 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& do i= i_count, j_count-1 call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -1602,16 +1602,16 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& if (iproc == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_spins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,j_count-1)/),b_glob(i_count:j_count-1),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psb_ins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1634,8 +1634,8 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& write(0,*) iam,'need to reallocate ',ll deallocate(val,irow,icol) allocate(val(ll),irow(ll),icol(ll),stat=info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='Allocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1648,16 +1648,16 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count:i_count+nnr-1),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(nnr,(/(i,i=i_count,i_count+nnr-1)/),& & b_glob(i_count:i_count+nnr-1),b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1678,7 +1678,7 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& do i= i_count, i_count call a_glob%csget(i,i,nz,& & irow,icol,val,info,nzin=ll,append=.true.) - if (info /= 0) then + if (info /= psb_success_) then if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then write(0,*) 'Allocation failure? This should not happen!' end if @@ -1691,16 +1691,16 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& if (k_count == iam) then call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1722,16 +1722,16 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& call psb_rcv(ictxt,b_glob(i_count),root) call psb_snd(ictxt,ll,root) call psb_spins(ll,irow,icol,val,a,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psspins' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if call psb_geins(1,(/i_count/),b_glob(i_count:i_count),& & b,desc_a,info) - if(info/=0) then - info=4010 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ch_err='psdsins' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1753,8 +1753,8 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& t0 = psb_wtime() call psb_cdasb(desc_a,info) t1 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_cdasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1764,8 +1764,8 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& t2 = psb_wtime() call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) t3 = psb_wtime() - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psb_spasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 @@ -1778,15 +1778,15 @@ subroutine zmatdist(a_glob, a, ictxt, desc_a,& end if call psb_geasb(b,desc_a,info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='psdsasb' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if deallocate(val,irow,icol,stat=info) - if(info/=0)then - info=4010 + if(info /= psb_success_)then + info=psb_err_from_subroutine_ ch_err='deallocate' call psb_errpush(info,name,a_err=ch_err) goto 9999 diff --git a/util/psb_mat_dist_mod.f90 b/util/psb_mat_dist_mod.f90 index 92675725b..7f21d75a7 100644 --- a/util/psb_mat_dist_mod.f90 +++ b/util/psb_mat_dist_mod.f90 @@ -41,7 +41,7 @@ module psb_mat_dist_mod ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers @@ -125,7 +125,7 @@ module psb_mat_dist_mod ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers @@ -210,7 +210,7 @@ module psb_mat_dist_mod ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers @@ -295,7 +295,7 @@ module psb_mat_dist_mod ! ! type(d_spmat) :: a_glob ! on entry: this contains the global sparse matrix as follows: - ! a%fida =='csr' + ! a%fida == 'csr' ! a%aspk for coefficient values ! a%ia1 for column indices ! a%ia2 for row pointers diff --git a/util/psb_metispart_mod.F90 b/util/psb_metispart_mod.F90 index 6f4743802..6575a9503 100644 --- a/util/psb_metispart_mod.F90 +++ b/util/psb_metispart_mod.F90 @@ -114,7 +114,7 @@ contains call psb_bcast(ictxt,n,root=root) allocate(graph_vect(n),stat=info) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Fatal error in DISTR_MTPART: memory allocation ',& & ' failure.' return @@ -223,7 +223,7 @@ contains allocate(graph_vect(n),stat=info) - if (info /= 0) then + if (info /= psb_success_) then write(0,*) 'Fatal error in BUILD_MTPART: memory allocation ',& & ' failure.' return diff --git a/util/psb_mmio_impl.f90 b/util/psb_mmio_impl.f90 index 81f850663..2a33e6319 100644 --- a/util/psb_mmio_impl.f90 +++ b/util/psb_mmio_impl.f90 @@ -40,9 +40,9 @@ subroutine mm_svet_read(b, info, iunit, filename) character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& & line*1024 - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -82,7 +82,7 @@ subroutine mm_svet_read(b, info, iunit, filename) end if ! read right hand sides - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -112,9 +112,9 @@ subroutine mm_dvet_read(b, info, iunit, filename) character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& & line*1024 - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -153,7 +153,7 @@ subroutine mm_dvet_read(b, info, iunit, filename) read(infile,fmt=*,end=902) ((b(i,j), i=1,nrow),j=1,ncol) end if ! read right hand sides - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -184,9 +184,9 @@ subroutine mm_cvet_read(b, info, iunit, filename) character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& & line*1024 - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -230,7 +230,7 @@ subroutine mm_cvet_read(b, info, iunit, filename) end do end if ! read right hand sides - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -261,9 +261,9 @@ subroutine mm_zvet_read(b, info, iunit, filename) character :: mmheader*15, fmt*15, object*10, type*10, sym*15,& & line*1024 - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -307,7 +307,7 @@ subroutine mm_zvet_read(b, info, iunit, filename) end do end if ! read right hand sides - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -337,9 +337,9 @@ subroutine mm_svet2_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -393,9 +393,9 @@ subroutine mm_svet1_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -450,9 +450,9 @@ subroutine mm_dvet2_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -506,9 +506,9 @@ subroutine mm_dvet1_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -563,9 +563,9 @@ subroutine mm_cvet2_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -619,9 +619,9 @@ subroutine mm_cvet1_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -675,9 +675,9 @@ subroutine mm_zvet2_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -731,9 +731,9 @@ subroutine mm_zvet1_write(b, header, info, iunit, filename) character(len=80) :: frmtv - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then outfile=6 else if (present(iunit)) then @@ -789,10 +789,10 @@ subroutine smm_mat_read(a, info, iunit, filename) integer :: ircode, i,nzr,infile type(psb_s_coo_sparse_mat), allocatable :: acoo - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -812,7 +812,7 @@ subroutine smm_mat_read(a, info, iunit, filename) read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then write(0,*) 'READ_MATRIX: input file type not yet supported' info=909 return @@ -865,7 +865,7 @@ subroutine smm_mat_read(a, info, iunit, filename) end if - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -892,10 +892,10 @@ subroutine smm_mat_write(a,mtitle,info,iunit,filename) integer :: iout - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then @@ -939,10 +939,10 @@ subroutine dmm_mat_read(a, info, iunit, filename) integer :: ircode, i,nzr,infile type(psb_d_coo_sparse_mat), allocatable :: acoo - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -962,7 +962,7 @@ subroutine dmm_mat_read(a, info, iunit, filename) read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then write(0,*) 'READ_MATRIX: input file type not yet supported' info=909 return @@ -1013,7 +1013,7 @@ subroutine dmm_mat_read(a, info, iunit, filename) write(0,*) 'read_matrix: matrix type not yet supported' info=904 end if - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -1040,10 +1040,10 @@ subroutine dmm_mat_write(a,mtitle,info,iunit,filename) integer :: iout - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then @@ -1087,10 +1087,10 @@ subroutine cmm_mat_read(a, info, iunit, filename) integer :: ircode, i,nzr,infile type(psb_c_coo_sparse_mat), allocatable :: acoo real(psb_spk_) :: are, aim - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -1110,7 +1110,7 @@ subroutine cmm_mat_read(a, info, iunit, filename) read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then write(0,*) 'READ_MATRIX: input file type not yet supported' info=909 return @@ -1186,7 +1186,7 @@ subroutine cmm_mat_read(a, info, iunit, filename) write(0,*) 'read_matrix: matrix type not yet supported' info=904 end if - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -1213,10 +1213,10 @@ subroutine cmm_mat_write(a,mtitle,info,iunit,filename) integer :: iout - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then @@ -1260,10 +1260,10 @@ subroutine zmm_mat_read(a, info, iunit, filename) integer :: ircode, i,nzr,infile type(psb_z_coo_sparse_mat), allocatable :: acoo real(psb_dpk_) :: are, aim - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then infile=5 else if (present(iunit)) then @@ -1283,7 +1283,7 @@ subroutine zmm_mat_read(a, info, iunit, filename) read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym - if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt)/='coordinate')) then + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then write(0,*) 'READ_MATRIX: input file type not yet supported' info=909 return @@ -1359,7 +1359,7 @@ subroutine zmm_mat_read(a, info, iunit, filename) write(0,*) 'read_matrix: matrix type not yet supported' info=904 end if - if (infile/=5) close(infile) + if (infile /= 5) close(infile) return ! open failed @@ -1386,10 +1386,10 @@ subroutine zmm_mat_write(a,mtitle,info,iunit,filename) integer :: iout - info = 0 + info = psb_success_ if (present(filename)) then - if (filename=='-') then + if (filename == '-') then iout=6 else if (present(iunit)) then