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

Finish vector assembly with REMOTE_BUILD. To be tested.

Browse Source
remotebuild
Salvatore Filippone 3 years ago
parent fc81367fef
commit fafe128516
41 changed files with 1021 additions and 899 deletions
Show Stats Download Patch File Download Diff File

2
base/internals/psi_indx_map_fnd_owner.F90
Unescape Escape View File

@ -68,7 +68,7 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info,adj)
#endif #endif
integer(psb_lpk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(inout) :: idxmap class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)

2
base/modules/desc/psb_gen_block_map_mod.F90
Unescape Escape View File

@ -1057,7 +1057,7 @@ contains
implicit none implicit none
integer(psb_lpk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_gen_block_map), intent(inout) :: idxmap class(psb_gen_block_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt

2
base/modules/desc/psb_glist_map_mod.f90
Unescape Escape View File

@ -157,7 +157,7 @@ contains
implicit none implicit none
integer(psb_lpk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_glist_map), intent(inout) :: idxmap class(psb_glist_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)

8
base/modules/desc/psb_indx_map_mod.f90
Unescape Escape View File

@ -273,7 +273,7 @@ module psb_indx_map_mod
implicit none implicit none
integer(psb_lpk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(inout) :: idxmap class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
end subroutine psi_indx_map_fnd_owner end subroutine psi_indx_map_fnd_owner
@ -310,7 +310,7 @@ module psb_indx_map_mod
integer(psb_lpk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
integer(psb_ipk_), allocatable, intent(out) :: ladj(:) integer(psb_ipk_), allocatable, intent(out) :: ladj(:)
class(psb_indx_map), intent(inout) :: idxmap class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psi_graph_fnd_owner end subroutine psi_graph_fnd_owner
end interface end interface
@ -1521,7 +1521,7 @@ contains
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
class(psb_indx_map), intent(inout) :: idxmap class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: xin integer(psb_ipk_), intent(in) :: xin
integer(psb_ipk_), intent(out) :: xout integer(psb_ipk_), intent(out) :: xout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1550,7 +1550,7 @@ contains
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
implicit none implicit none
class(psb_indx_map), intent(inout) :: idxmap class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: xin(:) integer(psb_ipk_), intent(in) :: xin(:)
integer(psb_ipk_), intent(out) :: xout(:) integer(psb_ipk_), intent(out) :: xout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info

2
base/modules/desc/psb_repl_map_mod.f90
Unescape Escape View File

@ -701,7 +701,7 @@ contains
implicit none implicit none
integer(psb_lpk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_repl_map), intent(inout) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:)
integer(psb_ipk_) :: nv integer(psb_ipk_) :: nv

51
base/modules/serial/psb_c_vect_mod.F90
Unescape Escape View File

@ -39,6 +39,7 @@
! !
module psb_c_vect_mod module psb_c_vect_mod
use psb_realloc_mod
use psb_c_base_vect_mod use psb_c_base_vect_mod
use psb_i_vect_mod use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_c_vect_mod
procedure, pass(x) :: set_remote_build => c_vect_set_remote_build procedure, pass(x) :: set_remote_build => c_vect_set_remote_build
procedure, pass(x) :: get_dupl => c_vect_get_dupl procedure, pass(x) :: get_dupl => c_vect_get_dupl
procedure, pass(x) :: set_dupl => c_vect_set_dupl procedure, pass(x) :: set_dupl => c_vect_set_dupl
procedure, pass(x) :: get_nrmv => c_vect_get_nrmv
procedure, pass(x) :: set_nrmv => c_vect_set_nrmv
procedure, pass(x) :: all => c_vect_all procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero procedure, pass(x) :: zero => c_vect_zero
@ -156,7 +159,7 @@ module psb_c_vect_mod
& c_vect_is_dev, c_vect_is_sync, c_vect_set_host, & & c_vect_is_dev, c_vect_is_sync, c_vect_set_host, &
& c_vect_set_dev, c_vect_set_sync, & & c_vect_set_dev, c_vect_set_sync, &
& c_vect_set_remote_build, c_is_remote_build, & & c_vect_set_remote_build, c_is_remote_build, &
& c_vect_set_dupl, c_get_dupl & c_vect_set_dupl, c_get_dupl, c_vect_set_nrmv, c_get_nrmv
private :: c_vect_dot_v, c_vect_dot_a, c_vect_axpby_v, c_vect_axpby_a, & private :: c_vect_dot_v, c_vect_dot_a, c_vect_axpby_v, c_vect_axpby_a, &
& c_vect_mlt_v, c_vect_mlt_a, c_vect_mlt_a_2, c_vect_mlt_v_2, & & c_vect_mlt_v, c_vect_mlt_a, c_vect_mlt_a_2, c_vect_mlt_v_2, &
@ -178,7 +181,6 @@ module psb_c_vect_mod
contains contains
function c_vect_get_dupl(x) result(res) function c_vect_get_dupl(x) result(res)
implicit none implicit none
class(psb_c_vect_type), intent(in) :: x class(psb_c_vect_type), intent(in) :: x
@ -198,6 +200,21 @@ contains
end if end if
end subroutine c_vect_set_dupl end subroutine c_vect_set_dupl
function c_vect_get_nrmv(x) result(res)
implicit none
class(psb_c_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function c_vect_get_nrmv
subroutine c_vect_set_nrmv(x,val)
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine c_vect_set_nrmv
function c_vect_is_remote_build(x) result(res) function c_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -410,14 +427,13 @@ contains
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function c_vect_get_fmt end function c_vect_get_fmt
subroutine c_vect_all(n, x, info, mold,mode) 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(inout) :: x class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(in), optional :: mode
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -432,9 +448,6 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
x%nrmv = 0
x%remote_build = psb_matbld_noremote_
if (present(mode)) call x%set_remote_build(mode)
end subroutine c_vect_all end subroutine c_vect_all
subroutine c_vect_reall(n, x, info) subroutine c_vect_reall(n, x, info)
@ -522,44 +535,44 @@ contains
end subroutine c_vect_free end subroutine c_vect_free
subroutine c_vect_ins_a(n,irl,val,dupl,x,info) subroutine c_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:) complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine c_vect_ins_a end subroutine c_vect_ins_a
subroutine c_vect_ins_v(n,irl,val,dupl,x,info) subroutine c_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_c_vect_type), intent(inout) :: val class(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine c_vect_ins_v end subroutine c_vect_ins_v
@ -1670,23 +1683,23 @@ contains
end subroutine c_vect_free end subroutine c_vect_free
subroutine c_vect_ins(n,irl,val,dupl,x,info) subroutine c_vect_ins(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_c_multivect_type), intent(inout) :: x class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:,:) complex(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine c_vect_ins end subroutine c_vect_ins

51
base/modules/serial/psb_d_vect_mod.F90
Unescape Escape View File

@ -39,6 +39,7 @@
! !
module psb_d_vect_mod module psb_d_vect_mod
use psb_realloc_mod
use psb_d_base_vect_mod use psb_d_base_vect_mod
use psb_i_vect_mod use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_d_vect_mod
procedure, pass(x) :: set_remote_build => d_vect_set_remote_build procedure, pass(x) :: set_remote_build => d_vect_set_remote_build
procedure, pass(x) :: get_dupl => d_vect_get_dupl procedure, pass(x) :: get_dupl => d_vect_get_dupl
procedure, pass(x) :: set_dupl => d_vect_set_dupl procedure, pass(x) :: set_dupl => d_vect_set_dupl
procedure, pass(x) :: get_nrmv => d_vect_get_nrmv
procedure, pass(x) :: set_nrmv => d_vect_set_nrmv
procedure, pass(x) :: all => d_vect_all procedure, pass(x) :: all => d_vect_all
procedure, pass(x) :: reall => d_vect_reall procedure, pass(x) :: reall => d_vect_reall
procedure, pass(x) :: zero => d_vect_zero procedure, pass(x) :: zero => d_vect_zero
@ -163,7 +166,7 @@ module psb_d_vect_mod
& d_vect_is_dev, d_vect_is_sync, d_vect_set_host, & & d_vect_is_dev, d_vect_is_sync, d_vect_set_host, &
& d_vect_set_dev, d_vect_set_sync, & & d_vect_set_dev, d_vect_set_sync, &
& d_vect_set_remote_build, d_is_remote_build, & & d_vect_set_remote_build, d_is_remote_build, &
& d_vect_set_dupl, d_get_dupl & d_vect_set_dupl, d_get_dupl, d_vect_set_nrmv, d_get_nrmv
private :: d_vect_dot_v, d_vect_dot_a, d_vect_axpby_v, d_vect_axpby_a, & private :: d_vect_dot_v, d_vect_dot_a, d_vect_axpby_v, d_vect_axpby_a, &
& d_vect_mlt_v, d_vect_mlt_a, d_vect_mlt_a_2, d_vect_mlt_v_2, & & d_vect_mlt_v, d_vect_mlt_a, d_vect_mlt_a_2, d_vect_mlt_v_2, &
@ -185,7 +188,6 @@ module psb_d_vect_mod
contains contains
function d_vect_get_dupl(x) result(res) function d_vect_get_dupl(x) result(res)
implicit none implicit none
class(psb_d_vect_type), intent(in) :: x class(psb_d_vect_type), intent(in) :: x
@ -205,6 +207,21 @@ contains
end if end if
end subroutine d_vect_set_dupl end subroutine d_vect_set_dupl
function d_vect_get_nrmv(x) result(res)
implicit none
class(psb_d_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function d_vect_get_nrmv
subroutine d_vect_set_nrmv(x,val)
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine d_vect_set_nrmv
function d_vect_is_remote_build(x) result(res) function d_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -417,14 +434,13 @@ contains
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function d_vect_get_fmt end function d_vect_get_fmt
subroutine d_vect_all(n, x, info, mold,mode) 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(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(in), optional :: mode
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -439,9 +455,6 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
x%nrmv = 0
x%remote_build = psb_matbld_noremote_
if (present(mode)) call x%set_remote_build(mode)
end subroutine d_vect_all end subroutine d_vect_all
subroutine d_vect_reall(n, x, info) subroutine d_vect_reall(n, x, info)
@ -529,44 +542,44 @@ contains
end subroutine d_vect_free end subroutine d_vect_free
subroutine d_vect_ins_a(n,irl,val,dupl,x,info) subroutine d_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine d_vect_ins_a end subroutine d_vect_ins_a
subroutine d_vect_ins_v(n,irl,val,dupl,x,info) subroutine d_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine d_vect_ins_v end subroutine d_vect_ins_v
@ -1749,23 +1762,23 @@ contains
end subroutine d_vect_free end subroutine d_vect_free
subroutine d_vect_ins(n,irl,val,dupl,x,info) subroutine d_vect_ins(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_d_multivect_type), intent(inout) :: x class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:,:) real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine d_vect_ins end subroutine d_vect_ins

51
base/modules/serial/psb_i_vect_mod.F90
Unescape Escape View File

@ -39,6 +39,7 @@
! !
module psb_i_vect_mod module psb_i_vect_mod
use psb_realloc_mod
use psb_i_base_vect_mod use psb_i_base_vect_mod
type psb_i_vect_type type psb_i_vect_type
@ -56,6 +57,8 @@ module psb_i_vect_mod
procedure, pass(x) :: set_remote_build => i_vect_set_remote_build procedure, pass(x) :: set_remote_build => i_vect_set_remote_build
procedure, pass(x) :: get_dupl => i_vect_get_dupl procedure, pass(x) :: get_dupl => i_vect_get_dupl
procedure, pass(x) :: set_dupl => i_vect_set_dupl procedure, pass(x) :: set_dupl => i_vect_set_dupl
procedure, pass(x) :: get_nrmv => i_vect_get_nrmv
procedure, pass(x) :: set_nrmv => i_vect_set_nrmv
procedure, pass(x) :: all => i_vect_all procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero procedure, pass(x) :: zero => i_vect_zero
@ -108,7 +111,7 @@ module psb_i_vect_mod
& i_vect_is_dev, i_vect_is_sync, i_vect_set_host, & & i_vect_is_dev, i_vect_is_sync, i_vect_set_host, &
& i_vect_set_dev, i_vect_set_sync, & & i_vect_set_dev, i_vect_set_sync, &
& i_vect_set_remote_build, i_is_remote_build, & & i_vect_set_remote_build, i_is_remote_build, &
& i_vect_set_dupl, i_get_dupl & i_vect_set_dupl, i_get_dupl, i_vect_set_nrmv, i_get_nrmv
class(psb_i_base_vect_type), allocatable, target,& class(psb_i_base_vect_type), allocatable, target,&
@ -125,7 +128,6 @@ module psb_i_vect_mod
contains contains
function i_vect_get_dupl(x) result(res) function i_vect_get_dupl(x) result(res)
implicit none implicit none
class(psb_i_vect_type), intent(in) :: x class(psb_i_vect_type), intent(in) :: x
@ -145,6 +147,21 @@ contains
end if end if
end subroutine i_vect_set_dupl end subroutine i_vect_set_dupl
function i_vect_get_nrmv(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function i_vect_get_nrmv
subroutine i_vect_set_nrmv(x,val)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine i_vect_set_nrmv
function i_vect_is_remote_build(x) result(res) function i_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -357,14 +374,13 @@ contains
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function i_vect_get_fmt end function i_vect_get_fmt
subroutine i_vect_all(n, x, info, mold,mode) 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(inout) :: x class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(in), optional :: mode
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -379,9 +395,6 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
x%nrmv = 0
x%remote_build = psb_matbld_noremote_
if (present(mode)) call x%set_remote_build(mode)
end subroutine i_vect_all end subroutine i_vect_all
subroutine i_vect_reall(n, x, info) subroutine i_vect_reall(n, x, info)
@ -469,44 +482,44 @@ contains
end subroutine i_vect_free end subroutine i_vect_free
subroutine i_vect_ins_a(n,irl,val,dupl,x,info) subroutine i_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine i_vect_ins_a end subroutine i_vect_ins_a
subroutine i_vect_ins_v(n,irl,val,dupl,x,info) subroutine i_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_i_vect_type), intent(inout) :: val class(psb_i_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine i_vect_ins_v end subroutine i_vect_ins_v
@ -1027,23 +1040,23 @@ contains
end subroutine i_vect_free end subroutine i_vect_free
subroutine i_vect_ins(n,irl,val,dupl,x,info) subroutine i_vect_ins(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_i_multivect_type), intent(inout) :: x class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine i_vect_ins end subroutine i_vect_ins

51
base/modules/serial/psb_l_vect_mod.F90
Unescape Escape View File

@ -39,6 +39,7 @@
! !
module psb_l_vect_mod module psb_l_vect_mod
use psb_realloc_mod
use psb_l_base_vect_mod use psb_l_base_vect_mod
use psb_i_vect_mod use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_l_vect_mod
procedure, pass(x) :: set_remote_build => l_vect_set_remote_build procedure, pass(x) :: set_remote_build => l_vect_set_remote_build
procedure, pass(x) :: get_dupl => l_vect_get_dupl procedure, pass(x) :: get_dupl => l_vect_get_dupl
procedure, pass(x) :: set_dupl => l_vect_set_dupl procedure, pass(x) :: set_dupl => l_vect_set_dupl
procedure, pass(x) :: get_nrmv => l_vect_get_nrmv
procedure, pass(x) :: set_nrmv => l_vect_set_nrmv
procedure, pass(x) :: all => l_vect_all procedure, pass(x) :: all => l_vect_all
procedure, pass(x) :: reall => l_vect_reall procedure, pass(x) :: reall => l_vect_reall
procedure, pass(x) :: zero => l_vect_zero procedure, pass(x) :: zero => l_vect_zero
@ -109,7 +112,7 @@ module psb_l_vect_mod
& l_vect_is_dev, l_vect_is_sync, l_vect_set_host, & & l_vect_is_dev, l_vect_is_sync, l_vect_set_host, &
& l_vect_set_dev, l_vect_set_sync, & & l_vect_set_dev, l_vect_set_sync, &
& l_vect_set_remote_build, l_is_remote_build, & & l_vect_set_remote_build, l_is_remote_build, &
& l_vect_set_dupl, l_get_dupl & l_vect_set_dupl, l_get_dupl, l_vect_set_nrmv, l_get_nrmv
class(psb_l_base_vect_type), allocatable, target,& class(psb_l_base_vect_type), allocatable, target,&
@ -126,7 +129,6 @@ module psb_l_vect_mod
contains contains
function l_vect_get_dupl(x) result(res) function l_vect_get_dupl(x) result(res)
implicit none implicit none
class(psb_l_vect_type), intent(in) :: x class(psb_l_vect_type), intent(in) :: x
@ -146,6 +148,21 @@ contains
end if end if
end subroutine l_vect_set_dupl end subroutine l_vect_set_dupl
function l_vect_get_nrmv(x) result(res)
implicit none
class(psb_l_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function l_vect_get_nrmv
subroutine l_vect_set_nrmv(x,val)
implicit none
class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine l_vect_set_nrmv
function l_vect_is_remote_build(x) result(res) function l_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -358,14 +375,13 @@ contains
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function l_vect_get_fmt end function l_vect_get_fmt
subroutine l_vect_all(n, x, info, mold,mode) subroutine l_vect_all(n, x, info, mold)
implicit none implicit none
integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(in) :: n
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(in), optional :: mode
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -380,9 +396,6 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
x%nrmv = 0
x%remote_build = psb_matbld_noremote_
if (present(mode)) call x%set_remote_build(mode)
end subroutine l_vect_all end subroutine l_vect_all
subroutine l_vect_reall(n, x, info) subroutine l_vect_reall(n, x, info)
@ -470,44 +483,44 @@ contains
end subroutine l_vect_free end subroutine l_vect_free
subroutine l_vect_ins_a(n,irl,val,dupl,x,info) subroutine l_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine l_vect_ins_a end subroutine l_vect_ins_a
subroutine l_vect_ins_v(n,irl,val,dupl,x,info) subroutine l_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_l_vect_type), intent(inout) :: val class(psb_l_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine l_vect_ins_v end subroutine l_vect_ins_v
@ -1028,23 +1041,23 @@ contains
end subroutine l_vect_free end subroutine l_vect_free
subroutine l_vect_ins(n,irl,val,dupl,x,info) subroutine l_vect_ins(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_l_multivect_type), intent(inout) :: x class(psb_l_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_lpk_), intent(in) :: val(:,:) integer(psb_lpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine l_vect_ins end subroutine l_vect_ins

51
base/modules/serial/psb_s_vect_mod.F90
Unescape Escape View File

@ -39,6 +39,7 @@
! !
module psb_s_vect_mod module psb_s_vect_mod
use psb_realloc_mod
use psb_s_base_vect_mod use psb_s_base_vect_mod
use psb_i_vect_mod use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_s_vect_mod
procedure, pass(x) :: set_remote_build => s_vect_set_remote_build procedure, pass(x) :: set_remote_build => s_vect_set_remote_build
procedure, pass(x) :: get_dupl => s_vect_get_dupl procedure, pass(x) :: get_dupl => s_vect_get_dupl
procedure, pass(x) :: set_dupl => s_vect_set_dupl procedure, pass(x) :: set_dupl => s_vect_set_dupl
procedure, pass(x) :: get_nrmv => s_vect_get_nrmv
procedure, pass(x) :: set_nrmv => s_vect_set_nrmv
procedure, pass(x) :: all => s_vect_all procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero procedure, pass(x) :: zero => s_vect_zero
@ -163,7 +166,7 @@ module psb_s_vect_mod
& s_vect_is_dev, s_vect_is_sync, s_vect_set_host, & & s_vect_is_dev, s_vect_is_sync, s_vect_set_host, &
& s_vect_set_dev, s_vect_set_sync, & & s_vect_set_dev, s_vect_set_sync, &
& s_vect_set_remote_build, s_is_remote_build, & & s_vect_set_remote_build, s_is_remote_build, &
& s_vect_set_dupl, s_get_dupl & s_vect_set_dupl, s_get_dupl, s_vect_set_nrmv, s_get_nrmv
private :: s_vect_dot_v, s_vect_dot_a, s_vect_axpby_v, s_vect_axpby_a, & private :: s_vect_dot_v, s_vect_dot_a, s_vect_axpby_v, s_vect_axpby_a, &
& s_vect_mlt_v, s_vect_mlt_a, s_vect_mlt_a_2, s_vect_mlt_v_2, & & s_vect_mlt_v, s_vect_mlt_a, s_vect_mlt_a_2, s_vect_mlt_v_2, &
@ -185,7 +188,6 @@ module psb_s_vect_mod
contains contains
function s_vect_get_dupl(x) result(res) function s_vect_get_dupl(x) result(res)
implicit none implicit none
class(psb_s_vect_type), intent(in) :: x class(psb_s_vect_type), intent(in) :: x
@ -205,6 +207,21 @@ contains
end if end if
end subroutine s_vect_set_dupl end subroutine s_vect_set_dupl
function s_vect_get_nrmv(x) result(res)
implicit none
class(psb_s_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function s_vect_get_nrmv
subroutine s_vect_set_nrmv(x,val)
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine s_vect_set_nrmv
function s_vect_is_remote_build(x) result(res) function s_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -417,14 +434,13 @@ contains
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function s_vect_get_fmt end function s_vect_get_fmt
subroutine s_vect_all(n, x, info, mold,mode) 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(inout) :: x class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(in), optional :: mode
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -439,9 +455,6 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
x%nrmv = 0
x%remote_build = psb_matbld_noremote_
if (present(mode)) call x%set_remote_build(mode)
end subroutine s_vect_all end subroutine s_vect_all
subroutine s_vect_reall(n, x, info) subroutine s_vect_reall(n, x, info)
@ -529,44 +542,44 @@ contains
end subroutine s_vect_free end subroutine s_vect_free
subroutine s_vect_ins_a(n,irl,val,dupl,x,info) subroutine s_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine s_vect_ins_a end subroutine s_vect_ins_a
subroutine s_vect_ins_v(n,irl,val,dupl,x,info) subroutine s_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_s_vect_type), intent(inout) :: val class(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine s_vect_ins_v end subroutine s_vect_ins_v
@ -1749,23 +1762,23 @@ contains
end subroutine s_vect_free end subroutine s_vect_free
subroutine s_vect_ins(n,irl,val,dupl,x,info) subroutine s_vect_ins(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_s_multivect_type), intent(inout) :: x class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:,:) real(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine s_vect_ins end subroutine s_vect_ins

51
base/modules/serial/psb_z_vect_mod.F90
Unescape Escape View File

@ -39,6 +39,7 @@
! !
module psb_z_vect_mod module psb_z_vect_mod
use psb_realloc_mod
use psb_z_base_vect_mod use psb_z_base_vect_mod
use psb_i_vect_mod use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_z_vect_mod
procedure, pass(x) :: set_remote_build => z_vect_set_remote_build procedure, pass(x) :: set_remote_build => z_vect_set_remote_build
procedure, pass(x) :: get_dupl => z_vect_get_dupl procedure, pass(x) :: get_dupl => z_vect_get_dupl
procedure, pass(x) :: set_dupl => z_vect_set_dupl procedure, pass(x) :: set_dupl => z_vect_set_dupl
procedure, pass(x) :: get_nrmv => z_vect_get_nrmv
procedure, pass(x) :: set_nrmv => z_vect_set_nrmv
procedure, pass(x) :: all => z_vect_all procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero procedure, pass(x) :: zero => z_vect_zero
@ -156,7 +159,7 @@ module psb_z_vect_mod
& z_vect_is_dev, z_vect_is_sync, z_vect_set_host, & & z_vect_is_dev, z_vect_is_sync, z_vect_set_host, &
& z_vect_set_dev, z_vect_set_sync, & & z_vect_set_dev, z_vect_set_sync, &
& z_vect_set_remote_build, z_is_remote_build, & & z_vect_set_remote_build, z_is_remote_build, &
& z_vect_set_dupl, z_get_dupl & z_vect_set_dupl, z_get_dupl, z_vect_set_nrmv, z_get_nrmv
private :: z_vect_dot_v, z_vect_dot_a, z_vect_axpby_v, z_vect_axpby_a, & private :: z_vect_dot_v, z_vect_dot_a, z_vect_axpby_v, z_vect_axpby_a, &
& z_vect_mlt_v, z_vect_mlt_a, z_vect_mlt_a_2, z_vect_mlt_v_2, & & z_vect_mlt_v, z_vect_mlt_a, z_vect_mlt_a_2, z_vect_mlt_v_2, &
@ -178,7 +181,6 @@ module psb_z_vect_mod
contains contains
function z_vect_get_dupl(x) result(res) function z_vect_get_dupl(x) result(res)
implicit none implicit none
class(psb_z_vect_type), intent(in) :: x class(psb_z_vect_type), intent(in) :: x
@ -198,6 +200,21 @@ contains
end if end if
end subroutine z_vect_set_dupl end subroutine z_vect_set_dupl
function z_vect_get_nrmv(x) result(res)
implicit none
class(psb_z_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = x%nrmv
end function z_vect_get_nrmv
subroutine z_vect_set_nrmv(x,val)
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
x%nrmv = val
end subroutine z_vect_set_nrmv
function z_vect_is_remote_build(x) result(res) function z_vect_is_remote_build(x) result(res)
implicit none implicit none
@ -410,14 +427,13 @@ contains
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function z_vect_get_fmt end function z_vect_get_fmt
subroutine z_vect_all(n, x, info, mold,mode) 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(inout) :: x class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(in), optional :: mode
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
@ -432,9 +448,6 @@ contains
else else
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
end if end if
x%nrmv = 0
x%remote_build = psb_matbld_noremote_
if (present(mode)) call x%set_remote_build(mode)
end subroutine z_vect_all end subroutine z_vect_all
subroutine z_vect_reall(n, x, info) subroutine z_vect_reall(n, x, info)
@ -522,44 +535,44 @@ contains
end subroutine z_vect_free end subroutine z_vect_free
subroutine z_vect_ins_a(n,irl,val,dupl,x,info) subroutine z_vect_ins_a(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:) complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine z_vect_ins_a end subroutine z_vect_ins_a
subroutine z_vect_ins_v(n,irl,val,dupl,x,info) subroutine z_vect_ins_v(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: irl class(psb_i_vect_type), intent(inout) :: irl
class(psb_z_vect_type), intent(inout) :: val class(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl%v,val%v,dupl,info) call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine z_vect_ins_v end subroutine z_vect_ins_v
@ -1670,23 +1683,23 @@ contains
end subroutine z_vect_free end subroutine z_vect_free
subroutine z_vect_ins(n,irl,val,dupl,x,info) subroutine z_vect_ins(n,irl,val,x,info)
use psi_serial_mod use psi_serial_mod
implicit none implicit none
class(psb_z_multivect_type), intent(inout) :: x class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: irl(:) integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:,:) complex(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i integer(psb_ipk_) :: i, dupl
info = 0 info = 0
if (.not.allocated(x%v)) then if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_ info = psb_err_invalid_vect_state_
return return
end if end if
dupl = x%get_dupl()
call x%v%ins(n,irl,val,dupl,info) call x%v%ins(n,irl,val,dupl,info)
end subroutine z_vect_ins end subroutine z_vect_ins

8
base/modules/tools/psb_c_tools_mod.F90
Unescape Escape View File

@ -263,11 +263,15 @@ Module psb_c_tools_mod
end interface end interface
interface psb_remote_vect interface psb_remote_vect
subroutine psb_c_remote_vect(v,desc_a, info) subroutine psb_c_remote_vect(n,v,iv,desc_a,x,ix, info)
import import
implicit none implicit none
type(psb_c_vect_type),Intent(inout) :: v integer(psb_ipk_), intent(in) :: n
complex(psb_spk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
complex(psb_spk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_remote_vect end subroutine psb_c_remote_vect
end interface psb_remote_vect end interface psb_remote_vect

8
base/modules/tools/psb_d_tools_mod.F90
Unescape Escape View File

@ -263,11 +263,15 @@ Module psb_d_tools_mod
end interface end interface
interface psb_remote_vect interface psb_remote_vect
subroutine psb_d_remote_vect(v,desc_a, info) subroutine psb_d_remote_vect(n,v,iv,desc_a,x,ix, info)
import import
implicit none implicit none
type(psb_d_vect_type),Intent(inout) :: v integer(psb_ipk_), intent(in) :: n
real(psb_dpk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
real(psb_dpk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_remote_vect end subroutine psb_d_remote_vect
end interface psb_remote_vect end interface psb_remote_vect

8
base/modules/tools/psb_s_tools_mod.F90
Unescape Escape View File

@ -263,11 +263,15 @@ Module psb_s_tools_mod
end interface end interface
interface psb_remote_vect interface psb_remote_vect
subroutine psb_s_remote_vect(v,desc_a, info) subroutine psb_s_remote_vect(n,v,iv,desc_a,x,ix, info)
import import
implicit none implicit none
type(psb_s_vect_type),Intent(inout) :: v integer(psb_ipk_), intent(in) :: n
real(psb_spk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
real(psb_spk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_remote_vect end subroutine psb_s_remote_vect
end interface psb_remote_vect end interface psb_remote_vect

8
base/modules/tools/psb_z_tools_mod.F90
Unescape Escape View File

@ -263,11 +263,15 @@ Module psb_z_tools_mod
end interface end interface
interface psb_remote_vect interface psb_remote_vect
subroutine psb_z_remote_vect(v,desc_a, info) subroutine psb_z_remote_vect(n,v,iv,desc_a,x,ix, info)
import import
implicit none implicit none
type(psb_z_vect_type),Intent(inout) :: v integer(psb_ipk_), intent(in) :: n
complex(psb_dpk_), intent(in) :: v(:)
integer(psb_lpk_), intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
complex(psb_dpk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_remote_vect end subroutine psb_z_remote_vect
end interface psb_remote_vect end interface psb_remote_vect

282
base/tools/psb_c_remote_mat.F90
Unescape Escape View File

@ -90,8 +90,7 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & n_elem, j, ipx,idxs,idxr
& data_,totxch,nxs, nxr, ncg
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem & lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth integer(psb_lpk_) :: nz,nouth
@ -140,14 +139,14 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros() nz = a%get_nzeros()
allocate(ila(nz)) !allocate(ila(nz))
!write(0,*) me,name,' size :',nz,size(ila) !write(0,*) me,name,' size :',nz,size(ila)
call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.)
nouth = count(ila(1:nz)<0) !nouth = count(ila(1:nz)<0)
!write(0,*) me,name,' Count out of halo :',nouth !write(0,*) me,name,' Count out of halo :',nouth
call psb_max(ctxt,nouth) !call psb_max(ctxt,nouth)
if ((nouth/=0).and.(me==0)) & !if ((nouth/=0).and.(me==0)) &
& write(0,*) 'Warning: would require reinit of DESC_A' ! & write(0,*) 'Warning: would require reinit of DESC_A'
call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info)
@ -277,7 +276,7 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info)
End Subroutine psb_lc_remote_mat End Subroutine psb_lc_remote_mat
subroutine psb_c_remote_vect(v,desc_a, info) subroutine psb_c_remote_vect(n,v,iv,desc_a,x,ix, info)
use psb_base_mod, psb_protect_name => psb_c_remote_vect use psb_base_mod, psb_protect_name => psb_c_remote_vect
#ifdef MPI_MOD #ifdef MPI_MOD
@ -287,29 +286,25 @@ subroutine psb_c_remote_vect(v,desc_a, info)
#ifdef MPI_H #ifdef MPI_H
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: n
type(psb_c_vect_type),Intent(inout) :: v complex(psb_spk_), Intent(in) :: v(:)
integer(psb_lpk_), Intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
complex(psb_spk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! ...local scalars.... ! ...local scalars....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & j, idxs,idxr, k, iszs, iszr
& data_,totxch,nxs, nxr, ncg, dupl_
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth
integer(psb_ipk_) :: nrcvs, nsnds integer(psb_ipk_) :: nrcvs, nsnds
integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_) :: icomm, minfo
integer(psb_mpk_), allocatable :: brvindx(:), & integer(psb_mpk_), allocatable :: brvindx(:), &
& rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:)
integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) integer(psb_lpk_), allocatable :: lsnd(:)
complex(psb_spk_), allocatable :: valsnd(:) complex(psb_spk_), allocatable :: valsnd(:)
integer(psb_ipk_), allocatable :: ila(:), iprc(:) integer(psb_ipk_), allocatable :: iprc(:)
logical :: rowcnv_,colcnv_,rowscale_,colscale_
character(len=5) :: outfmt_
integer(psb_ipk_) :: debug_level, debug_unit, err_act integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -327,150 +322,111 @@ subroutine psb_c_remote_vect(v,desc_a, info)
Call psb_info(ctxt, me, np) Call psb_info(ctxt, me, np)
dupl_ = v%get_dupl()
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start' & write(debug_unit,*) me,' ',trim(name),': Start'
write(0,*) me, 'X_remote_vect implementation to be completed ' write(0,*) me, 'X_remote_vect implementation to be completed '
!!$ call b%free()
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),&
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& & bsdindx(np+1), stat=info)
!!$ & bsdindx(np+1), acoo,stat=info)
!!$ if (info /= psb_success_) then
!!$ if (info /= psb_success_) then info=psb_err_alloc_dealloc_
!!$ info=psb_err_alloc_dealloc_ call psb_errpush(info,name)
!!$ call psb_errpush(info,name) goto 9999
!!$ goto 9999 end if
!!$ end if
!!$ call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info)
!!$
!!$ nz = a%get_nzeros() icomm = desc_a%get_mpic()
!!$ allocate(ila(nz)) sdsz(:) = 0
!!$ !write(0,*) me,name,' size :',nz,size(ila) rvsz(:) = 0
!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) sdsi(:) = 0
!!$ nouth = count(ila(1:nz)<0) rvsi(:) = 0
!!$ !write(0,*) me,name,' Count out of halo :',nouth brvindx(:) = 0
!!$ call psb_max(ctxt,nouth) bsdindx(:) = 0
!!$ if ((nouth/=0).and.(me==0)) & counter = 1
!!$ & write(0,*) 'Warning: would require reinit of DESC_A' idxs = 0
!!$ idxr = 0
!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) do i=1,n
!!$ if (iprc(i) >=0) then
!!$ icomm = desc_a%get_mpic() sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1
!!$ sdsz(:)=0 else
!!$ rvsz(:)=0 write(0,*)me,name,' Error from fnd_owner: ',iprc(i)
!!$ sdsi(:)=0 end if
!!$ rvsi(:)=0 end do
!!$ ipx = 1 call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
!!$ brvindx(:) = 0 & rvsz,1,psb_mpi_mpk_,icomm,minfo)
!!$ bsdindx(:) = 0 if (minfo /= psb_success_) then
!!$ counter=1 info=psb_err_from_subroutine_
!!$ idx = 0 call psb_errpush(info,name,a_err='mpi_alltoall')
!!$ idxs = 0 goto 9999
!!$ idxr = 0 end if
!!$ do i=1,nz !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!!$ if (iprc(i) >=0) then nsnds = count(sdsz /= 0)
!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 nrcvs = count(rvsz /= 0)
!!$ else idxs = 0
!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) idxr = 0
!!$ end if counter = 1
!!$ end do Do proc=0,np-1
!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& bsdindx(proc+1) = idxs
!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) idxs = idxs + sdsz(proc+1)
!!$ if (minfo /= psb_success_) then brvindx(proc+1) = idxr
!!$ info=psb_err_from_subroutine_ idxr = idxr + rvsz(proc+1)
!!$ call psb_errpush(info,name,a_err='mpi_alltoall') Enddo
!!$ goto 9999
!!$ end if iszs = sum(sdsz)
!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) iszr = sum(rvsz)
!!$ nsnds = count(sdsz /= 0) call psb_realloc(iszs,lsnd,info)
!!$ nrcvs = count(rvsz /= 0) if (info == 0) call psb_realloc(iszs,valsnd,info)
!!$ idxs = 0 if (info == 0) call psb_realloc(iszr,x,info)
!!$ idxr = 0 if (info == 0) call psb_realloc(iszr,ix,info)
!!$ counter = 1 if (info /= psb_success_) then
!!$ Do proc=0,np-1 info=psb_err_from_subroutine_
!!$ bsdindx(proc+1) = idxs call psb_errpush(info,name,a_err='realloc')
!!$ idxs = idxs + sdsz(proc+1) goto 9999
!!$ brvindx(proc+1) = idxr end if
!!$ idxr = idxr + rvsz(proc+1) do k=1, n
!!$ Enddo proc = iprc(k)
!!$ sdsi(proc+1) = sdsi(proc+1) + 1
!!$ iszs = sum(sdsz) lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k)
!!$ iszr = sum(rvsz) valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k)
!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) end do
!!$ if (psb_errstatus_fatal()) then do proc=0,np-1
!!$ write(0,*) 'Error from acoo%allocate ' if (sdsi(proc+1) /= sdsz(proc+1)) &
!!$ info = 4010 & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ goto 9999 end do
!!$ end if
!!$ if (debug_level >= psb_debug_outer_)& select case(psb_get_sp_a2av_alg())
!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_)
!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),': ',info & x,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info & ix,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) case(psb_sp_a2av_mpi_)
!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,&
!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info & x,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo)
!!$ if (info /= psb_success_) then if (minfo == mpi_success) &
!!$ info=psb_err_from_subroutine_ & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ call psb_errpush(info,name,a_err='ensure_size') & ix,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ goto 9999 if (minfo /= mpi_success) info = minfo
!!$ end if case default
!!$ do k=1, nz info = psb_err_internal_error_
!!$ proc = iprc(k) call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ sdsi(proc+1) = sdsi(proc+1) + 1 goto 9999
!!$ !rvsi(proc) = rvsi(proc) + 1 end select
!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k)
!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) if (info /= psb_success_) then
!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) info=psb_err_from_subroutine_
!!$ end do call psb_errpush(info,name,a_err='alltoallv')
!!$ do proc=0,np-1 goto 9999
!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & end if
!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ end do Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & lsnd,valsnd,stat=info)
!!$ select case(psb_get_sp_a2av_alg()) if (debug_level >= psb_debug_outer_)&
!!$ case(psb_sp_a2av_smpl_triad_) & write(debug_unit,*) me,' ',trim(name),': Done'
!!$ call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
!!$ & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_smpl_v_)
!!$ call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ & acoo%val,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,&
!!$ & acoo%ia,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,&
!!$ & acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_mpi_)
!!$
!!$ call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,&
!!$ & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo /= mpi_success) info = minfo
!!$ case default
!!$ info = psb_err_internal_error_
!!$ call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ goto 9999
!!$ end select
!!$
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='alltoallv')
!!$ goto 9999
!!$ end if
!!$ call acoo%set_nzeros(iszr)
!!$ call acoo%mv_to_coo(b,info)
!!$
!!$ Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & iasnd,jasnd,valsnd,stat=info)
!!$ if (debug_level >= psb_debug_outer_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -480,5 +436,3 @@ subroutine psb_c_remote_vect(v,desc_a, info)
return return
End Subroutine psb_c_remote_vect End Subroutine psb_c_remote_vect

5
base/tools/psb_callc.f90
Unescape Escape View File

@ -116,9 +116,11 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
end if end if
call x%set_dupl(dupl_) call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(0)
if (x%is_remote_build()) then if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x%rmtv(nrmt_)) call psb_ensure_size(nrmt_,x%rmtv,info)
call psb_ensure_size(nrmt_,x%rmidx,info)
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -129,6 +131,7 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
return return
end subroutine psb_calloc_vect end subroutine psb_calloc_vect
! Function: psb_calloc_vect_r2 ! Function: psb_calloc_vect_r2
! Allocates a vector of dense vectors for PSBLAS routines. ! Allocates a vector of dense vectors for PSBLAS routines.
! The descriptor may be in either the build or assembled state. ! The descriptor may be in either the build or assembled state.

