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

Finish vector assembly with REMOTE_BUILD. To be tested.

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

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

@ -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(:)

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

@ -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

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

@ -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(:)

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

@ -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

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

@ -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

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

@ -39,6 +39,7 @@
!
module psb_c_vect_mod
use psb_realloc_mod
use psb_c_base_vect_mod
use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_c_vect_mod
procedure, pass(x) :: set_remote_build => c_vect_set_remote_build
procedure, pass(x) :: get_dupl => c_vect_get_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
@ -198,6 +200,21 @@ contains
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)
implicit none
@ -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

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

@ -39,6 +39,7 @@
!
module psb_d_vect_mod
use psb_realloc_mod
use psb_d_base_vect_mod
use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_d_vect_mod
procedure, pass(x) :: set_remote_build => d_vect_set_remote_build
procedure, pass(x) :: get_dupl => d_vect_get_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
@ -205,6 +207,21 @@ contains
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)
implicit none
@ -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

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

@ -39,6 +39,7 @@
!
module psb_i_vect_mod
use psb_realloc_mod
use psb_i_base_vect_mod
type psb_i_vect_type
@ -56,6 +57,8 @@ module psb_i_vect_mod
procedure, pass(x) :: set_remote_build => i_vect_set_remote_build
procedure, pass(x) :: get_dupl => i_vect_get_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
@ -145,6 +147,21 @@ contains
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)
implicit none
@ -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

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

@ -39,6 +39,7 @@
!
module psb_l_vect_mod
use psb_realloc_mod
use psb_l_base_vect_mod
use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_l_vect_mod
procedure, pass(x) :: set_remote_build => l_vect_set_remote_build
procedure, pass(x) :: get_dupl => l_vect_get_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
@ -146,6 +148,21 @@ contains
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)
implicit none
@ -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

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

@ -39,6 +39,7 @@
!
module psb_s_vect_mod
use psb_realloc_mod
use psb_s_base_vect_mod
use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_s_vect_mod
procedure, pass(x) :: set_remote_build => s_vect_set_remote_build
procedure, pass(x) :: get_dupl => s_vect_get_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
@ -205,6 +207,21 @@ contains
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)
implicit none
@ -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

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

@ -39,6 +39,7 @@
!
module psb_z_vect_mod
use psb_realloc_mod
use psb_z_base_vect_mod
use psb_i_vect_mod
@ -57,6 +58,8 @@ module psb_z_vect_mod
procedure, pass(x) :: set_remote_build => z_vect_set_remote_build
procedure, pass(x) :: get_dupl => z_vect_get_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
@ -198,6 +200,21 @@ contains
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)
implicit none
@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -90,8 +90,7 @@ Subroutine psb_lc_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt
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

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

@ -116,9 +116,11 @@ subroutine psb_calloc_vect(x, desc_a,info, dupl, bldmode)
end if
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.

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

@ -104,7 +104,23 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
call x%free(info)
call x%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)

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

@ -116,7 +116,6 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, local)
goto 9999
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

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

@ -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

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

@ -90,8 +90,7 @@ Subroutine psb_ld_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt
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

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

@ -116,9 +116,11 @@ subroutine psb_dalloc_vect(x, desc_a,info, dupl, bldmode)
end if
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.

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

@ -104,7 +104,23 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
call x%free(info)
call x%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)

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

@ -116,7 +116,6 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, local)
goto 9999
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

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

@ -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

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

@ -116,9 +116,11 @@ subroutine psb_ialloc_vect(x, desc_a,info, dupl, bldmode)
end if
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.

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

@ -104,7 +104,23 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch)
call x%free(info)
call x%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)

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

@ -116,7 +116,6 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, local)
goto 9999
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

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

@ -116,9 +116,11 @@ subroutine psb_lalloc_vect(x, desc_a,info, dupl, bldmode)
end if
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.

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

@ -104,7 +104,23 @@ subroutine psb_lasb_vect(x, desc_a, info, mold, scratch)
call x%free(info)
call x%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)

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

@ -116,7 +116,6 @@ subroutine psb_lins_vect(m, irw, val, x, desc_a, info, local)
goto 9999
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

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

@ -90,8 +90,7 @@ Subroutine psb_ls_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt
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

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

@ -116,9 +116,11 @@ subroutine psb_salloc_vect(x, desc_a,info, dupl, bldmode)
end if
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.

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

@ -104,7 +104,23 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
call x%free(info)
call x%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)

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

@ -116,7 +116,6 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, local)
goto 9999
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

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

@ -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

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

@ -90,8 +90,7 @@ Subroutine psb_lz_remote_mat(a,desc_a,b,info)
type(psb_ctxt_type) :: ctxt
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

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

@ -116,9 +116,11 @@ subroutine psb_zalloc_vect(x, desc_a,info, dupl, bldmode)
end if
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.

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

@ -104,7 +104,23 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
call x%free(info)
call x%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)

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

@ -116,7 +116,6 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, local)
goto 9999
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

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

@ -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

Write Preview
Loading…
Cancel
Save