fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3

Browse Source 
base/modules/psb_c_vect_mod.F90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_d_vect_mod.F90
 base/modules/psb_i_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
psblas-testmv
Salvatore Filippone 11 years ago
parent c86620020e
commit 31023c565a
10 changed files with 131 additions and 286 deletions
Show Stats Download Patch File Download Diff File

20
base/modules/psb_c_vect_mod.F90
Unescape Escape View File

@ -66,6 +66,7 @@ module psb_c_vect_mod
procedure, pass(x) :: amax => c_vect_amax procedure, pass(x) :: amax => c_vect_amax
procedure, pass(x) :: asum => c_vect_asum procedure, pass(x) :: asum => c_vect_asum
procedure, pass(x) :: all => c_vect_all procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero procedure, pass(x) :: zero => c_vect_zero
procedure, pass(x) :: asb => c_vect_asb procedure, pass(x) :: asb => c_vect_asb
procedure, pass(x) :: sync => c_vect_sync procedure, pass(x) :: sync => c_vect_sync
@ -437,10 +438,10 @@ contains
subroutine c_vect_all(n, x, info, mold) subroutine c_vect_all(n, x, info, mold)
implicit none 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_vect_type), intent(out) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold 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 if (present(mold)) then
#ifdef HAVE_MOLD #ifdef HAVE_MOLD
@ -459,6 +460,21 @@ contains
end subroutine c_vect_all 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) subroutine c_vect_zero(x)
use psi_serial_mod use psi_serial_mod
implicit none implicit none

1
base/modules/psb_d_base_vect_mod.f90
Unescape Escape View File

@ -389,6 +389,7 @@ contains
class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
info = 0
if (x%get_nrows() < n) & if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info) & call psb_realloc(n,x%v,info)
if (info /= 0) & if (info /= 0) &

20
base/modules/psb_d_vect_mod.F90
Unescape Escape View File

@ -66,6 +66,7 @@ module psb_d_vect_mod
procedure, pass(x) :: amax => d_vect_amax procedure, pass(x) :: amax => d_vect_amax
procedure, pass(x) :: asum => d_vect_asum procedure, pass(x) :: asum => d_vect_asum
procedure, pass(x) :: all => d_vect_all procedure, pass(x) :: all => d_vect_all
procedure, pass(x) :: reall => d_vect_reall
procedure, pass(x) :: zero => d_vect_zero procedure, pass(x) :: zero => d_vect_zero
procedure, pass(x) :: asb => d_vect_asb procedure, pass(x) :: asb => d_vect_asb
procedure, pass(x) :: sync => d_vect_sync procedure, pass(x) :: sync => d_vect_sync
@ -437,10 +438,10 @@ contains
subroutine d_vect_all(n, x, info, mold) subroutine d_vect_all(n, x, info, mold)
implicit none 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_vect_type), intent(out) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold 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 if (present(mold)) then
#ifdef HAVE_MOLD #ifdef HAVE_MOLD
@ -459,6 +460,21 @@ contains
end subroutine d_vect_all 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) subroutine d_vect_zero(x)
use psi_serial_mod use psi_serial_mod
implicit none implicit none

20
base/modules/psb_i_vect_mod.F90
Unescape Escape View File

@ -66,6 +66,7 @@ module psb_i_vect_mod
procedure, pass(x) :: amax => i_vect_amax procedure, pass(x) :: amax => i_vect_amax
procedure, pass(x) :: asum => i_vect_asum procedure, pass(x) :: asum => i_vect_asum
procedure, pass(x) :: all => i_vect_all procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero procedure, pass(x) :: zero => i_vect_zero
procedure, pass(x) :: asb => i_vect_asb procedure, pass(x) :: asb => i_vect_asb
procedure, pass(x) :: sync => i_vect_sync procedure, pass(x) :: sync => i_vect_sync
@ -437,10 +438,10 @@ contains
subroutine i_vect_all(n, x, info, mold) subroutine i_vect_all(n, x, info, mold)
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(out) :: x class(psb_i_vect_type), intent(out) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD #ifdef HAVE_MOLD
@ -459,6 +460,21 @@ contains
end subroutine i_vect_all end subroutine i_vect_all
subroutine i_vect_reall(n, x, info)
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_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 i_vect_reall
subroutine i_vect_zero(x) subroutine i_vect_zero(x)
use psi_serial_mod use psi_serial_mod
implicit none implicit none

20
base/modules/psb_s_vect_mod.F90
Unescape Escape View File