18
base/tools/psb_casb.f90
Unescape Escape View File

@ -104,7 +104,23 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
call x%free(info) call x%free(info)
call x%bld(ncol,mold=mold) call x%bld(ncol,mold=mold)
else else
if (x%is_remote_build()) call psb_c_remote_vect(x,desc_a,info)
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_c_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
call x%asb(ncol,info) call x%asb(ncol,info)
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x,desc_a,info) call psb_halo(x,desc_a,info)

39
base/tools/psb_cins.f90
Unescape Escape View File

@ -116,7 +116,6 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -128,11 +127,33 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (x%is_remote_build()) then
block
integer(psb_ipk_) :: j,k
k = x%get_nrmv()
do j=1,m
if (irl(j) < 0 ) then
k = k + 1
call psb_ensure_size(k,x%rmtv,info)
if (info == 0) call psb_ensure_size(k,x%rmidx,info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
x%rmtv(k) = val(j)
x%rmidx(k) = irw(j)
call x%set_nrmv(k)
end if
end do
end block
end if
deallocate(irl) deallocate(irl)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -180,7 +201,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_) :: np, me
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
complex(psb_spk_), allocatable :: lval(:) complex(psb_spk_), allocatable :: lval(:)
logical :: local_ logical :: local_
@ -227,7 +248,6 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -241,7 +261,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,dupl_,info) call x%ins(m,irl,lval,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -277,7 +297,6 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local)
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_ipk_) :: i, loc_rows,loc_cols, n
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
@ -349,8 +368,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) dupl_ = x(i)%get_dupl() if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then
@ -390,7 +408,7 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
logical :: local_ logical :: local_
character(len=20) :: name character(len=20) :: name
@ -446,7 +464,6 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -458,7 +475,7 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999

