fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 12:22:10 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas-3.99

Browse Source 
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
This commit is contained in:
Salvatore Filippone
2013-09-26 16:50:34 +00:00
parent 492b059e85
commit 8309d08f72
8 changed files with 112 additions and 284 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_c_vect_mod.F90
+18 -2
View File
@@ -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
base/modules/psb_d_vect_mod.F90
+18 -2
View File
@@ -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
base/modules/psb_s_vect_mod.F90
+18 -2
View File
@@ -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
base/modules/psb_z_vect_mod.F90
+18 -2
View File
@@ -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
base/psblas/psb_cspmm.f90
+10 -69
View File
@@ -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<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()
! 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
base/psblas/psb_dspmm.f90
+10 -69
View File
@@ -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<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()
! 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
base/psblas/psb_sspmm.f90
+10 -69
View File
@@ -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<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()
! 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
base/psblas/psb_zspmm.f90
+10 -69
View File
@@ -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<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()
! 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