diff --git a/base/internals/psi_indx_map_fnd_owner.F90 b/base/internals/psi_indx_map_fnd_owner.F90 index dc9ab7f1..157b73a1 100644 --- a/base/internals/psi_indx_map_fnd_owner.F90 +++ b/base/internals/psi_indx_map_fnd_owner.F90 @@ -66,9 +66,9 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info,adj) #ifdef MPI_H include 'mpif.h' #endif - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) 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_), optional, allocatable, intent(out) :: adj(:) diff --git a/base/modules/desc/psb_gen_block_map_mod.F90 b/base/modules/desc/psb_gen_block_map_mod.F90 index 795a9d8f..dfb47b61 100644 --- a/base/modules/desc/psb_gen_block_map_mod.F90 +++ b/base/modules/desc/psb_gen_block_map_mod.F90 @@ -1057,8 +1057,8 @@ contains implicit none integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_gen_block_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: iam, np, nv, ip, i, nadj diff --git a/base/modules/desc/psb_glist_map_mod.f90 b/base/modules/desc/psb_glist_map_mod.f90 index 5f260d7e..4ddcdaca 100644 --- a/base/modules/desc/psb_glist_map_mod.f90 +++ b/base/modules/desc/psb_glist_map_mod.f90 @@ -157,7 +157,7 @@ contains implicit none integer(psb_lpk_), intent(in) :: idx(:) 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_), optional, allocatable, intent(out) :: adj(:) diff --git a/base/modules/desc/psb_indx_map_mod.f90 b/base/modules/desc/psb_indx_map_mod.f90 index 046a7f1f..7753db23 100644 --- a/base/modules/desc/psb_indx_map_mod.f90 +++ b/base/modules/desc/psb_indx_map_mod.f90 @@ -273,8 +273,8 @@ module psb_indx_map_mod implicit none integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_indx_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_indx_map), intent(in) :: idxmap + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) end subroutine psi_indx_map_fnd_owner end interface @@ -310,8 +310,8 @@ module psb_indx_map_mod integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: ladj(:) - class(psb_indx_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_indx_map), intent(in) :: idxmap + integer(psb_ipk_), intent(out) :: info end subroutine psi_graph_fnd_owner end interface @@ -1521,7 +1521,7 @@ contains use psb_error_mod use psb_realloc_mod 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(out) :: xout integer(psb_ipk_), intent(out) :: info @@ -1550,7 +1550,7 @@ contains use psb_error_mod use psb_realloc_mod 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(out) :: xout(:) integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/desc/psb_repl_map_mod.f90 b/base/modules/desc/psb_repl_map_mod.f90 index f360f6c3..fe51b7b1 100644 --- a/base/modules/desc/psb_repl_map_mod.f90 +++ b/base/modules/desc/psb_repl_map_mod.f90 @@ -701,8 +701,8 @@ contains implicit none integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_repl_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_repl_map), intent(in) :: idxmap + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, allocatable, intent(out) :: adj(:) integer(psb_ipk_) :: nv type(psb_ctxt_type) :: ctxt diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index a2620af5..3bd6f5ad 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -39,6 +39,7 @@ ! module psb_c_vect_mod + use psb_realloc_mod use psb_c_base_vect_mod use psb_i_vect_mod @@ -56,7 +57,9 @@ module psb_c_vect_mod procedure, pass(x) :: is_remote_build => c_vect_is_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) :: 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) :: reall => c_vect_reall 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_set_dev, c_vect_set_sync, & & 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, & & 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 - function c_vect_get_dupl(x) result(res) implicit none class(psb_c_vect_type), intent(in) :: x @@ -197,6 +199,21 @@ contains x%dupl = psb_dupl_def_ end if 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) @@ -410,14 +427,13 @@ contains if (allocated(x%v)) res = x%v%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 integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(in), optional :: mode if (allocated(x%v)) & & call x%free(info) @@ -432,9 +448,6 @@ contains else info = psb_err_alloc_dealloc_ 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 subroutine c_vect_reall(n, x, info) @@ -522,44 +535,44 @@ contains 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 implicit none 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(:) complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) 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 implicit none 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_c_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl%v,val%v,dupl,info) end subroutine c_vect_ins_v @@ -1670,23 +1683,23 @@ contains 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 implicit none 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(:) complex(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) end subroutine c_vect_ins diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 68aba8aa..21f9a7b7 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -39,6 +39,7 @@ ! module psb_d_vect_mod + use psb_realloc_mod use psb_d_base_vect_mod use psb_i_vect_mod @@ -56,7 +57,9 @@ module psb_d_vect_mod procedure, pass(x) :: is_remote_build => d_vect_is_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) :: 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) :: reall => d_vect_reall 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_set_dev, d_vect_set_sync, & & 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, & & 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 - function d_vect_get_dupl(x) result(res) implicit none class(psb_d_vect_type), intent(in) :: x @@ -204,6 +206,21 @@ contains x%dupl = psb_dupl_def_ end if 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) @@ -417,14 +434,13 @@ contains if (allocated(x%v)) res = x%v%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 integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(in), optional :: mode if (allocated(x%v)) & & call x%free(info) @@ -439,9 +455,6 @@ contains else info = psb_err_alloc_dealloc_ 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 subroutine d_vect_reall(n, x, info) @@ -529,44 +542,44 @@ contains 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 implicit none 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(:) real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) 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 implicit none 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_d_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl%v,val%v,dupl,info) end subroutine d_vect_ins_v @@ -1749,23 +1762,23 @@ contains 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 implicit none 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(:) real(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) end subroutine d_vect_ins diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index c4cd3178..aa14d903 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -39,6 +39,7 @@ ! module psb_i_vect_mod + use psb_realloc_mod use psb_i_base_vect_mod type psb_i_vect_type @@ -55,7 +56,9 @@ module psb_i_vect_mod procedure, pass(x) :: is_remote_build => i_vect_is_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) :: 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) :: reall => i_vect_reall 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_set_dev, i_vect_set_sync, & & 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,& @@ -125,7 +128,6 @@ module psb_i_vect_mod contains - function i_vect_get_dupl(x) result(res) implicit none class(psb_i_vect_type), intent(in) :: x @@ -144,6 +146,21 @@ contains x%dupl = psb_dupl_def_ end if 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) @@ -357,14 +374,13 @@ contains if (allocated(x%v)) res = x%v%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 integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(in), optional :: mode if (allocated(x%v)) & & call x%free(info) @@ -379,9 +395,6 @@ contains else info = psb_err_alloc_dealloc_ 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 subroutine i_vect_reall(n, x, info) @@ -469,44 +482,44 @@ contains 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 implicit none 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) :: val(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) 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 implicit none 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) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl%v,val%v,dupl,info) end subroutine i_vect_ins_v @@ -1027,23 +1040,23 @@ contains 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 implicit none 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) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) end subroutine i_vect_ins diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index b3579b17..de444e8d 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -39,6 +39,7 @@ ! module psb_l_vect_mod + use psb_realloc_mod use psb_l_base_vect_mod use psb_i_vect_mod @@ -56,7 +57,9 @@ module psb_l_vect_mod procedure, pass(x) :: is_remote_build => l_vect_is_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) :: 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) :: reall => l_vect_reall 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_set_dev, l_vect_set_sync, & & 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,& @@ -126,7 +129,6 @@ module psb_l_vect_mod contains - function l_vect_get_dupl(x) result(res) implicit none class(psb_l_vect_type), intent(in) :: x @@ -145,6 +147,21 @@ contains x%dupl = psb_dupl_def_ end if 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) @@ -358,14 +375,13 @@ contains if (allocated(x%v)) res = x%v%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 integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(in), optional :: mode if (allocated(x%v)) & & call x%free(info) @@ -380,9 +396,6 @@ contains else info = psb_err_alloc_dealloc_ 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 subroutine l_vect_reall(n, x, info) @@ -470,44 +483,44 @@ contains 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 implicit none 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_lpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) 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 implicit none 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_l_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl%v,val%v,dupl,info) end subroutine l_vect_ins_v @@ -1028,23 +1041,23 @@ contains 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 implicit none 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_lpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) end subroutine l_vect_ins diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index c15c6606..9ad61752 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -39,6 +39,7 @@ ! module psb_s_vect_mod + use psb_realloc_mod use psb_s_base_vect_mod use psb_i_vect_mod @@ -56,7 +57,9 @@ module psb_s_vect_mod procedure, pass(x) :: is_remote_build => s_vect_is_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) :: 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) :: reall => s_vect_reall 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_set_dev, s_vect_set_sync, & & 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, & & 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 - function s_vect_get_dupl(x) result(res) implicit none class(psb_s_vect_type), intent(in) :: x @@ -204,6 +206,21 @@ contains x%dupl = psb_dupl_def_ end if 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) @@ -417,14 +434,13 @@ contains if (allocated(x%v)) res = x%v%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 integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(in), optional :: mode if (allocated(x%v)) & & call x%free(info) @@ -439,9 +455,6 @@ contains else info = psb_err_alloc_dealloc_ 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 subroutine s_vect_reall(n, x, info) @@ -529,44 +542,44 @@ contains 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 implicit none 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(:) real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) 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 implicit none 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_s_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl%v,val%v,dupl,info) end subroutine s_vect_ins_v @@ -1749,23 +1762,23 @@ contains 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 implicit none 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(:) real(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) end subroutine s_vect_ins diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 7d2f3b9e..a962f5d0 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -39,6 +39,7 @@ ! module psb_z_vect_mod + use psb_realloc_mod use psb_z_base_vect_mod use psb_i_vect_mod @@ -56,7 +57,9 @@ module psb_z_vect_mod procedure, pass(x) :: is_remote_build => z_vect_is_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) :: 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) :: reall => z_vect_reall 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_set_dev, z_vect_set_sync, & & 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, & & 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 - function z_vect_get_dupl(x) result(res) implicit none class(psb_z_vect_type), intent(in) :: x @@ -197,6 +199,21 @@ contains x%dupl = psb_dupl_def_ end if 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) @@ -410,14 +427,13 @@ contains if (allocated(x%v)) res = x%v%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 integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type), intent(in), optional :: mold - integer(psb_ipk_), intent(in), optional :: mode if (allocated(x%v)) & & call x%free(info) @@ -432,9 +448,6 @@ contains else info = psb_err_alloc_dealloc_ 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 subroutine z_vect_reall(n, x, info) @@ -522,44 +535,44 @@ contains 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 implicit none 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(:) complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) 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 implicit none 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_z_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl%v,val%v,dupl,info) end subroutine z_vect_ins_v @@ -1670,23 +1683,23 @@ contains 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 implicit none 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(:) complex(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: i + integer(psb_ipk_) :: i, dupl info = 0 if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if - + dupl = x%get_dupl() call x%v%ins(n,irl,val,dupl,info) end subroutine z_vect_ins diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index c6e06134..78ec8518 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -263,11 +263,15 @@ Module psb_c_tools_mod end interface 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 implicit none - type(psb_c_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a + 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 + complex(psb_spk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_c_remote_vect end interface psb_remote_vect diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index 2c39bffd..30510123 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -263,11 +263,15 @@ Module psb_d_tools_mod end interface 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 implicit none - type(psb_d_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a + 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 + real(psb_dpk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_d_remote_vect end interface psb_remote_vect diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index 98d8dd8e..72033781 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -263,11 +263,15 @@ Module psb_s_tools_mod end interface 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 implicit none - type(psb_s_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a + 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 + real(psb_spk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_s_remote_vect end interface psb_remote_vect diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index 04960560..c96737b1 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -263,11 +263,15 @@ Module psb_z_tools_mod end interface 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 implicit none - type(psb_z_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a + 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 + complex(psb_dpk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_z_remote_vect end interface psb_remote_vect diff --git a/base/tools/psb_c_remote_mat.F90 b/base/tools/psb_c_remote_mat.F90 index 612c92dc..b66c615b 100644 --- a/base/tools/psb_c_remote_mat.F90 +++ b/base/tools/psb_c_remote_mat.F90 @@ -90,8 +90,7 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & data_,totxch,nxs, nxr, ncg + & n_elem, j, ipx,idxs,idxr 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 @@ -140,14 +139,14 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info) nz = a%get_nzeros() - allocate(ila(nz)) + !allocate(ila(nz)) !write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) + !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + !nouth = count(ila(1:nz)<0) !write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' + !call psb_max(ctxt,nouth) + !if ((nouth/=0).and.(me==0)) & + ! & write(0,*) 'Warning: would require reinit of DESC_A' 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 -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 #ifdef MPI_MOD @@ -287,29 +286,25 @@ subroutine psb_c_remote_vect(v,desc_a, info) #ifdef MPI_H include 'mpif.h' #endif - - type(psb_c_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - + 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 + complex(psb_spk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) + integer(psb_ipk_), intent(out) :: info ! ...local scalars.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me - integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & 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_) :: counter, proc, i, & + & j, idxs,idxr, k, iszs, iszr integer(psb_ipk_) :: nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) - integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) + integer(psb_lpk_), allocatable :: lsnd(:) complex(psb_spk_), allocatable :: valsnd(:) - integer(psb_ipk_), allocatable :: ila(:), iprc(:) - logical :: rowcnv_,colcnv_,rowscale_,colscale_ - character(len=5) :: outfmt_ + integer(psb_ipk_), allocatable :: iprc(:) integer(psb_ipk_) :: debug_level, debug_unit, err_act 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) - dupl_ = v%get_dupl() if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' 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),& -!!$ & bsdindx(np+1), acoo,stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ nz = a%get_nzeros() -!!$ allocate(ila(nz)) -!!$ !write(0,*) me,name,' size :',nz,size(ila) -!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) -!!$ nouth = count(ila(1:nz)<0) -!!$ !write(0,*) me,name,' Count out of halo :',nouth -!!$ call psb_max(ctxt,nouth) -!!$ if ((nouth/=0).and.(me==0)) & -!!$ & write(0,*) 'Warning: would require reinit of DESC_A' -!!$ -!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) -!!$ -!!$ icomm = desc_a%get_mpic() -!!$ sdsz(:)=0 -!!$ rvsz(:)=0 -!!$ sdsi(:)=0 -!!$ rvsi(:)=0 -!!$ ipx = 1 -!!$ brvindx(:) = 0 -!!$ bsdindx(:) = 0 -!!$ counter=1 -!!$ idx = 0 -!!$ idxs = 0 -!!$ idxr = 0 -!!$ do i=1,nz -!!$ if (iprc(i) >=0) then -!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 -!!$ else -!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) -!!$ end if -!!$ end do -!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& -!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) -!!$ if (minfo /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='mpi_alltoall') -!!$ goto 9999 -!!$ end if -!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) -!!$ nsnds = count(sdsz /= 0) -!!$ nrcvs = count(rvsz /= 0) -!!$ idxs = 0 -!!$ idxr = 0 -!!$ counter = 1 -!!$ Do proc=0,np-1 -!!$ bsdindx(proc+1) = idxs -!!$ idxs = idxs + sdsz(proc+1) -!!$ brvindx(proc+1) = idxr -!!$ idxr = idxr + rvsz(proc+1) -!!$ Enddo -!!$ -!!$ iszs = sum(sdsz) -!!$ iszr = sum(rvsz) -!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) -!!$ if (psb_errstatus_fatal()) then -!!$ write(0,*) 'Error from acoo%allocate ' -!!$ info = 4010 -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_outer_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& -!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) -!!$ !write(debug_unit,*) me,' ',trim(name),': ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='ensure_size') -!!$ goto 9999 -!!$ end if -!!$ do k=1, nz -!!$ proc = iprc(k) -!!$ sdsi(proc+1) = sdsi(proc+1) + 1 -!!$ !rvsi(proc) = rvsi(proc) + 1 -!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) -!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) -!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) -!!$ end do -!!$ do proc=0,np-1 -!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & -!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) -!!$ end do -!!$ -!!$ select case(psb_get_sp_a2av_alg()) -!!$ case(psb_sp_a2av_smpl_triad_) -!!$ 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' + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info) + + icomm = desc_a%get_mpic() + sdsz(:) = 0 + rvsz(:) = 0 + sdsi(:) = 0 + rvsi(:) = 0 + brvindx(:) = 0 + bsdindx(:) = 0 + counter = 1 + idxs = 0 + idxr = 0 + do i=1,n + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call psb_realloc(iszs,lsnd,info) + if (info == 0) call psb_realloc(iszs,valsnd,info) + if (info == 0) call psb_realloc(iszr,x,info) + if (info == 0) call psb_realloc(iszr,ix,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='realloc') + goto 9999 + end if + do k=1, n + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do + + select case(psb_get_sp_a2av_alg()) + case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_) + call psb_simple_a2av(valsnd,sdsz,bsdindx,& + & x,rvsz,brvindx,ctxt,info) + if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,& + & ix,rvsz,brvindx,ctxt,info) + case(psb_sp_a2av_mpi_) + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& + & x,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) + if (minfo == mpi_success) & + & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,& + & ix,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 + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & lsnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' call psb_erractionrestore(err_act) return @@ -480,5 +436,3 @@ subroutine psb_c_remote_vect(v,desc_a, info) return End Subroutine psb_c_remote_vect - - diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index 0c41be88..272ece8b 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -116,9 +116,11 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode) end if call x%set_dupl(dupl_) call x%set_remote_build(bldmode_) + call x%set_nrmv(0) if (x%is_remote_build()) then 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 call psb_erractionrestore(err_act) @@ -129,6 +131,7 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode) return end subroutine psb_calloc_vect + ! Function: psb_calloc_vect_r2 ! Allocates a vector of dense vectors for PSBLAS routines. ! The descriptor may be in either the build or assembled state. diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index c3cbe509..d43b062c 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -104,7 +104,23 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) call x%free(info) call x%bld(ncol,mold=mold) 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) ! ..update halo elements.. call psb_halo(x,desc_a,info) diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index d3f2ea99..180520a3 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -116,7 +116,6 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -128,11 +127,33 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 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) 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_lpk_) :: mglob type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: np, me integer(psb_ipk_), allocatable :: irl(:) complex(psb_spk_), allocatable :: lval(:) logical :: local_ @@ -227,7 +248,6 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, local) call psb_errpush(info,name) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local 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.) end if - call x%ins(m,irl,lval,dupl_,info) + call x%ins(m,irl,lval,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -277,7 +297,6 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, err_act 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 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),dupl_,info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info /= 0) exit end do 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_lpk_) :: mglob 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(:) logical :: local_ character(len=20) :: name @@ -446,7 +464,6 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -458,7 +475,7 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 index 08f18d00..d4a80771 100644 --- a/base/tools/psb_cspasb.f90 +++ b/base/tools/psb_cspasb.f90 @@ -108,8 +108,7 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold) integer(psb_ipk_), allocatable :: ila(:), jla(:) integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - nz = a_add%get_nzeros() -!!$ write(0,*) me,name,' Nz to be added',nz + nz = a_add%get_nzeros() nzt = nz call psb_sum(ctxt,nzt) if (nzt>0) then diff --git a/base/tools/psb_d_remote_mat.F90 b/base/tools/psb_d_remote_mat.F90 index ad9beba1..1a50e446 100644 --- a/base/tools/psb_d_remote_mat.F90 +++ b/base/tools/psb_d_remote_mat.F90 @@ -90,8 +90,7 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & data_,totxch,nxs, nxr, ncg + & n_elem, j, ipx,idxs,idxr 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 @@ -140,14 +139,14 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info) nz = a%get_nzeros() - allocate(ila(nz)) + !allocate(ila(nz)) !write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) + !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + !nouth = count(ila(1:nz)<0) !write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' + !call psb_max(ctxt,nouth) + !if ((nouth/=0).and.(me==0)) & + ! & write(0,*) 'Warning: would require reinit of DESC_A' 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 -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 #ifdef MPI_MOD @@ -287,29 +286,25 @@ subroutine psb_d_remote_vect(v,desc_a, info) #ifdef MPI_H include 'mpif.h' #endif - - type(psb_d_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - + 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 + real(psb_dpk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) + integer(psb_ipk_), intent(out) :: info ! ...local scalars.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me - integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & 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_) :: counter, proc, i, & + & j, idxs,idxr, k, iszs, iszr integer(psb_ipk_) :: nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) - integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) + integer(psb_lpk_), allocatable :: lsnd(:) real(psb_dpk_), allocatable :: valsnd(:) - integer(psb_ipk_), allocatable :: ila(:), iprc(:) - logical :: rowcnv_,colcnv_,rowscale_,colscale_ - character(len=5) :: outfmt_ + integer(psb_ipk_), allocatable :: iprc(:) integer(psb_ipk_) :: debug_level, debug_unit, err_act 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) - dupl_ = v%get_dupl() if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' 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),& -!!$ & bsdindx(np+1), acoo,stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ nz = a%get_nzeros() -!!$ allocate(ila(nz)) -!!$ !write(0,*) me,name,' size :',nz,size(ila) -!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) -!!$ nouth = count(ila(1:nz)<0) -!!$ !write(0,*) me,name,' Count out of halo :',nouth -!!$ call psb_max(ctxt,nouth) -!!$ if ((nouth/=0).and.(me==0)) & -!!$ & write(0,*) 'Warning: would require reinit of DESC_A' -!!$ -!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) -!!$ -!!$ icomm = desc_a%get_mpic() -!!$ sdsz(:)=0 -!!$ rvsz(:)=0 -!!$ sdsi(:)=0 -!!$ rvsi(:)=0 -!!$ ipx = 1 -!!$ brvindx(:) = 0 -!!$ bsdindx(:) = 0 -!!$ counter=1 -!!$ idx = 0 -!!$ idxs = 0 -!!$ idxr = 0 -!!$ do i=1,nz -!!$ if (iprc(i) >=0) then -!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 -!!$ else -!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) -!!$ end if -!!$ end do -!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& -!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) -!!$ if (minfo /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='mpi_alltoall') -!!$ goto 9999 -!!$ end if -!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) -!!$ nsnds = count(sdsz /= 0) -!!$ nrcvs = count(rvsz /= 0) -!!$ idxs = 0 -!!$ idxr = 0 -!!$ counter = 1 -!!$ Do proc=0,np-1 -!!$ bsdindx(proc+1) = idxs -!!$ idxs = idxs + sdsz(proc+1) -!!$ brvindx(proc+1) = idxr -!!$ idxr = idxr + rvsz(proc+1) -!!$ Enddo -!!$ -!!$ iszs = sum(sdsz) -!!$ iszr = sum(rvsz) -!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) -!!$ if (psb_errstatus_fatal()) then -!!$ write(0,*) 'Error from acoo%allocate ' -!!$ info = 4010 -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_outer_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& -!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) -!!$ !write(debug_unit,*) me,' ',trim(name),': ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='ensure_size') -!!$ goto 9999 -!!$ end if -!!$ do k=1, nz -!!$ proc = iprc(k) -!!$ sdsi(proc+1) = sdsi(proc+1) + 1 -!!$ !rvsi(proc) = rvsi(proc) + 1 -!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) -!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) -!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) -!!$ end do -!!$ do proc=0,np-1 -!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & -!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) -!!$ end do -!!$ -!!$ select case(psb_get_sp_a2av_alg()) -!!$ case(psb_sp_a2av_smpl_triad_) -!!$ 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' + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info) + + icomm = desc_a%get_mpic() + sdsz(:) = 0 + rvsz(:) = 0 + sdsi(:) = 0 + rvsi(:) = 0 + brvindx(:) = 0 + bsdindx(:) = 0 + counter = 1 + idxs = 0 + idxr = 0 + do i=1,n + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call psb_realloc(iszs,lsnd,info) + if (info == 0) call psb_realloc(iszs,valsnd,info) + if (info == 0) call psb_realloc(iszr,x,info) + if (info == 0) call psb_realloc(iszr,ix,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='realloc') + goto 9999 + end if + do k=1, n + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do + + select case(psb_get_sp_a2av_alg()) + case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_) + call psb_simple_a2av(valsnd,sdsz,bsdindx,& + & x,rvsz,brvindx,ctxt,info) + if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,& + & ix,rvsz,brvindx,ctxt,info) + case(psb_sp_a2av_mpi_) + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& + & x,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) + if (minfo == mpi_success) & + & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,& + & ix,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 + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & lsnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' call psb_erractionrestore(err_act) return @@ -480,5 +436,3 @@ subroutine psb_d_remote_vect(v,desc_a, info) return End Subroutine psb_d_remote_vect - - diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 24aecfe0..108e2000 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -116,9 +116,11 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode) end if call x%set_dupl(dupl_) call x%set_remote_build(bldmode_) + call x%set_nrmv(0) if (x%is_remote_build()) then 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 call psb_erractionrestore(err_act) @@ -129,6 +131,7 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode) return end subroutine psb_dalloc_vect + ! Function: psb_dalloc_vect_r2 ! Allocates a vector of dense vectors for PSBLAS routines. ! The descriptor may be in either the build or assembled state. diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index 44edbf4b..f8225496 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -104,7 +104,23 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) call x%free(info) call x%bld(ncol,mold=mold) 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) ! ..update halo elements.. call psb_halo(x,desc_a,info) diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 9a37e6df..d3529229 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -116,7 +116,6 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -128,11 +127,33 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 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) 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_lpk_) :: mglob type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: np, me integer(psb_ipk_), allocatable :: irl(:) real(psb_dpk_), allocatable :: lval(:) logical :: local_ @@ -227,7 +248,6 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, local) call psb_errpush(info,name) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local 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.) end if - call x%ins(m,irl,lval,dupl_,info) + call x%ins(m,irl,lval,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -277,7 +297,6 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, err_act 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 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),dupl_,info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info /= 0) exit end do 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_lpk_) :: mglob 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(:) logical :: local_ character(len=20) :: name @@ -446,7 +464,6 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -458,7 +475,7 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index f6497aef..b6139465 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -108,8 +108,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold) integer(psb_ipk_), allocatable :: ila(:), jla(:) integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - nz = a_add%get_nzeros() -!!$ write(0,*) me,name,' Nz to be added',nz + nz = a_add%get_nzeros() nzt = nz call psb_sum(ctxt,nzt) if (nzt>0) then diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index 5d192706..7ed69ed6 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -116,9 +116,11 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode) end if call x%set_dupl(dupl_) call x%set_remote_build(bldmode_) + call x%set_nrmv(0) if (x%is_remote_build()) then 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 call psb_erractionrestore(err_act) @@ -129,6 +131,7 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode) return end subroutine psb_ialloc_vect + ! Function: psb_ialloc_vect_r2 ! Allocates a vector of dense vectors for PSBLAS routines. ! The descriptor may be in either the build or assembled state. diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index a9244e96..5e09d331 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -104,7 +104,23 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) call x%free(info) call x%bld(ncol,mold=mold) 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) ! ..update halo elements.. call psb_halo(x,desc_a,info) diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 92257905..4fa53429 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -116,7 +116,6 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -128,11 +127,33 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 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) 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_lpk_) :: mglob 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 :: lval(:) logical :: local_ @@ -227,7 +248,6 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, local) call psb_errpush(info,name) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local 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.) end if - call x%ins(m,irl,lval,dupl_,info) + call x%ins(m,irl,lval,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -277,7 +297,6 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, err_act 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 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),dupl_,info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info /= 0) exit end do 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_lpk_) :: mglob 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(:) logical :: local_ character(len=20) :: name @@ -446,7 +464,6 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -458,7 +475,7 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 index 47ba201b..53857029 100644 --- a/base/tools/psb_lallc.f90 +++ b/base/tools/psb_lallc.f90 @@ -116,9 +116,11 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode) end if call x%set_dupl(dupl_) call x%set_remote_build(bldmode_) + call x%set_nrmv(0) if (x%is_remote_build()) then 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 call psb_erractionrestore(err_act) @@ -129,6 +131,7 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode) return end subroutine psb_lalloc_vect + ! Function: psb_lalloc_vect_r2 ! Allocates a vector of dense vectors for PSBLAS routines. ! The descriptor may be in either the build or assembled state. diff --git a/base/tools/psb_lasb.f90 b/base/tools/psb_lasb.f90 index b7bfb66c..1110ee11 100644 --- a/base/tools/psb_lasb.f90 +++ b/base/tools/psb_lasb.f90 @@ -104,7 +104,23 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) call x%free(info) call x%bld(ncol,mold=mold) 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) ! ..update halo elements.. call psb_halo(x,desc_a,info) diff --git a/base/tools/psb_lins.f90 b/base/tools/psb_lins.f90 index 224b6f8e..90da8111 100644 --- a/base/tools/psb_lins.f90 +++ b/base/tools/psb_lins.f90 @@ -116,7 +116,6 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -128,11 +127,33 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 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) 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_lpk_) :: mglob type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: np, me integer(psb_ipk_), allocatable :: irl(:) integer(psb_lpk_), allocatable :: lval(:) logical :: local_ @@ -227,7 +248,6 @@ subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, local) call psb_errpush(info,name) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local 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.) end if - call x%ins(m,irl,lval,dupl_,info) + call x%ins(m,irl,lval,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -277,7 +297,6 @@ subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, err_act 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 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),dupl_,info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info /= 0) exit end do 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_lpk_) :: mglob 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(:) logical :: local_ character(len=20) :: name @@ -446,7 +464,6 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -458,7 +475,7 @@ subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_s_remote_mat.F90 b/base/tools/psb_s_remote_mat.F90 index 1cccce94..3da9725c 100644 --- a/base/tools/psb_s_remote_mat.F90 +++ b/base/tools/psb_s_remote_mat.F90 @@ -90,8 +90,7 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & data_,totxch,nxs, nxr, ncg + & n_elem, j, ipx,idxs,idxr 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 @@ -140,14 +139,14 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info) nz = a%get_nzeros() - allocate(ila(nz)) + !allocate(ila(nz)) !write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) + !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + !nouth = count(ila(1:nz)<0) !write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' + !call psb_max(ctxt,nouth) + !if ((nouth/=0).and.(me==0)) & + ! & write(0,*) 'Warning: would require reinit of DESC_A' 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 -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 #ifdef MPI_MOD @@ -287,29 +286,25 @@ subroutine psb_s_remote_vect(v,desc_a, info) #ifdef MPI_H include 'mpif.h' #endif - - type(psb_s_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - + 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 + real(psb_spk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) + integer(psb_ipk_), intent(out) :: info ! ...local scalars.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me - integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & 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_) :: counter, proc, i, & + & j, idxs,idxr, k, iszs, iszr integer(psb_ipk_) :: nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) - integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) + integer(psb_lpk_), allocatable :: lsnd(:) real(psb_spk_), allocatable :: valsnd(:) - integer(psb_ipk_), allocatable :: ila(:), iprc(:) - logical :: rowcnv_,colcnv_,rowscale_,colscale_ - character(len=5) :: outfmt_ + integer(psb_ipk_), allocatable :: iprc(:) integer(psb_ipk_) :: debug_level, debug_unit, err_act 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) - dupl_ = v%get_dupl() if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' 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),& -!!$ & bsdindx(np+1), acoo,stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ nz = a%get_nzeros() -!!$ allocate(ila(nz)) -!!$ !write(0,*) me,name,' size :',nz,size(ila) -!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) -!!$ nouth = count(ila(1:nz)<0) -!!$ !write(0,*) me,name,' Count out of halo :',nouth -!!$ call psb_max(ctxt,nouth) -!!$ if ((nouth/=0).and.(me==0)) & -!!$ & write(0,*) 'Warning: would require reinit of DESC_A' -!!$ -!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) -!!$ -!!$ icomm = desc_a%get_mpic() -!!$ sdsz(:)=0 -!!$ rvsz(:)=0 -!!$ sdsi(:)=0 -!!$ rvsi(:)=0 -!!$ ipx = 1 -!!$ brvindx(:) = 0 -!!$ bsdindx(:) = 0 -!!$ counter=1 -!!$ idx = 0 -!!$ idxs = 0 -!!$ idxr = 0 -!!$ do i=1,nz -!!$ if (iprc(i) >=0) then -!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 -!!$ else -!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) -!!$ end if -!!$ end do -!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& -!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) -!!$ if (minfo /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='mpi_alltoall') -!!$ goto 9999 -!!$ end if -!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) -!!$ nsnds = count(sdsz /= 0) -!!$ nrcvs = count(rvsz /= 0) -!!$ idxs = 0 -!!$ idxr = 0 -!!$ counter = 1 -!!$ Do proc=0,np-1 -!!$ bsdindx(proc+1) = idxs -!!$ idxs = idxs + sdsz(proc+1) -!!$ brvindx(proc+1) = idxr -!!$ idxr = idxr + rvsz(proc+1) -!!$ Enddo -!!$ -!!$ iszs = sum(sdsz) -!!$ iszr = sum(rvsz) -!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) -!!$ if (psb_errstatus_fatal()) then -!!$ write(0,*) 'Error from acoo%allocate ' -!!$ info = 4010 -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_outer_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& -!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) -!!$ !write(debug_unit,*) me,' ',trim(name),': ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='ensure_size') -!!$ goto 9999 -!!$ end if -!!$ do k=1, nz -!!$ proc = iprc(k) -!!$ sdsi(proc+1) = sdsi(proc+1) + 1 -!!$ !rvsi(proc) = rvsi(proc) + 1 -!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) -!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) -!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) -!!$ end do -!!$ do proc=0,np-1 -!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & -!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) -!!$ end do -!!$ -!!$ select case(psb_get_sp_a2av_alg()) -!!$ case(psb_sp_a2av_smpl_triad_) -!!$ 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' + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info) + + icomm = desc_a%get_mpic() + sdsz(:) = 0 + rvsz(:) = 0 + sdsi(:) = 0 + rvsi(:) = 0 + brvindx(:) = 0 + bsdindx(:) = 0 + counter = 1 + idxs = 0 + idxr = 0 + do i=1,n + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call psb_realloc(iszs,lsnd,info) + if (info == 0) call psb_realloc(iszs,valsnd,info) + if (info == 0) call psb_realloc(iszr,x,info) + if (info == 0) call psb_realloc(iszr,ix,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='realloc') + goto 9999 + end if + do k=1, n + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do + + select case(psb_get_sp_a2av_alg()) + case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_) + call psb_simple_a2av(valsnd,sdsz,bsdindx,& + & x,rvsz,brvindx,ctxt,info) + if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,& + & ix,rvsz,brvindx,ctxt,info) + case(psb_sp_a2av_mpi_) + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& + & x,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) + if (minfo == mpi_success) & + & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,& + & ix,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 + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & lsnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' call psb_erractionrestore(err_act) return @@ -480,5 +436,3 @@ subroutine psb_s_remote_vect(v,desc_a, info) return End Subroutine psb_s_remote_vect - - diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 13b6368e..951d8128 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -116,9 +116,11 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode) end if call x%set_dupl(dupl_) call x%set_remote_build(bldmode_) + call x%set_nrmv(0) if (x%is_remote_build()) then 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 call psb_erractionrestore(err_act) @@ -129,6 +131,7 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode) return end subroutine psb_salloc_vect + ! Function: psb_salloc_vect_r2 ! Allocates a vector of dense vectors for PSBLAS routines. ! The descriptor may be in either the build or assembled state. diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 69bc10b2..7238fecf 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -104,7 +104,23 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) call x%free(info) call x%bld(ncol,mold=mold) 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) ! ..update halo elements.. call psb_halo(x,desc_a,info) diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index 2c41be7d..ddead81f 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -116,7 +116,6 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -128,11 +127,33 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 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) 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_lpk_) :: mglob type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: np, me integer(psb_ipk_), allocatable :: irl(:) real(psb_spk_), allocatable :: lval(:) logical :: local_ @@ -227,7 +248,6 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, local) call psb_errpush(info,name) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local 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.) end if - call x%ins(m,irl,lval,dupl_,info) + call x%ins(m,irl,lval,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -277,7 +297,6 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, err_act 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 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),dupl_,info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info /= 0) exit end do 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_lpk_) :: mglob 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(:) logical :: local_ character(len=20) :: name @@ -446,7 +464,6 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -458,7 +475,7 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 index 4b0c8ad4..143e7a2f 100644 --- a/base/tools/psb_sspasb.f90 +++ b/base/tools/psb_sspasb.f90 @@ -108,8 +108,7 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold) integer(psb_ipk_), allocatable :: ila(:), jla(:) integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - nz = a_add%get_nzeros() -!!$ write(0,*) me,name,' Nz to be added',nz + nz = a_add%get_nzeros() nzt = nz call psb_sum(ctxt,nzt) if (nzt>0) then diff --git a/base/tools/psb_z_remote_mat.F90 b/base/tools/psb_z_remote_mat.F90 index 2c921570..7929c1e5 100644 --- a/base/tools/psb_z_remote_mat.F90 +++ b/base/tools/psb_z_remote_mat.F90 @@ -90,8 +90,7 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info) type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & data_,totxch,nxs, nxr, ncg + & n_elem, j, ipx,idxs,idxr 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 @@ -140,14 +139,14 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info) nz = a%get_nzeros() - allocate(ila(nz)) + !allocate(ila(nz)) !write(0,*) me,name,' size :',nz,size(ila) - call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) - nouth = count(ila(1:nz)<0) + !call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) + !nouth = count(ila(1:nz)<0) !write(0,*) me,name,' Count out of halo :',nouth - call psb_max(ctxt,nouth) - if ((nouth/=0).and.(me==0)) & - & write(0,*) 'Warning: would require reinit of DESC_A' + !call psb_max(ctxt,nouth) + !if ((nouth/=0).and.(me==0)) & + ! & write(0,*) 'Warning: would require reinit of DESC_A' 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 -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 #ifdef MPI_MOD @@ -287,29 +286,25 @@ subroutine psb_z_remote_vect(v,desc_a, info) #ifdef MPI_H include 'mpif.h' #endif - - type(psb_z_vect_type),Intent(inout) :: v - type(psb_desc_type),intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - + 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 + complex(psb_dpk_), allocatable, intent(out) :: x(:) + integer(psb_lpk_), allocatable, intent(out) :: ix(:) + integer(psb_ipk_), intent(out) :: info ! ...local scalars.... type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np,me - integer(psb_ipk_) :: counter, proc, i, n_el_send,n_el_recv, & - & n_elem, j, ipx,mat_recv, idxs,idxr,& - & 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_) :: counter, proc, i, & + & j, idxs,idxr, k, iszs, iszr integer(psb_ipk_) :: nrcvs, nsnds integer(psb_mpk_) :: icomm, minfo integer(psb_mpk_), allocatable :: brvindx(:), & - & rvsz(:), bsdindx(:),sdsz(:), sdsi(:), rvsi(:) - integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + & rvsz(:), bsdindx(:), sdsz(:), sdsi(:), rvsi(:) + integer(psb_lpk_), allocatable :: lsnd(:) complex(psb_dpk_), allocatable :: valsnd(:) - integer(psb_ipk_), allocatable :: ila(:), iprc(:) - logical :: rowcnv_,colcnv_,rowscale_,colscale_ - character(len=5) :: outfmt_ + integer(psb_ipk_), allocatable :: iprc(:) integer(psb_ipk_) :: debug_level, debug_unit, err_act 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) - dupl_ = v%get_dupl() if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),': Start' 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),& -!!$ & bsdindx(np+1), acoo,stat=info) -!!$ -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_dealloc_ -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ -!!$ nz = a%get_nzeros() -!!$ allocate(ila(nz)) -!!$ !write(0,*) me,name,' size :',nz,size(ila) -!!$ call desc_a%g2l(a%ia(1:nz),ila(1:nz),info,owned=.false.) -!!$ nouth = count(ila(1:nz)<0) -!!$ !write(0,*) me,name,' Count out of halo :',nouth -!!$ call psb_max(ctxt,nouth) -!!$ if ((nouth/=0).and.(me==0)) & -!!$ & write(0,*) 'Warning: would require reinit of DESC_A' -!!$ -!!$ call desc_a%indxmap%fnd_owner(a%ia(1:nz),iprc,info) -!!$ -!!$ icomm = desc_a%get_mpic() -!!$ sdsz(:)=0 -!!$ rvsz(:)=0 -!!$ sdsi(:)=0 -!!$ rvsi(:)=0 -!!$ ipx = 1 -!!$ brvindx(:) = 0 -!!$ bsdindx(:) = 0 -!!$ counter=1 -!!$ idx = 0 -!!$ idxs = 0 -!!$ idxr = 0 -!!$ do i=1,nz -!!$ if (iprc(i) >=0) then -!!$ sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 -!!$ else -!!$ write(0,*)me,name,' Error from fnd_owner: ',iprc(i) -!!$ end if -!!$ end do -!!$ call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& -!!$ & rvsz,1,psb_mpi_mpk_,icomm,minfo) -!!$ if (minfo /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='mpi_alltoall') -!!$ goto 9999 -!!$ end if -!!$ !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) -!!$ nsnds = count(sdsz /= 0) -!!$ nrcvs = count(rvsz /= 0) -!!$ idxs = 0 -!!$ idxr = 0 -!!$ counter = 1 -!!$ Do proc=0,np-1 -!!$ bsdindx(proc+1) = idxs -!!$ idxs = idxs + sdsz(proc+1) -!!$ brvindx(proc+1) = idxr -!!$ idxr = idxr + rvsz(proc+1) -!!$ Enddo -!!$ -!!$ iszs = sum(sdsz) -!!$ iszr = sum(rvsz) -!!$ call acoo%allocate(desc_a%get_global_rows(),desc_a%get_global_cols(),iszr) -!!$ if (psb_errstatus_fatal()) then -!!$ write(0,*) 'Error from acoo%allocate ' -!!$ info = 4010 -!!$ goto 9999 -!!$ end if -!!$ if (debug_level >= psb_debug_outer_)& -!!$ & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& -!!$ & ' Send:',sdsz(:),' Receive:',rvsz(:) -!!$ !write(debug_unit,*) me,' ',trim(name),': ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' iasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' jasnd: ',info -!!$ if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) -!!$ !write(debug_unit,*) me,' ',trim(name),' valsnd: ',info -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='ensure_size') -!!$ goto 9999 -!!$ end if -!!$ do k=1, nz -!!$ proc = iprc(k) -!!$ sdsi(proc+1) = sdsi(proc+1) + 1 -!!$ !rvsi(proc) = rvsi(proc) + 1 -!!$ iasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ia(k) -!!$ jasnd(bsdindx(proc+1)+sdsi(proc+1)) = a%ja(k) -!!$ valsnd(bsdindx(proc+1)+sdsi(proc+1)) = a%val(k) -!!$ end do -!!$ do proc=0,np-1 -!!$ if (sdsi(proc+1) /= sdsz(proc+1)) & -!!$ & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) -!!$ end do -!!$ -!!$ select case(psb_get_sp_a2av_alg()) -!!$ case(psb_sp_a2av_smpl_triad_) -!!$ 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' + + Allocate(rvsz(np),sdsz(np),sdsi(np),rvsi(np),brvindx(np+1),& + & bsdindx(np+1), stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + call desc_a%indxmap%fnd_owner(iv(1:n),iprc,info) + + icomm = desc_a%get_mpic() + sdsz(:) = 0 + rvsz(:) = 0 + sdsi(:) = 0 + rvsi(:) = 0 + brvindx(:) = 0 + bsdindx(:) = 0 + counter = 1 + idxs = 0 + idxr = 0 + do i=1,n + if (iprc(i) >=0) then + sdsz(iprc(i)+1) = sdsz(iprc(i)+1) +1 + else + write(0,*)me,name,' Error from fnd_owner: ',iprc(i) + end if + end do + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (minfo /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + !write(0,*)me,name,' sdsz ',sdsz(:),' rvsz:',rvsz(:) + nsnds = count(sdsz /= 0) + nrcvs = count(rvsz /= 0) + idxs = 0 + idxr = 0 + counter = 1 + Do proc=0,np-1 + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + Enddo + + iszs = sum(sdsz) + iszr = sum(rvsz) + call psb_realloc(iszs,lsnd,info) + if (info == 0) call psb_realloc(iszs,valsnd,info) + if (info == 0) call psb_realloc(iszr,x,info) + if (info == 0) call psb_realloc(iszr,ix,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='realloc') + goto 9999 + end if + do k=1, n + proc = iprc(k) + sdsi(proc+1) = sdsi(proc+1) + 1 + lsnd(bsdindx(proc+1)+sdsi(proc+1)) = iv(k) + valsnd(bsdindx(proc+1)+sdsi(proc+1)) = v(k) + end do + do proc=0,np-1 + if (sdsi(proc+1) /= sdsz(proc+1)) & + & write(0,*) me,name,'Send mismacth ',sdsi(proc+1),sdsz(proc+1) + end do + + select case(psb_get_sp_a2av_alg()) + case(psb_sp_a2av_smpl_triad_,psb_sp_a2av_smpl_v_) + call psb_simple_a2av(valsnd,sdsz,bsdindx,& + & x,rvsz,brvindx,ctxt,info) + if (info == psb_success_) call psb_simple_a2av(lsnd,sdsz,bsdindx,& + & ix,rvsz,brvindx,ctxt,info) + case(psb_sp_a2av_mpi_) + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& + & x,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) + if (minfo == mpi_success) & + & call mpi_alltoallv(lsnd,sdsz,bsdindx,psb_mpi_lpk_,& + & ix,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 + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & lsnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' call psb_erractionrestore(err_act) return @@ -480,5 +436,3 @@ subroutine psb_z_remote_vect(v,desc_a, info) return End Subroutine psb_z_remote_vect - - diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index d40ce62a..be4d9089 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -116,9 +116,11 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode) end if call x%set_dupl(dupl_) call x%set_remote_build(bldmode_) + call x%set_nrmv(0) if (x%is_remote_build()) then 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 call psb_erractionrestore(err_act) @@ -129,6 +131,7 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode) return end subroutine psb_zalloc_vect + ! Function: psb_zalloc_vect_r2 ! Allocates a vector of dense vectors for PSBLAS routines. ! The descriptor may be in either the build or assembled state. diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 1cca7ea2..11c08d6d 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -104,7 +104,23 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) call x%free(info) call x%bld(ncol,mold=mold) 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) ! ..update halo elements.. call psb_halo(x,desc_a,info) diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index 4d000093..43e5d5cd 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -116,7 +116,6 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -128,11 +127,33 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 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) 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_lpk_) :: mglob type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: np, me integer(psb_ipk_), allocatable :: irl(:) complex(psb_dpk_), allocatable :: lval(:) logical :: local_ @@ -227,7 +248,6 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, local) call psb_errpush(info,name) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local 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.) end if - call x%ins(m,irl,lval,dupl_,info) + call x%ins(m,irl,lval,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -277,7 +297,6 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, local) !locals..... integer(psb_ipk_) :: i, loc_rows,loc_cols, n integer(psb_lpk_) :: mglob - integer(psb_ipk_) :: dupl_ type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, err_act 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 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),dupl_,info) + if (info == 0) call x(i)%ins(m,irl,val(:,i),info) if (info /= 0) exit end do 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_lpk_) :: mglob 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(:) logical :: local_ character(len=20) :: name @@ -446,7 +464,6 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, local) goto 9999 endif - dupl_ = x%get_dupl() if (present(local)) then local_ = local else @@ -458,7 +475,7 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, local) else call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) end if - call x%ins(m,irl,val,dupl_,info) + call x%ins(m,irl,val,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index 4f516f74..db229b17 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -108,8 +108,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold) integer(psb_ipk_), allocatable :: ila(:), jla(:) integer(psb_ipk_) :: nz, nzt,k call psb_remote_mat(a%rmta,desc_a,a_add,info) - nz = a_add%get_nzeros() -!!$ write(0,*) me,name,' Nz to be added',nz + nz = a_add%get_nzeros() nzt = nz call psb_sum(ctxt,nzt) if (nzt>0) then