1
base/tools/psb_cspasb.f90
Unescape Escape View File

@ -109,7 +109,6 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: nz, nzt,k integer(psb_ipk_) :: nz, nzt,k
call psb_remote_mat(a%rmta,desc_a,a_add,info) call psb_remote_mat(a%rmta,desc_a,a_add,info)
nz = a_add%get_nzeros() nz = a_add%get_nzeros()
!!$ write(0,*) me,name,' Nz to be added',nz
nzt = nz nzt = nz
call psb_sum(ctxt,nzt) call psb_sum(ctxt,nzt)
if (nzt>0) then if (nzt>0) then

282
base/tools/psb_d_remote_mat.F90
Unescape Escape View File

@ -90,8 +90,7 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & n_elem, j, ipx,idxs,idxr
& data_,totxch,nxs, nxr, ncg
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem & lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth integer(psb_lpk_) :: nz,nouth
@ -140,14 +139,14 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros() nz = a%get_nzeros()
allocate(ila(nz)) !allocate(ila(nz))
!write(0,*) me,name,' size :',nz,size(ila) !write(0,*) me,name,' size :',nz,size(ila)
call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.)
nouth = count(ila(1:nz)<0) !nouth = count(ila(1:nz)<0)
!write(0,*) me,name,' Count out of halo :',nouth !write(0,*) me,name,' Count out of halo :',nouth
call psb_max(ctxt,nouth) !call psb_max(ctxt,nouth)
if ((nouth/=0).and.(me==0)) & !if ((nouth/=0).and.(me==0)) &
& write(0,*) 'Warning: would require reinit of DESC_A' ! & write(0,*) 'Warning: would require reinit of DESC_A'
call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info)
@ -277,7 +276,7 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info)
End Subroutine psb_ld_remote_mat End Subroutine psb_ld_remote_mat
subroutine psb_d_remote_vect(v,desc_a, info) subroutine psb_d_remote_vect(n,v,iv,desc_a,x,ix, info)
use psb_base_mod, psb_protect_name => psb_d_remote_vect use psb_base_mod, psb_protect_name => psb_d_remote_vect
#ifdef MPI_MOD #ifdef MPI_MOD
@ -287,29 +286,25 @@ subroutine psb_d_remote_vect(v,desc_a, info)
#ifdef MPI_H #ifdef MPI_H
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: n
type(psb_d_vect_type),Intent(inout) :: v real(psb_dpk_), Intent(in) :: v(:)
integer(psb_lpk_), Intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
real(psb_dpk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! ...local scalars.... ! ...local scalars....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & j, idxs,idxr, k, iszs, iszr
& data_,totxch,nxs, nxr, ncg, dupl_
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth
integer(psb_ipk_) :: nrcvs, nsnds integer(psb_ipk_) :: nrcvs, nsnds
integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_) :: icomm, minfo
integer(psb_mpk_), allocatable :: brvindx(:), & integer(psb_mpk_), allocatable :: brvindx(:), &
& rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:)
integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) integer(psb_lpk_), allocatable :: lsnd(:)
real(psb_dpk_), allocatable :: valsnd(:) real(psb_dpk_), allocatable :: valsnd(:)
integer(psb_ipk_), allocatable :: ila(:), iprc(:) integer(psb_ipk_), allocatable :: iprc(:)
logical :: rowcnv_,colcnv_,rowscale_,colscale_
character(len=5) :: outfmt_
integer(psb_ipk_) :: debug_level, debug_unit, err_act integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -327,150 +322,111 @@ subroutine psb_d_remote_vect(v,desc_a, info)
Call psb_info(ctxt, me, np) Call psb_info(ctxt, me, np)
dupl_ = v%get_dupl()
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start' & write(debug_unit,*) me,' ',trim(name),': Start'
write(0,*) me, 'X_remote_vect implementation to be completed ' write(0,*) me, 'X_remote_vect implementation to be completed '
!!$ call b%free()
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),&
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& & bsdindx(np+1), stat=info)
!!$ & bsdindx(np+1), acoo,stat=info)
!!$ if (info /= psb_success_) then
!!$ if (info /= psb_success_) then info=psb_err_alloc_dealloc_
!!$ info=psb_err_alloc_dealloc_ call psb_errpush(info,name)
!!$ call psb_errpush(info,name) goto 9999
!!$ goto 9999 end if
!!$ end if
!!$ call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info)
!!$
!!$ nz = a%get_nzeros() icomm = desc_a%get_mpic()
!!$ allocate(ila(nz)) sdsz(:) = 0
!!$ !write(0,*) me,name,' size :',nz,size(ila) rvsz(:) = 0
!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) sdsi(:) = 0
!!$ nouth = count(ila(1:nz)<0) rvsi(:) = 0
!!$ !write(0,*) me,name,' Count out of halo :',nouth brvindx(:) = 0
!!$ call psb_max(ctxt,nouth) bsdindx(:) = 0
!!$ if ((nouth/=0).and.(me==0)) & counter = 1
!!$ & write(0,*) 'Warning: would require reinit of DESC_A' idxs = 0
!!$ idxr = 0
!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) do i=1,n
!!$ if (iprc(i) >=0) then
!!$ icomm = desc_a%get_mpic() sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1
!!$ sdsz(:)=0 else
!!$ rvsz(:)=0 write(0,*)me,name,' Error from fnd_owner: ',iprc(i)
!!$ sdsi(:)=0 end if
!!$ rvsi(:)=0 end do
!!$ ipx = 1 call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
!!$ brvindx(:) = 0 & rvsz,1,psb_mpi_mpk_,icomm,minfo)
!!$ bsdindx(:) = 0 if (minfo /= psb_success_) then
!!$ counter=1 info=psb_err_from_subroutine_
!!$ idx = 0 call psb_errpush(info,name,a_err='mpi_alltoall')
!!$ idxs = 0 goto 9999
!!$ idxr = 0 end if
!!$ do i=1,nz !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!!$ if (iprc(i) >=0) then nsnds = count(sdsz /= 0)
!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 nrcvs = count(rvsz /= 0)
!!$ else idxs = 0
!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) idxr = 0
!!$ end if counter = 1
!!$ end do Do proc=0,np-1
!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& bsdindx(proc+1) = idxs
!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) idxs = idxs + sdsz(proc+1)
!!$ if (minfo /= psb_success_) then brvindx(proc+1) = idxr
!!$ info=psb_err_from_subroutine_ idxr = idxr + rvsz(proc+1)
!!$ call psb_errpush(info,name,a_err='mpi_alltoall') Enddo
!!$ goto 9999
!!$ end if iszs = sum(sdsz)
!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) iszr = sum(rvsz)
!!$ nsnds = count(sdsz /= 0) call psb_realloc(iszs,lsnd,info)
!!$ nrcvs = count(rvsz /= 0) if (info == 0) call psb_realloc(iszs,valsnd,info)
!!$ idxs = 0 if (info == 0) call psb_realloc(iszr,x,info)
!!$ idxr = 0 if (info == 0) call psb_realloc(iszr,ix,info)
!!$ counter = 1 if (info /= psb_success_) then
!!$ Do proc=0,np-1 info=psb_err_from_subroutine_
!!$ bsdindx(proc+1) = idxs call psb_errpush(info,name,a_err='realloc')
!!$ idxs = idxs + sdsz(proc+1) goto 9999
!!$ brvindx(proc+1) = idxr end if
!!$ idxr = idxr + rvsz(proc+1) do k=1, n
!!$ Enddo proc = iprc(k)
!!$ sdsi(proc+1) = sdsi(proc+1) + 1
!!$ iszs = sum(sdsz) lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k)
!!$ iszr = sum(rvsz) valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k)
!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) end do
!!$ if (psb_errstatus_fatal()) then do proc=0,np-1
!!$ write(0,*) 'Error from acoo%allocate ' if (sdsi(proc+1) /= sdsz(proc+1)) &
!!$ info = 4010 & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ goto 9999 end do
!!$ end if
!!$ if (debug_level >= psb_debug_outer_)& select case(psb_get_sp_a2av_alg())
!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_)
!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),': ',info & x,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info & ix,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) case(psb_sp_a2av_mpi_)
!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,&
!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info & x,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo)
!!$ if (info /= psb_success_) then if (minfo == mpi_success) &
!!$ info=psb_err_from_subroutine_ & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ call psb_errpush(info,name,a_err='ensure_size') & ix,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ goto 9999 if (minfo /= mpi_success) info = minfo
!!$ end if case default
!!$ do k=1, nz info = psb_err_internal_error_
!!$ proc = iprc(k) call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ sdsi(proc+1) = sdsi(proc+1) + 1 goto 9999
!!$ !rvsi(proc) = rvsi(proc) + 1 end select
!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k)
!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) if (info /= psb_success_) then
!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) info=psb_err_from_subroutine_
!!$ end do call psb_errpush(info,name,a_err='alltoallv')
!!$ do proc=0,np-1 goto 9999
!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & end if
!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ end do Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & lsnd,valsnd,stat=info)
!!$ select case(psb_get_sp_a2av_alg()) if (debug_level >= psb_debug_outer_)&
!!$ case(psb_sp_a2av_smpl_triad_) & write(debug_unit,*) me,' ',trim(name),': Done'
!!$ call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
!!$ & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_smpl_v_)
!!$ call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ & acoo%val,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,&
!!$ & acoo%ia,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,&
!!$ & acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_mpi_)
!!$
!!$ call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,&
!!$ & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo /= mpi_success) info = minfo
!!$ case default
!!$ info = psb_err_internal_error_
!!$ call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ goto 9999
!!$ end select
!!$
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='alltoallv')
!!$ goto 9999
!!$ end if
!!$ call acoo%set_nzeros(iszr)
!!$ call acoo%mv_to_coo(b,info)
!!$
!!$ Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & iasnd,jasnd,valsnd,stat=info)
!!$ if (debug_level >= psb_debug_outer_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -480,5 +436,3 @@ subroutine psb_d_remote_vect(v,desc_a, info)
return return
End Subroutine psb_d_remote_vect End Subroutine psb_d_remote_vect

5
base/tools/psb_dallc.f90
Unescape Escape View File

@ -116,9 +116,11 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
end if end if
call x%set_dupl(dupl_) call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(0)
if (x%is_remote_build()) then if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x%rmtv(nrmt_)) call psb_ensure_size(nrmt_,x%rmtv,info)
call psb_ensure_size(nrmt_,x%rmidx,info)
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -129,6 +131,7 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
return return
end subroutine psb_dalloc_vect end subroutine psb_dalloc_vect
! Function: psb_dalloc_vect_r2 ! Function: psb_dalloc_vect_r2
! Allocates a vector of dense vectors for PSBLAS routines. ! Allocates a vector of dense vectors for PSBLAS routines.
! The descriptor may be in either the build or assembled state. ! The descriptor may be in either the build or assembled state.

