From 8309d08f722f6e11c2e3d2b0443fda66a01215da Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 26 Sep 2013 16:50:34 +0000 Subject: [PATCH] psblas-3.99 base/modules/psb_c_vect_mod.F90 base/modules/psb_d_vect_mod.F90 base/modules/psb_s_vect_mod.F90 base/modules/psb_z_vect_mod.F90 base/psblas/psb_cspmm.f90 base/psblas/psb_dspmm.f90 base/psblas/psb_sspmm.f90 base/psblas/psb_zspmm.f90 Lighten checks, new realloc method --- base/modules/psb_c_vect_mod.F90 | 20 ++++++++- base/modules/psb_d_vect_mod.F90 | 20 ++++++++- base/modules/psb_s_vect_mod.F90 | 20 ++++++++- base/modules/psb_z_vect_mod.F90 | 20 ++++++++- base/psblas/psb_cspmm.f90 | 79 +++++---------------------------- base/psblas/psb_dspmm.f90 | 79 +++++---------------------------- base/psblas/psb_sspmm.f90 | 79 +++++---------------------------- base/psblas/psb_zspmm.f90 | 79 +++++---------------------------- 8 files changed, 112 insertions(+), 284 deletions(-) diff --git a/base/modules/psb_c_vect_mod.F90 b/base/modules/psb_c_vect_mod.F90 index 00ef3b04..3848d9ff 100644 --- a/base/modules/psb_c_vect_mod.F90 +++ b/base/modules/psb_c_vect_mod.F90 @@ -66,6 +66,7 @@ module psb_c_vect_mod procedure, pass(x) :: amax => c_vect_amax procedure, pass(x) :: asum => c_vect_asum procedure, pass(x) :: all => c_vect_all + procedure, pass(x) :: reall => c_vect_reall procedure, pass(x) :: zero => c_vect_zero procedure, pass(x) :: asb => c_vect_asb procedure, pass(x) :: sync => c_vect_sync @@ -437,10 +438,10 @@ contains subroutine c_vect_all(n, x, info, mold) implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(out) :: x class(psb_c_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info if (present(mold)) then #ifdef HAVE_MOLD @@ -459,6 +460,21 @@ contains end subroutine c_vect_all + subroutine c_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine c_vect_reall + subroutine c_vect_zero(x) use psi_serial_mod implicit none diff --git a/base/modules/psb_d_vect_mod.F90 b/base/modules/psb_d_vect_mod.F90 index 3659b8d4..1b00c678 100644 --- a/base/modules/psb_d_vect_mod.F90 +++ b/base/modules/psb_d_vect_mod.F90 @@ -66,6 +66,7 @@ module psb_d_vect_mod procedure, pass(x) :: amax => d_vect_amax procedure, pass(x) :: asum => d_vect_asum procedure, pass(x) :: all => d_vect_all + procedure, pass(x) :: reall => d_vect_reall procedure, pass(x) :: zero => d_vect_zero procedure, pass(x) :: asb => d_vect_asb procedure, pass(x) :: sync => d_vect_sync @@ -437,10 +438,10 @@ contains subroutine d_vect_all(n, x, info, mold) implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(out) :: x class(psb_d_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info if (present(mold)) then #ifdef HAVE_MOLD @@ -459,6 +460,21 @@ contains end subroutine d_vect_all + subroutine d_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine d_vect_reall + subroutine d_vect_zero(x) use psi_serial_mod implicit none diff --git a/base/modules/psb_s_vect_mod.F90 b/base/modules/psb_s_vect_mod.F90 index 493b833b..fe418b1a 100644 --- a/base/modules/psb_s_vect_mod.F90 +++ b/base/modules/psb_s_vect_mod.F90 @@ -66,6 +66,7 @@ module psb_s_vect_mod procedure, pass(x) :: amax => s_vect_amax procedure, pass(x) :: asum => s_vect_asum procedure, pass(x) :: all => s_vect_all + procedure, pass(x) :: reall => s_vect_reall procedure, pass(x) :: zero => s_vect_zero procedure, pass(x) :: asb => s_vect_asb procedure, pass(x) :: sync => s_vect_sync @@ -437,10 +438,10 @@ contains subroutine s_vect_all(n, x, info, mold) implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(out) :: x class(psb_s_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info if (present(mold)) then #ifdef HAVE_MOLD @@ -459,6 +460,21 @@ contains end subroutine s_vect_all + subroutine s_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine s_vect_reall + subroutine s_vect_zero(x) use psi_serial_mod implicit none diff --git a/base/modules/psb_z_vect_mod.F90 b/base/modules/psb_z_vect_mod.F90 index dd703928..8e985c18 100644 --- a/base/modules/psb_z_vect_mod.F90 +++ b/base/modules/psb_z_vect_mod.F90 @@ -66,6 +66,7 @@ module psb_z_vect_mod procedure, pass(x) :: amax => z_vect_amax procedure, pass(x) :: asum => z_vect_asum procedure, pass(x) :: all => z_vect_all + procedure, pass(x) :: reall => z_vect_reall procedure, pass(x) :: zero => z_vect_zero procedure, pass(x) :: asb => z_vect_asb procedure, pass(x) :: sync => z_vect_sync @@ -437,10 +438,10 @@ contains subroutine z_vect_all(n, x, info, mold) implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(out) :: x class(psb_z_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info if (present(mold)) then #ifdef HAVE_MOLD @@ -459,6 +460,21 @@ contains end subroutine z_vect_all + subroutine z_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine z_vect_reall + subroutine z_vect_zero(x) use psi_serial_mod implicit none diff --git a/base/psblas/psb_cspmm.f90 b/base/psblas/psb_cspmm.f90 index 81e251fb..bdf6e685 100644 --- a/base/psblas/psb_cspmm.f90 +++ b/base/psblas/psb_cspmm.f90 @@ -731,16 +731,6 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& goto 9999 endif - - ia = 1 - ja = 1 - ix = 1 - jx = 1 - iy = 1 - jy = 1 - ik = 1 - ib = 1 - if (present(doswap)) then doswap_ = doswap else @@ -766,6 +756,16 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& ncol = desc_a%get_local_cols() lldx = x%get_nrows() lldy = y%get_nrows() + if ((info == 0).and.(lldx null() ! check for presence/size of a work area @@ -795,43 +795,9 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (debug_level >= psb_debug_comp_) & & 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 /= 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 (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Checkmat ', info if (trans_ == 'N') then ! Matrix is not transposed - if((ja /= ix).or.(ia /= iy)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if if (doswap_) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -848,31 +814,6 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& else ! Matrix is transposed - if((ja /= iy).or.(ia /= ix)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - ! ! Non-empty overlap, need a buffer to hold diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index ed34b1bd..bc84bc8c 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -731,16 +731,6 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& goto 9999 endif - - ia = 1 - ja = 1 - ix = 1 - jx = 1 - iy = 1 - jy = 1 - ik = 1 - ib = 1 - if (present(doswap)) then doswap_ = doswap else @@ -766,6 +756,16 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& ncol = desc_a%get_local_cols() lldx = x%get_nrows() lldy = y%get_nrows() + if ((info == 0).and.(lldx null() ! check for presence/size of a work area @@ -795,43 +795,9 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (debug_level >= psb_debug_comp_) & & 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 /= 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 (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Checkmat ', info if (trans_ == 'N') then ! Matrix is not transposed - if((ja /= ix).or.(ia /= iy)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if if (doswap_) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -848,31 +814,6 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& else ! Matrix is transposed - if((ja /= iy).or.(ia /= ix)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - ! ! Non-empty overlap, need a buffer to hold diff --git a/base/psblas/psb_sspmm.f90 b/base/psblas/psb_sspmm.f90 index b69faa3a..29fd5a3d 100644 --- a/base/psblas/psb_sspmm.f90 +++ b/base/psblas/psb_sspmm.f90 @@ -731,16 +731,6 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& goto 9999 endif - - ia = 1 - ja = 1 - ix = 1 - jx = 1 - iy = 1 - jy = 1 - ik = 1 - ib = 1 - if (present(doswap)) then doswap_ = doswap else @@ -766,6 +756,16 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& ncol = desc_a%get_local_cols() lldx = x%get_nrows() lldy = y%get_nrows() + if ((info == 0).and.(lldx null() ! check for presence/size of a work area @@ -795,43 +795,9 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (debug_level >= psb_debug_comp_) & & 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 /= 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 (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Checkmat ', info if (trans_ == 'N') then ! Matrix is not transposed - if((ja /= ix).or.(ia /= iy)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if if (doswap_) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -848,31 +814,6 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& else ! Matrix is transposed - if((ja /= iy).or.(ia /= ix)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - ! ! Non-empty overlap, need a buffer to hold diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index 351eb671..d76fb6c4 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -731,16 +731,6 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& goto 9999 endif - - ia = 1 - ja = 1 - ix = 1 - jx = 1 - iy = 1 - jy = 1 - ik = 1 - ib = 1 - if (present(doswap)) then doswap_ = doswap else @@ -766,6 +756,16 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& ncol = desc_a%get_local_cols() lldx = x%get_nrows() lldy = y%get_nrows() + if ((info == 0).and.(lldx null() ! check for presence/size of a work area @@ -795,43 +795,9 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (debug_level >= psb_debug_comp_) & & 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 /= 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 (debug_level >= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Checkmat ', info if (trans_ == 'N') then ! Matrix is not transposed - if((ja /= ix).or.(ia /= iy)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if if (doswap_) then call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -848,31 +814,6 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& else ! Matrix is transposed - if((ja /= iy).or.(ia /= ix)) then - ! this case is not yet implemented - 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,lldx,ix,jx,desc_a,info,iix,jjx) - if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) - 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).or.(iiy /= 1)) then - ! this case is not yet implemented - info = psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - ! ! Non-empty overlap, need a buffer to hold