@ -66,6 +66,7 @@ module psb_s_vect_mod
procedure, pass(x) :: amax => s_vect_amax procedure, pass(x) :: amax => s_vect_amax
procedure, pass(x) :: asum => s_vect_asum procedure, pass(x) :: asum => s_vect_asum
procedure, pass(x) :: all => s_vect_all procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero procedure, pass(x) :: zero => s_vect_zero
procedure, pass(x) :: asb => s_vect_asb procedure, pass(x) :: asb => s_vect_asb
procedure, pass(x) :: sync => s_vect_sync procedure, pass(x) :: sync => s_vect_sync
@ -437,10 +438,10 @@ contains
subroutine s_vect_all(n, x, info, mold) subroutine s_vect_all(n, x, info, mold)
implicit none 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_vect_type), intent(out) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold 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 if (present(mold)) then
#ifdef HAVE_MOLD #ifdef HAVE_MOLD
@ -459,6 +460,21 @@ contains
end subroutine s_vect_all 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) subroutine s_vect_zero(x)
use psi_serial_mod use psi_serial_mod
implicit none implicit none

20
base/modules/psb_z_vect_mod.F90
Unescape Escape View File

@ -66,6 +66,7 @@ module psb_z_vect_mod
procedure, pass(x) :: amax => z_vect_amax procedure, pass(x) :: amax => z_vect_amax
procedure, pass(x) :: asum => z_vect_asum procedure, pass(x) :: asum => z_vect_asum
procedure, pass(x) :: all => z_vect_all procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero procedure, pass(x) :: zero => z_vect_zero
procedure, pass(x) :: asb => z_vect_asb procedure, pass(x) :: asb => z_vect_asb
procedure, pass(x) :: sync => z_vect_sync procedure, pass(x) :: sync => z_vect_sync
@ -437,10 +438,10 @@ contains
subroutine z_vect_all(n, x, info, mold) subroutine z_vect_all(n, x, info, mold)
implicit none 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_vect_type), intent(out) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold 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 if (present(mold)) then
#ifdef HAVE_MOLD #ifdef HAVE_MOLD
@ -459,6 +460,21 @@ contains
end subroutine z_vect_all 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) subroutine z_vect_zero(x)
use psi_serial_mod use psi_serial_mod
implicit none implicit none

79
base/psblas/psb_cspmm.f90
Unescape Escape View File

@ -731,16 +731,6 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
endif endif
ia = 1
ja = 1
ix = 1
jx = 1
iy = 1
jy = 1
ik = 1
ib = 1
if (present(doswap)) then if (present(doswap)) then
doswap_ = doswap doswap_ = doswap
else else
@ -766,6 +756,16 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
lldx = x%get_nrows() lldx = x%get_nrows()
lldy = y%get_nrows() lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null() iwork => null()
! check for presence/size of a work area ! 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_) & if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', 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 /= 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 if (trans_ == 'N') then
! Matrix is not transposed ! 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 if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& 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 else
! Matrix is transposed ! 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 ! Non-empty overlap, need a buffer to hold

79
base/psblas/psb_dspmm.f90
Unescape Escape View File

@ -731,16 +731,6 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
endif endif
ia = 1
ja = 1
ix = 1
jx = 1
iy = 1
jy = 1
ik = 1
ib = 1
if (present(doswap)) then if (present(doswap)) then
doswap_ = doswap doswap_ = doswap
else else
@ -766,6 +756,16 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
lldx = x%get_nrows() lldx = x%get_nrows()
lldy = y%get_nrows() lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null() iwork => null()
! check for presence/size of a work area ! 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_) & if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', 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 /= 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 if (trans_ == 'N') then
! Matrix is not transposed ! 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 if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& 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 else
! Matrix is transposed ! 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 ! Non-empty overlap, need a buffer to hold

79
base/psblas/psb_sspmm.f90
Unescape Escape View File

@ -731,16 +731,6 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
endif endif
ia = 1
ja = 1
ix = 1
jx = 1
iy = 1
jy = 1
ik = 1
ib = 1
if (present(doswap)) then if (present(doswap)) then
doswap_ = doswap doswap_ = doswap
else else
@ -766,6 +756,16 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
lldx = x%get_nrows() lldx = x%get_nrows()
lldy = y%get_nrows() lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null() iwork => null()
! check for presence/size of a work area ! 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_) & if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', 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 /= 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 if (trans_ == 'N') then
! Matrix is not transposed ! 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 if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& 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 else
! Matrix is transposed ! 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 ! Non-empty overlap, need a buffer to hold

79
base/psblas/psb_zspmm.f90
Unescape Escape View File

@ -731,16 +731,6 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
endif endif
ia = 1
ja = 1
ix = 1
jx = 1
iy = 1
jy = 1
ik = 1
ib = 1
if (present(doswap)) then if (present(doswap)) then
doswap_ = doswap doswap_ = doswap
else else
@ -766,6 +756,16 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
lldx = x%get_nrows() lldx = x%get_nrows()
lldy = y%get_nrows() lldy = y%get_nrows()
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null() iwork => null()
! check for presence/size of a work area ! 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_) & if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', 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 /= 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 if (trans_ == 'N') then
! Matrix is not transposed ! 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 if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& 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 else
! Matrix is transposed ! 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 ! Non-empty overlap, need a buffer to hold

Write Preview
Loading…
Cancel
Save