18
base/tools/psb_dasb.f90
Unescape Escape View File

@ -104,7 +104,23 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
call x%free(info) call x%free(info)
call x%bld(ncol,mold=mold) call x%bld(ncol,mold=mold)
else else
if (x%is_remote_build()) call psb_d_remote_vect(x,desc_a,info)
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
real(psb_dpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_d_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
call x%asb(ncol,info) call x%asb(ncol,info)
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x,desc_a,info) call psb_halo(x,desc_a,info)

39
base/tools/psb_dins.f90
Unescape Escape View File

@ -116,7 +116,6 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -128,11 +127,33 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (x%is_remote_build()) then
block
integer(psb_ipk_) :: j,k
k = x%get_nrmv()
do j=1,m
if (irl(j) < 0 ) then
k = k + 1
call psb_ensure_size(k,x%rmtv,info)
if (info == 0) call psb_ensure_size(k,x%rmidx,info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
x%rmtv(k) = val(j)
x%rmidx(k) = irw(j)
call x%set_nrmv(k)
end if
end do
end block
end if
deallocate(irl) deallocate(irl)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -180,7 +201,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_) :: np, me
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
real(psb_dpk_), allocatable :: lval(:) real(psb_dpk_), allocatable :: lval(:)
logical :: local_ logical :: local_
@ -227,7 +248,6 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -241,7 +261,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,dupl_,info) call x%ins(m,irl,lval,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -277,7 +297,6 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, local)
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_ipk_) :: i, loc_rows,loc_cols, n
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
@ -349,8 +368,7 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) dupl_ = x(i)%get_dupl() if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then
@ -390,7 +408,7 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
logical :: local_ logical :: local_
character(len=20) :: name character(len=20) :: name
@ -446,7 +464,6 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -458,7 +475,7 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999

1
base/tools/psb_dspasb.f90
Unescape Escape View File

@ -109,7 +109,6 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: nz, nzt,k integer(psb_ipk_) :: nz, nzt,k
call psb_remote_mat(a%rmta,desc_a,a_add,info) call psb_remote_mat(a%rmta,desc_a,a_add,info)
nz = a_add%get_nzeros() nz = a_add%get_nzeros()
!!$ write(0,*) me,name,' Nz to be added',nz
nzt = nz nzt = nz
call psb_sum(ctxt,nzt) call psb_sum(ctxt,nzt)
if (nzt>0) then if (nzt>0) then

5
base/tools/psb_iallc.f90
Unescape Escape View File

@ -116,9 +116,11 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode)
end if end if
call x%set_dupl(dupl_) call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(0)
if (x%is_remote_build()) then if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x%rmtv(nrmt_)) call psb_ensure_size(nrmt_,x%rmtv,info)
call psb_ensure_size(nrmt_,x%rmidx,info)
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -129,6 +131,7 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode)
return return
end subroutine psb_ialloc_vect end subroutine psb_ialloc_vect
! Function: psb_ialloc_vect_r2 ! Function: psb_ialloc_vect_r2
! Allocates a vector of dense vectors for PSBLAS routines. ! Allocates a vector of dense vectors for PSBLAS routines.
! The descriptor may be in either the build or assembled state. ! The descriptor may be in either the build or assembled state.

18
base/tools/psb_iasb.f90
Unescape Escape View File

@ -104,7 +104,23 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
call x%free(info) call x%free(info)
call x%bld(ncol,mold=mold) call x%bld(ncol,mold=mold)
else else
if (x%is_remote_build()) call psb_i_remote_vect(x,desc_a,info)
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_ipk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_i_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
call x%asb(ncol,info) call x%asb(ncol,info)
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x,desc_a,info) call psb_halo(x,desc_a,info)

39
base/tools/psb_iins.f90
Unescape Escape View File

@ -116,7 +116,6 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -128,11 +127,33 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (x%is_remote_build()) then
block
integer(psb_ipk_) :: j,k
k = x%get_nrmv()
do j=1,m
if (irl(j) < 0 ) then
k = k + 1
call psb_ensure_size(k,x%rmtv,info)
if (info == 0) call psb_ensure_size(k,x%rmidx,info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
x%rmtv(k) = val(j)
x%rmidx(k) = irw(j)
call x%set_nrmv(k)
end if
end do
end block
end if
deallocate(irl) deallocate(irl)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -180,7 +201,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_) :: np, me
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
integer(psb_ipk_), allocatable :: lval(:) integer(psb_ipk_), allocatable :: lval(:)
logical :: local_ logical :: local_
@ -227,7 +248,6 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -241,7 +261,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,dupl_,info) call x%ins(m,irl,lval,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -277,7 +297,6 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, local)
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_ipk_) :: i, loc_rows,loc_cols, n
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
@ -349,8 +368,7 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) dupl_ = x(i)%get_dupl() if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then
@ -390,7 +408,7 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
logical :: local_ logical :: local_
character(len=20) :: name character(len=20) :: name
@ -446,7 +464,6 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -458,7 +475,7 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999

5
base/tools/psb_lallc.f90
Unescape Escape View File

@ -116,9 +116,11 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode)
end if end if
call x%set_dupl(dupl_) call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(0)
if (x%is_remote_build()) then if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x%rmtv(nrmt_)) call psb_ensure_size(nrmt_,x%rmtv,info)
call psb_ensure_size(nrmt_,x%rmidx,info)
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -129,6 +131,7 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode)
return return
end subroutine psb_lalloc_vect end subroutine psb_lalloc_vect
! Function: psb_lalloc_vect_r2 ! Function: psb_lalloc_vect_r2
! Allocates a vector of dense vectors for PSBLAS routines. ! Allocates a vector of dense vectors for PSBLAS routines.
! The descriptor may be in either the build or assembled state. ! The descriptor may be in either the build or assembled state.

18
base/tools/psb_lasb.f90
Unescape Escape View File

@ -104,7 +104,23 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
call x%free(info) call x%free(info)
call x%bld(ncol,mold=mold) call x%bld(ncol,mold=mold)
else else
if (x%is_remote_build()) call psb_l_remote_vect(x,desc_a,info)
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
integer(psb_lpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_l_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
call x%asb(ncol,info) call x%asb(ncol,info)
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x,desc_a,info) call psb_halo(x,desc_a,info)

39
base/tools/psb_lins.f90
Unescape Escape View File

@ -116,7 +116,6 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -128,11 +127,33 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (x%is_remote_build()) then
block
integer(psb_ipk_) :: j,k
k = x%get_nrmv()
do j=1,m
if (irl(j) < 0 ) then
k = k + 1
call psb_ensure_size(k,x%rmtv,info)
if (info == 0) call psb_ensure_size(k,x%rmidx,info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
x%rmtv(k) = val(j)
x%rmidx(k) = irw(j)
call x%set_nrmv(k)
end if
end do
end block
end if
deallocate(irl) deallocate(irl)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -180,7 +201,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_) :: np, me
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
integer(psb_lpk_), allocatable :: lval(:) integer(psb_lpk_), allocatable :: lval(:)
logical :: local_ logical :: local_
@ -227,7 +248,6 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -241,7 +261,7 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,dupl_,info) call x%ins(m,irl,lval,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -277,7 +297,6 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, local)
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_ipk_) :: i, loc_rows,loc_cols, n
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
@ -349,8 +368,7 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) dupl_ = x(i)%get_dupl() if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then
@ -390,7 +408,7 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
logical :: local_ logical :: local_
character(len=20) :: name character(len=20) :: name
@ -446,7 +464,6 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -458,7 +475,7 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999

282
base/tools/psb_s_remote_mat.F90
Unescape Escape View File

@ -90,8 +90,7 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & n_elem, j, ipx,idxs,idxr
& data_,totxch,nxs, nxr, ncg
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem & lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth integer(psb_lpk_) :: nz,nouth
@ -140,14 +139,14 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros() nz = a%get_nzeros()
allocate(ila(nz)) !allocate(ila(nz))
!write(0,*) me,name,' size :',nz,size(ila) !write(0,*) me,name,' size :',nz,size(ila)
call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.)
nouth = count(ila(1:nz)<0) !nouth = count(ila(1:nz)<0)
!write(0,*) me,name,' Count out of halo :',nouth !write(0,*) me,name,' Count out of halo :',nouth
call psb_max(ctxt,nouth) !call psb_max(ctxt,nouth)
if ((nouth/=0).and.(me==0)) & !if ((nouth/=0).and.(me==0)) &
& write(0,*) 'Warning: would require reinit of DESC_A' ! & write(0,*) 'Warning: would require reinit of DESC_A'
call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info)
@ -277,7 +276,7 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info)
End Subroutine psb_ls_remote_mat End Subroutine psb_ls_remote_mat
subroutine psb_s_remote_vect(v,desc_a, info) subroutine psb_s_remote_vect(n,v,iv,desc_a,x,ix, info)
use psb_base_mod, psb_protect_name => psb_s_remote_vect use psb_base_mod, psb_protect_name => psb_s_remote_vect
#ifdef MPI_MOD #ifdef MPI_MOD
@ -287,29 +286,25 @@ subroutine psb_s_remote_vect(v,desc_a, info)
#ifdef MPI_H #ifdef MPI_H
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: n
type(psb_s_vect_type),Intent(inout) :: v real(psb_spk_), Intent(in) :: v(:)
integer(psb_lpk_), Intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
real(psb_spk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! ...local scalars.... ! ...local scalars....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & j, idxs,idxr, k, iszs, iszr
& data_,totxch,nxs, nxr, ncg, dupl_
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth
integer(psb_ipk_) :: nrcvs, nsnds integer(psb_ipk_) :: nrcvs, nsnds
integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_) :: icomm, minfo
integer(psb_mpk_), allocatable :: brvindx(:), & integer(psb_mpk_), allocatable :: brvindx(:), &
& rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:)
integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) integer(psb_lpk_), allocatable :: lsnd(:)
real(psb_spk_), allocatable :: valsnd(:) real(psb_spk_), allocatable :: valsnd(:)
integer(psb_ipk_), allocatable :: ila(:), iprc(:) integer(psb_ipk_), allocatable :: iprc(:)
logical :: rowcnv_,colcnv_,rowscale_,colscale_
character(len=5) :: outfmt_
integer(psb_ipk_) :: debug_level, debug_unit, err_act integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -327,150 +322,111 @@ subroutine psb_s_remote_vect(v,desc_a, info)
Call psb_info(ctxt, me, np) Call psb_info(ctxt, me, np)
dupl_ = v%get_dupl()
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start' & write(debug_unit,*) me,' ',trim(name),': Start'
write(0,*) me, 'X_remote_vect implementation to be completed ' write(0,*) me, 'X_remote_vect implementation to be completed '
!!$ call b%free()
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),&
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& & bsdindx(np+1), stat=info)
!!$ & bsdindx(np+1), acoo,stat=info)
!!$ if (info /= psb_success_) then
!!$ if (info /= psb_success_) then info=psb_err_alloc_dealloc_
!!$ info=psb_err_alloc_dealloc_ call psb_errpush(info,name)
!!$ call psb_errpush(info,name) goto 9999
!!$ goto 9999 end if
!!$ end if
!!$ call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info)
!!$
!!$ nz = a%get_nzeros() icomm = desc_a%get_mpic()
!!$ allocate(ila(nz)) sdsz(:) = 0
!!$ !write(0,*) me,name,' size :',nz,size(ila) rvsz(:) = 0
!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) sdsi(:) = 0
!!$ nouth = count(ila(1:nz)<0) rvsi(:) = 0
!!$ !write(0,*) me,name,' Count out of halo :',nouth brvindx(:) = 0
!!$ call psb_max(ctxt,nouth) bsdindx(:) = 0
!!$ if ((nouth/=0).and.(me==0)) & counter = 1
!!$ & write(0,*) 'Warning: would require reinit of DESC_A' idxs = 0
!!$ idxr = 0
!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) do i=1,n
!!$ if (iprc(i) >=0) then
!!$ icomm = desc_a%get_mpic() sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1
!!$ sdsz(:)=0 else
!!$ rvsz(:)=0 write(0,*)me,name,' Error from fnd_owner: ',iprc(i)
!!$ sdsi(:)=0 end if
!!$ rvsi(:)=0 end do
!!$ ipx = 1 call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
!!$ brvindx(:) = 0 & rvsz,1,psb_mpi_mpk_,icomm,minfo)
!!$ bsdindx(:) = 0 if (minfo /= psb_success_) then
!!$ counter=1 info=psb_err_from_subroutine_
!!$ idx = 0 call psb_errpush(info,name,a_err='mpi_alltoall')
!!$ idxs = 0 goto 9999
!!$ idxr = 0 end if
!!$ do i=1,nz !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!!$ if (iprc(i) >=0) then nsnds = count(sdsz /= 0)
!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 nrcvs = count(rvsz /= 0)
!!$ else idxs = 0
!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) idxr = 0
!!$ end if counter = 1
!!$ end do Do proc=0,np-1
!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& bsdindx(proc+1) = idxs
!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) idxs = idxs + sdsz(proc+1)
!!$ if (minfo /= psb_success_) then brvindx(proc+1) = idxr
!!$ info=psb_err_from_subroutine_ idxr = idxr + rvsz(proc+1)
!!$ call psb_errpush(info,name,a_err='mpi_alltoall') Enddo
!!$ goto 9999
!!$ end if iszs = sum(sdsz)
!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) iszr = sum(rvsz)
!!$ nsnds = count(sdsz /= 0) call psb_realloc(iszs,lsnd,info)
!!$ nrcvs = count(rvsz /= 0) if (info == 0) call psb_realloc(iszs,valsnd,info)
!!$ idxs = 0 if (info == 0) call psb_realloc(iszr,x,info)
!!$ idxr = 0 if (info == 0) call psb_realloc(iszr,ix,info)
!!$ counter = 1 if (info /= psb_success_) then
!!$ Do proc=0,np-1 info=psb_err_from_subroutine_
!!$ bsdindx(proc+1) = idxs call psb_errpush(info,name,a_err='realloc')
!!$ idxs = idxs + sdsz(proc+1) goto 9999
!!$ brvindx(proc+1) = idxr end if
!!$ idxr = idxr + rvsz(proc+1) do k=1, n
!!$ Enddo proc = iprc(k)
!!$ sdsi(proc+1) = sdsi(proc+1) + 1
!!$ iszs = sum(sdsz) lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k)
!!$ iszr = sum(rvsz) valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k)
!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) end do
!!$ if (psb_errstatus_fatal()) then do proc=0,np-1
!!$ write(0,*) 'Error from acoo%allocate ' if (sdsi(proc+1) /= sdsz(proc+1)) &
!!$ info = 4010 & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ goto 9999 end do
!!$ end if
!!$ if (debug_level >= psb_debug_outer_)& select case(psb_get_sp_a2av_alg())
!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_)
!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),': ',info & x,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info & ix,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) case(psb_sp_a2av_mpi_)
!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,&
!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info & x,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo)
!!$ if (info /= psb_success_) then if (minfo == mpi_success) &
!!$ info=psb_err_from_subroutine_ & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ call psb_errpush(info,name,a_err='ensure_size') & ix,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ goto 9999 if (minfo /= mpi_success) info = minfo
!!$ end if case default
!!$ do k=1, nz info = psb_err_internal_error_
!!$ proc = iprc(k) call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ sdsi(proc+1) = sdsi(proc+1) + 1 goto 9999
!!$ !rvsi(proc) = rvsi(proc) + 1 end select
!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k)
!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) if (info /= psb_success_) then
!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) info=psb_err_from_subroutine_
!!$ end do call psb_errpush(info,name,a_err='alltoallv')
!!$ do proc=0,np-1 goto 9999
!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & end if
!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ end do Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & lsnd,valsnd,stat=info)
!!$ select case(psb_get_sp_a2av_alg()) if (debug_level >= psb_debug_outer_)&
!!$ case(psb_sp_a2av_smpl_triad_) & write(debug_unit,*) me,' ',trim(name),': Done'
!!$ call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
!!$ & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_smpl_v_)
!!$ call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ & acoo%val,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,&
!!$ & acoo%ia,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,&
!!$ & acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_mpi_)
!!$
!!$ call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,&
!!$ & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo /= mpi_success) info = minfo
!!$ case default
!!$ info = psb_err_internal_error_
!!$ call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ goto 9999
!!$ end select
!!$
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='alltoallv')
!!$ goto 9999
!!$ end if
!!$ call acoo%set_nzeros(iszr)
!!$ call acoo%mv_to_coo(b,info)
!!$
!!$ Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & iasnd,jasnd,valsnd,stat=info)
!!$ if (debug_level >= psb_debug_outer_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -480,5 +436,3 @@ subroutine psb_s_remote_vect(v,desc_a, info)
return return
End Subroutine psb_s_remote_vect End Subroutine psb_s_remote_vect

5
base/tools/psb_sallc.f90
Unescape Escape View File

@ -116,9 +116,11 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode)
end if end if
call x%set_dupl(dupl_) call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(0)
if (x%is_remote_build()) then if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x%rmtv(nrmt_)) call psb_ensure_size(nrmt_,x%rmtv,info)
call psb_ensure_size(nrmt_,x%rmidx,info)
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -129,6 +131,7 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode)
return return
end subroutine psb_salloc_vect end subroutine psb_salloc_vect
! Function: psb_salloc_vect_r2 ! Function: psb_salloc_vect_r2
! Allocates a vector of dense vectors for PSBLAS routines. ! Allocates a vector of dense vectors for PSBLAS routines.
! The descriptor may be in either the build or assembled state. ! The descriptor may be in either the build or assembled state.

18
base/tools/psb_sasb.f90
Unescape Escape View File

@ -104,7 +104,23 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
call x%free(info) call x%free(info)
call x%bld(ncol,mold=mold) call x%bld(ncol,mold=mold)
else else
if (x%is_remote_build()) call psb_s_remote_vect(x,desc_a,info)
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
real(psb_spk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_s_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
call x%asb(ncol,info) call x%asb(ncol,info)
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x,desc_a,info) call psb_halo(x,desc_a,info)

39
base/tools/psb_sins.f90
Unescape Escape View File

@ -116,7 +116,6 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -128,11 +127,33 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (x%is_remote_build()) then
block
integer(psb_ipk_) :: j,k
k = x%get_nrmv()
do j=1,m
if (irl(j) < 0 ) then
k = k + 1
call psb_ensure_size(k,x%rmtv,info)
if (info == 0) call psb_ensure_size(k,x%rmidx,info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
x%rmtv(k) = val(j)
x%rmidx(k) = irw(j)
call x%set_nrmv(k)
end if
end do
end block
end if
deallocate(irl) deallocate(irl)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -180,7 +201,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_) :: np, me
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
real(psb_spk_), allocatable :: lval(:) real(psb_spk_), allocatable :: lval(:)
logical :: local_ logical :: local_
@ -227,7 +248,6 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -241,7 +261,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,dupl_,info) call x%ins(m,irl,lval,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -277,7 +297,6 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, local)
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_ipk_) :: i, loc_rows,loc_cols, n
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
@ -349,8 +368,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) dupl_ = x(i)%get_dupl() if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then
@ -390,7 +408,7 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
logical :: local_ logical :: local_
character(len=20) :: name character(len=20) :: name
@ -446,7 +464,6 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -458,7 +475,7 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999

1
base/tools/psb_sspasb.f90
Unescape Escape View File

@ -109,7 +109,6 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: nz, nzt,k integer(psb_ipk_) :: nz, nzt,k
call psb_remote_mat(a%rmta,desc_a,a_add,info) call psb_remote_mat(a%rmta,desc_a,a_add,info)
nz = a_add%get_nzeros() nz = a_add%get_nzeros()
!!$ write(0,*) me,name,' Nz to be added',nz
nzt = nz nzt = nz
call psb_sum(ctxt,nzt) call psb_sum(ctxt,nzt)
if (nzt>0) then if (nzt>0) then

282
base/tools/psb_z_remote_mat.F90
Unescape Escape View File

@ -90,8 +90,7 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & n_elem, j, ipx,idxs,idxr
& data_,totxch,nxs, nxr, ncg
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem & lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth integer(psb_lpk_) :: nz,nouth
@ -140,14 +139,14 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info)
nz = a%get_nzeros() nz = a%get_nzeros()
allocate(ila(nz)) !allocate(ila(nz))
!write(0,*) me,name,' size :',nz,size(ila) !write(0,*) me,name,' size :',nz,size(ila)
call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.)
nouth = count(ila(1:nz)<0) !nouth = count(ila(1:nz)<0)
!write(0,*) me,name,' Count out of halo :',nouth !write(0,*) me,name,' Count out of halo :',nouth
call psb_max(ctxt,nouth) !call psb_max(ctxt,nouth)
if ((nouth/=0).and.(me==0)) & !if ((nouth/=0).and.(me==0)) &
& write(0,*) 'Warning: would require reinit of DESC_A' ! & write(0,*) 'Warning: would require reinit of DESC_A'
call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info)
@ -277,7 +276,7 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info)
End Subroutine psb_lz_remote_mat End Subroutine psb_lz_remote_mat
subroutine psb_z_remote_vect(v,desc_a, info) subroutine psb_z_remote_vect(n,v,iv,desc_a,x,ix, info)
use psb_base_mod, psb_protect_name => psb_z_remote_vect use psb_base_mod, psb_protect_name => psb_z_remote_vect
#ifdef MPI_MOD #ifdef MPI_MOD
@ -287,29 +286,25 @@ subroutine psb_z_remote_vect(v,desc_a, info)
#ifdef MPI_H #ifdef MPI_H
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: n
type(psb_z_vect_type),Intent(inout) :: v complex(psb_dpk_), Intent(in) :: v(:)
integer(psb_lpk_), Intent(in) :: iv(:)
type(psb_desc_type),intent(in) :: desc_a type(psb_desc_type),intent(in) :: desc_a
complex(psb_dpk_), allocatable, intent(out) :: x(:)
integer(psb_lpk_), allocatable, intent(out) :: ix(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! ...local scalars.... ! ...local scalars....
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & integer(psb_ipk_) :: counter, proc, i, &
& n_elem, j, ipx,mat_recv, idxs,idxr,& & j, idxs,idxr, k, iszs, iszr
& data_,totxch,nxs, nxr, ncg, dupl_
integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, &
& lidx, l1, lnr, lnc, lnnz, idx, ngtz, tot_elem
integer(psb_lpk_) :: nz,nouth
integer(psb_ipk_) :: nrcvs, nsnds integer(psb_ipk_) :: nrcvs, nsnds
integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_) :: icomm, minfo
integer(psb_mpk_), allocatable :: brvindx(:), & integer(psb_mpk_), allocatable :: brvindx(:), &
& rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:)
integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) integer(psb_lpk_), allocatable :: lsnd(:)
complex(psb_dpk_), allocatable :: valsnd(:) complex(psb_dpk_), allocatable :: valsnd(:)
integer(psb_ipk_), allocatable :: ila(:), iprc(:) integer(psb_ipk_), allocatable :: iprc(:)
logical :: rowcnv_,colcnv_,rowscale_,colscale_
character(len=5) :: outfmt_
integer(psb_ipk_) :: debug_level, debug_unit, err_act integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -327,150 +322,111 @@ subroutine psb_z_remote_vect(v,desc_a, info)
Call psb_info(ctxt, me, np) Call psb_info(ctxt, me, np)
dupl_ = v%get_dupl()
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start' & write(debug_unit,*) me,' ',trim(name),': Start'
write(0,*) me, 'X_remote_vect implementation to be completed ' write(0,*) me, 'X_remote_vect implementation to be completed '
!!$ call b%free()
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),&
!!$ Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& & bsdindx(np+1), stat=info)
!!$ & bsdindx(np+1), acoo,stat=info)
!!$ if (info /= psb_success_) then
!!$ if (info /= psb_success_) then info=psb_err_alloc_dealloc_
!!$ info=psb_err_alloc_dealloc_ call psb_errpush(info,name)
!!$ call psb_errpush(info,name) goto 9999
!!$ goto 9999 end if
!!$ end if
!!$ call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info)
!!$
!!$ nz = a%get_nzeros() icomm = desc_a%get_mpic()
!!$ allocate(ila(nz)) sdsz(:) = 0
!!$ !write(0,*) me,name,' size :',nz,size(ila) rvsz(:) = 0
!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) sdsi(:) = 0
!!$ nouth = count(ila(1:nz)<0) rvsi(:) = 0
!!$ !write(0,*) me,name,' Count out of halo :',nouth brvindx(:) = 0
!!$ call psb_max(ctxt,nouth) bsdindx(:) = 0
!!$ if ((nouth/=0).and.(me==0)) & counter = 1
!!$ & write(0,*) 'Warning: would require reinit of DESC_A' idxs = 0
!!$ idxr = 0
!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) do i=1,n
!!$ if (iprc(i) >=0) then
!!$ icomm = desc_a%get_mpic() sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1
!!$ sdsz(:)=0 else
!!$ rvsz(:)=0 write(0,*)me,name,' Error from fnd_owner: ',iprc(i)
!!$ sdsi(:)=0 end if
!!$ rvsi(:)=0 end do
!!$ ipx = 1 call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
!!$ brvindx(:) = 0 & rvsz,1,psb_mpi_mpk_,icomm,minfo)
!!$ bsdindx(:) = 0 if (minfo /= psb_success_) then
!!$ counter=1 info=psb_err_from_subroutine_
!!$ idx = 0 call psb_errpush(info,name,a_err='mpi_alltoall')
!!$ idxs = 0 goto 9999
!!$ idxr = 0 end if
!!$ do i=1,nz !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:)
!!$ if (iprc(i) >=0) then nsnds = count(sdsz /= 0)
!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 nrcvs = count(rvsz /= 0)
!!$ else idxs = 0
!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) idxr = 0
!!$ end if counter = 1
!!$ end do Do proc=0,np-1
!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& bsdindx(proc+1) = idxs
!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) idxs = idxs + sdsz(proc+1)
!!$ if (minfo /= psb_success_) then brvindx(proc+1) = idxr
!!$ info=psb_err_from_subroutine_ idxr = idxr + rvsz(proc+1)
!!$ call psb_errpush(info,name,a_err='mpi_alltoall') Enddo
!!$ goto 9999
!!$ end if iszs = sum(sdsz)
!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) iszr = sum(rvsz)
!!$ nsnds = count(sdsz /= 0) call psb_realloc(iszs,lsnd,info)
!!$ nrcvs = count(rvsz /= 0) if (info == 0) call psb_realloc(iszs,valsnd,info)
!!$ idxs = 0 if (info == 0) call psb_realloc(iszr,x,info)
!!$ idxr = 0 if (info == 0) call psb_realloc(iszr,ix,info)
!!$ counter = 1 if (info /= psb_success_) then
!!$ Do proc=0,np-1 info=psb_err_from_subroutine_
!!$ bsdindx(proc+1) = idxs call psb_errpush(info,name,a_err='realloc')
!!$ idxs = idxs + sdsz(proc+1) goto 9999
!!$ brvindx(proc+1) = idxr end if
!!$ idxr = idxr + rvsz(proc+1) do k=1, n
!!$ Enddo proc = iprc(k)
!!$ sdsi(proc+1) = sdsi(proc+1) + 1
!!$ iszs = sum(sdsz) lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k)
!!$ iszr = sum(rvsz) valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k)
!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) end do
!!$ if (psb_errstatus_fatal()) then do proc=0,np-1
!!$ write(0,*) 'Error from acoo%allocate ' if (sdsi(proc+1) /= sdsz(proc+1)) &
!!$ info = 4010 & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ goto 9999 end do
!!$ end if
!!$ if (debug_level >= psb_debug_outer_)& select case(psb_get_sp_a2av_alg())
!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_)
!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),': ',info & x,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,&
!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info & ix,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) case(psb_sp_a2av_mpi_)
!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info
!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,&
!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info & x,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo)
!!$ if (info /= psb_success_) then if (minfo == mpi_success) &
!!$ info=psb_err_from_subroutine_ & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ call psb_errpush(info,name,a_err='ensure_size') & ix,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ goto 9999 if (minfo /= mpi_success) info = minfo
!!$ end if case default
!!$ do k=1, nz info = psb_err_internal_error_
!!$ proc = iprc(k) call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ sdsi(proc+1) = sdsi(proc+1) + 1 goto 9999
!!$ !rvsi(proc) = rvsi(proc) + 1 end select
!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k)
!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) if (info /= psb_success_) then
!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) info=psb_err_from_subroutine_
!!$ end do call psb_errpush(info,name,a_err='alltoallv')
!!$ do proc=0,np-1 goto 9999
!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & end if
!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1)
!!$ end do Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & lsnd,valsnd,stat=info)
!!$ select case(psb_get_sp_a2av_alg()) if (debug_level >= psb_debug_outer_)&
!!$ case(psb_sp_a2av_smpl_triad_) & write(debug_unit,*) me,' ',trim(name),': Done'
!!$ call psb_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,&
!!$ & acoo%val,acoo%ia,acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_smpl_v_)
!!$ call psb_simple_a2av(valsnd,sdsz,bsdindx,&
!!$ & acoo%val,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(iasnd,sdsz,bsdindx,&
!!$ & acoo%ia,rvsz,brvindx,ctxt,info)
!!$ if (info == psb_success_) call psb_simple_a2av(jasnd,sdsz,bsdindx,&
!!$ & acoo%ja,rvsz,brvindx,ctxt,info)
!!$ case(psb_sp_a2av_mpi_)
!!$
!!$ call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,&
!!$ & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo == mpi_success) &
!!$ & call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,&
!!$ & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
!!$ if (minfo /= mpi_success) info = minfo
!!$ case default
!!$ info = psb_err_internal_error_
!!$ call psb_errpush(info,name,a_err='wrong A2AV alg selector')
!!$ goto 9999
!!$ end select
!!$
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='alltoallv')
!!$ goto 9999
!!$ end if
!!$ call acoo%set_nzeros(iszr)
!!$ call acoo%mv_to_coo(b,info)
!!$
!!$ Deallocate(brvindx,bsdindx,rvsz,sdsz,&
!!$ & iasnd,jasnd,valsnd,stat=info)
!!$ if (debug_level >= psb_debug_outer_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -480,5 +436,3 @@ subroutine psb_z_remote_vect(v,desc_a, info)
return return
End Subroutine psb_z_remote_vect End Subroutine psb_z_remote_vect

5
base/tools/psb_zallc.f90
Unescape Escape View File

@ -116,9 +116,11 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode)
end if end if
call x%set_dupl(dupl_) call x%set_dupl(dupl_)
call x%set_remote_build(bldmode_) call x%set_remote_build(bldmode_)
call x%set_nrmv(0)
if (x%is_remote_build()) then if (x%is_remote_build()) then
nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows())) nrmt_ = max(100,(desc_a%get_local_cols()-desc_a%get_local_rows()))
allocate(x%rmtv(nrmt_)) call psb_ensure_size(nrmt_,x%rmtv,info)
call psb_ensure_size(nrmt_,x%rmidx,info)
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -129,6 +131,7 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode)
return return
end subroutine psb_zalloc_vect end subroutine psb_zalloc_vect
! Function: psb_zalloc_vect_r2 ! Function: psb_zalloc_vect_r2
! Allocates a vector of dense vectors for PSBLAS routines. ! Allocates a vector of dense vectors for PSBLAS routines.
! The descriptor may be in either the build or assembled state. ! The descriptor may be in either the build or assembled state.

18
base/tools/psb_zasb.f90
Unescape Escape View File

@ -104,7 +104,23 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
call x%free(info) call x%free(info)
call x%bld(ncol,mold=mold) call x%bld(ncol,mold=mold)
else else
if (x%is_remote_build()) call psb_z_remote_vect(x,desc_a,info)
if (x%is_remote_build()) then
block
integer(psb_lpk_), allocatable :: lvx(:)
complex(psb_dpk_), allocatable :: vx(:)
integer(psb_ipk_), allocatable :: ivx(:)
integer(psb_ipk_) :: nrmv, nx, i
nrmv = x%get_nrmv()
call psb_z_remote_vect(nrmv,x%rmtv,x%rmidx,desc_a,vx,lvx,info)
nx = size(vx)
call psb_realloc(nx,ivx,info)
call desc_a%g2l(lvx,ivx,info,owned=.true.)
call x%ins(nx,ivx,vx,info)
end block
end if
call x%asb(ncol,info) call x%asb(ncol,info)
! ..update halo elements.. ! ..update halo elements..
call psb_halo(x,desc_a,info) call psb_halo(x,desc_a,info)

39
base/tools/psb_zins.f90
Unescape Escape View File

@ -116,7 +116,6 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -128,11 +127,33 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (x%is_remote_build()) then
block
integer(psb_ipk_) :: j,k
k = x%get_nrmv()
do j=1,m
if (irl(j) < 0 ) then
k = k + 1
call psb_ensure_size(k,x%rmtv,info)
if (info == 0) call psb_ensure_size(k,x%rmidx,info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
x%rmtv(k) = val(j)
x%rmidx(k) = irw(j)
call x%set_nrmv(k)
end if
end do
end block
end if
deallocate(irl) deallocate(irl)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -180,7 +201,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_ integer(psb_ipk_) :: np, me
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
complex(psb_dpk_), allocatable :: lval(:) complex(psb_dpk_), allocatable :: lval(:)
logical :: local_ logical :: local_
@ -227,7 +248,6 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -241,7 +261,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local)
call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,lval,dupl_,info) call x%ins(m,irl,lval,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -277,7 +297,6 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, local)
!locals..... !locals.....
integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_ipk_) :: i, loc_rows,loc_cols, n
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: dupl_
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
@ -349,8 +368,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, local)
do i=1,n do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) dupl_ = x(i)%get_dupl() if (info == 0) call x(i)%ins(m,irl,val(:,i),info)
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
if (info /= 0) exit if (info /= 0) exit
end do end do
if (info /= 0) then if (info /= 0) then
@ -390,7 +408,7 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, local)
integer(psb_ipk_) :: i, loc_rows,loc_cols integer(psb_ipk_) :: i, loc_rows,loc_cols
integer(psb_lpk_) :: mglob integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, dupl_, err_act integer(psb_ipk_) :: np, me, err_act
integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: irl(:)
logical :: local_ logical :: local_
character(len=20) :: name character(len=20) :: name
@ -446,7 +464,6 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, local)
goto 9999 goto 9999
endif endif
dupl_ = x%get_dupl()
if (present(local)) then if (present(local)) then
local_ = local local_ = local
else else
@ -458,7 +475,7 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, local)
else else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if end if
call x%ins(m,irl,val,dupl_,info) call x%ins(m,irl,val,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999

1
base/tools/psb_zspasb.f90
Unescape Escape View File

@ -109,7 +109,6 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold)
integer(psb_ipk_) :: nz, nzt,k integer(psb_ipk_) :: nz, nzt,k
call psb_remote_mat(a%rmta,desc_a,a_add,info) call psb_remote_mat(a%rmta,desc_a,a_add,info)
nz = a_add%get_nzeros() nz = a_add%get_nzeros()
!!$ write(0,*) me,name,' Nz to be added',nz
nzt = nz nzt = nz
call psb_sum(ctxt,nzt) call psb_sum(ctxt,nzt)
if (nzt>0) then if (nzt>0) then

Write Preview
Loading…
Cancel
Save